commit 6cd3c9f4be16df3cbd615a37204ca5f37e441b4d Author: denghao Date: Fri Sep 2 08:44:07 2022 +0300 Import Upstream version 2.004 diff --git a/Changes b/Changes new file mode 100644 index 0000000..3b081fa --- /dev/null +++ b/Changes @@ -0,0 +1,94 @@ +2.004 2020-03-27 + + Main change: This module is now distributed under Artistic + 2.0 license (instead of Artistic 1.0) + + Other changes are + * add contributors section + * clarify and fix typos in documentation + * Added minimum perl version as suggested by CPANTS. + (Thanks Mohammad S Anwar) + +2014-12-24 v2.003 + + * Added set, set_range_as_string and get_range_list methods + * mention that consolidate can be called without arguments + +2010-09-28 Dominique Dumont v2.002 + + * Array/IntSpan.pm (lookup): returns undef on an empty object + without mucking up internal data (Fixes RT 61700. Thanks to + Matthew Nodine for the report) + +2004-01-29 Dominique Dumont v2.001 + + * IntSpan.pm: Updated copyright infos + +2003-05-26 Dominique Dumont + + * IntSpan.pm, IntSpan/Fields.pm: + - bug fix in Fields::adapt_range_in_cb: method can be undef + +2003-04-17 Dominique Dumont + + * IntSpan.pm, IntSpan/Fields.pm: + - small code refactoring and perf improvement + +2003-03-19 Dominique Dumont + + * IntSpan.pm: - added clear function in IntSpan + +2003-03-07 Dominique Dumont + + * IntSpan.pm: - some optimizations + - cannot create range with undef values. + +2003-03-04 Dominique Dumont + + * IntSpan.pm, IntSpan/Fields.pm: - added Array::IntSpan::Fields + - callback signature are now (start, end, [payload]) + +2003-02-24 Dominique Dumont + + * IntSpan.pm: - various get_range bug_fixes + +2003-02-14 Dominique Dumont + + * IntSpan.pm: + - get_range bug with fill: read range is now also modified + +2003-02-13 Dominique Dumont + + * IntSpan.pm: - get_range: bug fix with filler subf + + * IntSpan.pm: + - get_range: fill can be done with a sub ref + - set_*_range: copy of splitted range items can be done using a + sub ref. In this case the original value is passed to the sub + ref. It must return the new value + +2003-02-12 Dominique Dumont + + * IntSpan.pm: - added fill parameter to get_range + - split tests + + * IntSpan.pm: - bug fix in empty ranges + +2003-02-11 Dominique Dumont + + * IntSpan.pm: - better get_range and set_range + +2003-02-06 Dominique Dumont + + * IntSpan.pm: Modified version 1.02 with consolidation + + * IntSpan.pm, IntSpan/IP.pm: Initial version 1.01 from Toby Everett + + * IntSpan.pm, IntSpan/IP.pm: New file. + + +1.01 Thu Feb 24 14:10:00 2000 + - fixed Makefile.PL + +1.00 Thu Feb 24 14:00:00 2000 + - original version diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e44d2f2 --- /dev/null +++ b/LICENSE @@ -0,0 +1,207 @@ +This software is Copyright (c) 2014 by Dominique Dumont. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + + The Artistic License 2.0 + + Copyright (c) 2000-2006, The Perl Foundation. + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +Preamble + +This license establishes the terms under which a given free software +Package may be copied, modified, distributed, and/or redistributed. +The intent is that the Copyright Holder maintains some artistic +control over the development of that Package while still keeping the +Package available as open source and free software. + +You are always permitted to make arrangements wholly outside of this +license directly with the Copyright Holder of a given Package. If the +terms of this license do not permit the full use that you propose to +make of the Package, you should contact the Copyright Holder and seek +a different licensing arrangement. + +Definitions + + "Copyright Holder" means the individual(s) or organization(s) + named in the copyright notice for the entire Package. + + "Contributor" means any party that has contributed code or other + material to the Package, in accordance with the Copyright Holder's + procedures. + + "You" and "your" means any person who would like to copy, + distribute, or modify the Package. + + "Package" means the collection of files distributed by the + Copyright Holder, and derivatives of that collection and/or of + those files. A given Package may consist of either the Standard + Version, or a Modified Version. + + "Distribute" means providing a copy of the Package or making it + accessible to anyone else, or in the case of a company or + organization, to others outside of your company or organization. + + "Distributor Fee" means any fee that you charge for Distributing + this Package or providing support for this Package to another + party. It does not mean licensing fees. + + "Standard Version" refers to the Package if it has not been + modified, or has been modified only in ways explicitly requested + by the Copyright Holder. + + "Modified Version" means the Package, if it has been changed, and + such changes were not explicitly requested by the Copyright + Holder. + + "Original License" means this Artistic License as Distributed with + the Standard Version of the Package, in its current version or as + it may be modified by The Perl Foundation in the future. + + "Source" form means the source code, documentation source, and + configuration files for the Package. + + "Compiled" form means the compiled bytecode, object code, binary, + or any other form resulting from mechanical transformation or + translation of the Source form. + + +Permission for Use and Modification Without Distribution + +(1) You are permitted to use the Standard Version and create and use +Modified Versions for any purpose without restriction, provided that +you do not Distribute the Modified Version. + + +Permissions for Redistribution of the Standard Version + +(2) You may Distribute verbatim copies of the Source form of the +Standard Version of this Package in any medium without restriction, +either gratis or for a Distributor Fee, provided that you duplicate +all of the original copyright notices and associated disclaimers. At +your discretion, such verbatim copies may or may not include a +Compiled form of the Package. + +(3) You may apply any bug fixes, portability changes, and other +modifications made available from the Copyright Holder. The resulting +Package will still be considered the Standard Version, and as such +will be subject to the Original License. + + +Distribution of Modified Versions of the Package as Source + +(4) You may Distribute your Modified Version as Source (either gratis +or for a Distributor Fee, and with or without a Compiled form of the +Modified Version) provided that you clearly document how it differs +from the Standard Version, including, but not limited to, documenting +any non-standard features, executables, or modules, and provided that +you do at least ONE of the following: + + (a) make the Modified Version available to the Copyright Holder + of the Standard Version, under the Original License, so that the + Copyright Holder may include your modifications in the Standard + Version. + + (b) ensure that installation of your Modified Version does not + prevent the user installing or running the Standard Version. In + addition, the Modified Version must bear a name that is different + from the name of the Standard Version. + + (c) allow anyone who receives a copy of the Modified Version to + make the Source form of the Modified Version available to others + under + + (i) the Original License or + + (ii) a license that permits the licensee to freely copy, + modify and redistribute the Modified Version using the same + licensing terms that apply to the copy that the licensee + received, and requires that the Source form of the Modified + Version, and of any works derived from it, be made freely + available in that license fees are prohibited but Distributor + Fees are allowed. + + +Distribution of Compiled Forms of the Standard Version +or Modified Versions without the Source + +(5) You may Distribute Compiled forms of the Standard Version without +the Source, provided that you include complete instructions on how to +get the Source of the Standard Version. Such instructions must be +valid at the time of your distribution. If these instructions, at any +time while you are carrying out such distribution, become invalid, you +must provide new instructions on demand or cease further distribution. +If you provide valid instructions or cease distribution within thirty +days after you become aware that the instructions are invalid, then +you do not forfeit any of your rights under this license. + +(6) You may Distribute a Modified Version in Compiled form without +the Source, provided that you comply with Section 4 with respect to +the Source of the Modified Version. + + +Aggregating or Linking the Package + +(7) You may aggregate the Package (either the Standard Version or +Modified Version) with other packages and Distribute the resulting +aggregation provided that you do not charge a licensing fee for the +Package. Distributor Fees are permitted, and licensing fees for other +components in the aggregation are permitted. The terms of this license +apply to the use and Distribution of the Standard or Modified Versions +as included in the aggregation. + +(8) You are permitted to link Modified and Standard Versions with +other works, to embed the Package in a larger work of your own, or to +build stand-alone binary or bytecode versions of applications that +include the Package, and Distribute the result without restriction, +provided the result does not expose a direct interface to the Package. + + +Items That are Not Considered Part of a Modified Version + +(9) Works (including, but not limited to, modules and scripts) that +merely extend or make use of the Package, do not, by themselves, cause +the Package to be a Modified Version. In addition, such works are not +considered parts of the Package itself, and are not subject to the +terms of this license. + + +General Provisions + +(10) Any use, modification, and distribution of the Standard or +Modified Versions is governed by this Artistic License. By using, +modifying or distributing the Package, you accept this license. Do not +use, modify, or distribute the Package, if you do not accept this +license. + +(11) If your Modified Version has been derived from a Modified +Version made by someone other than you, you are nevertheless required +to ensure that your Modified Version complies with the requirements of +this license. + +(12) This license does not grant you the right to use any trademark, +service mark, tradename, or logo of the Copyright Holder. + +(13) This license includes the non-exclusive, worldwide, +free-of-charge patent license to make, have made, use, offer to sell, +sell, import and otherwise transfer the Package with respect to any +patent claims licensable by the Copyright Holder that are necessarily +infringed by the Package. If you institute patent litigation +(including a cross-claim or counterclaim) against any party alleging +that the Package constitutes direct or contributory patent +infringement, then this Artistic License to you shall terminate on the +date that such litigation is filed. + +(14) Disclaimer of Warranty: +THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS +IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED +WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR +NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL +LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL +BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL +DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3b7a046 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,20 @@ +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.014. +Changes +LICENSE +MANIFEST +META.json +META.yml +Makefile.PL +README +dist.ini +lib/Array/IntSpan.pm +lib/Array/IntSpan/Fields.pm +lib/Array/IntSpan/IP.pm +t/clobbered_items.t +t/consolidate.t +t/empty_span.t +t/fields.t +t/get_range.t +t/get_splice_parms.t +t/search.t +t/set_range.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..01504f3 --- /dev/null +++ b/META.json @@ -0,0 +1,67 @@ +{ + "abstract" : "Handles arrays of scalars or objects using integer ranges", + "author" : [ + "Dominique Dumont" + ], + "dynamic_config" : 0, + "generated_by" : "Dist::Zilla version 6.014, CPAN::Meta::Converter version 2.150010", + "license" : [ + "artistic_2" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Array-IntSpan", + "prereqs" : { + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Carp" : "0", + "perl" : "5.008" + } + }, + "test" : { + "requires" : { + "Data::Dumper" : "0", + "Test::More" : "0" + } + } + }, + "provides" : { + "Array::IntSpan" : { + "file" : "lib/Array/IntSpan.pm", + "version" : "2.004" + }, + "Array::IntSpan::Fields" : { + "file" : "lib/Array/IntSpan/Fields.pm", + "version" : "2.004" + }, + "Array::IntSpan::IP" : { + "file" : "lib/Array/IntSpan/IP.pm", + "version" : "2.004" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-project@rt.cpan.org", + "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Array-IntSpan" + }, + "homepage" : "https://github.com/dod38fr/array-intspan-perl", + "repository" : { + "type" : "git", + "url" : "https://github.com/dod38fr/array-intspan-perl.git", + "web" : "https://github.com/dod38fr/array-intspan-perl" + } + }, + "version" : "2.004", + "x_generated_by_perl" : "v5.30.0", + "x_serialization_backend" : "Cpanel::JSON::XS version 4.19", + "x_spdx_expression" : "Artistic-2.0" +} + diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..0a36ec0 --- /dev/null +++ b/META.yml @@ -0,0 +1,37 @@ +--- +abstract: 'Handles arrays of scalars or objects using integer ranges' +author: + - 'Dominique Dumont' +build_requires: + Data::Dumper: '0' + Test::More: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 0 +generated_by: 'Dist::Zilla version 6.014, CPAN::Meta::Converter version 2.150010' +license: artistic_2 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Array-IntSpan +provides: + Array::IntSpan: + file: lib/Array/IntSpan.pm + version: '2.004' + Array::IntSpan::Fields: + file: lib/Array/IntSpan/Fields.pm + version: '2.004' + Array::IntSpan::IP: + file: lib/Array/IntSpan/IP.pm + version: '2.004' +requires: + Carp: '0' + perl: '5.008' +resources: + bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Array-IntSpan + homepage: https://github.com/dod38fr/array-intspan-perl + repository: https://github.com/dod38fr/array-intspan-perl.git +version: '2.004' +x_generated_by_perl: v5.30.0 +x_serialization_backend: 'YAML::Tiny version 1.73' +x_spdx_expression: Artistic-2.0 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..656c101 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,58 @@ +# +# This file is part of Array-IntSpan +# +# This software is Copyright (c) 2014 by Dominique Dumont. +# +# This is free software, licensed under: +# +# The Artistic License 2.0 (GPL Compatible) +# +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.014. +use strict; +use warnings; + +use 5.008; + +use ExtUtils::MakeMaker; + +my %WriteMakefileArgs = ( + "ABSTRACT" => "Handles arrays of scalars or objects using integer ranges", + "AUTHOR" => "Dominique Dumont", + "CONFIGURE_REQUIRES" => { + "ExtUtils::MakeMaker" => 0 + }, + "DISTNAME" => "Array-IntSpan", + "LICENSE" => "artistic_2", + "MIN_PERL_VERSION" => "5.008", + "NAME" => "Array::IntSpan", + "PREREQ_PM" => { + "Carp" => 0 + }, + "TEST_REQUIRES" => { + "Data::Dumper" => 0, + "Test::More" => 0 + }, + "VERSION" => "2.004", + "test" => { + "TESTS" => "t/*.t" + } +); + + +my %FallbackPrereqs = ( + "Carp" => 0, + "Data::Dumper" => 0, + "Test::More" => 0 +); + + +unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { + delete $WriteMakefileArgs{TEST_REQUIRES}; + delete $WriteMakefileArgs{BUILD_REQUIRES}; + $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; +} + +delete $WriteMakefileArgs{CONFIGURE_REQUIRES} + unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; + +WriteMakefile(%WriteMakefileArgs); diff --git a/README b/README new file mode 100644 index 0000000..8d856c5 --- /dev/null +++ b/README @@ -0,0 +1,63 @@ + +This distribution provides a set of modules: + +Array::IntSpan - a Module for handling arrays using integer ranges +Array::IntSpan::Fields - IntSpan array using integer fields as indices +Array::IntSpan::IP - a Module for arrays using IP addresses as indices + + +Array::IntSpan brings the speed advantages of Set::IntSpan (written by +Steven McDougall) to arrays. Uses include manipulating grades, +routing tables, or any other situation where you have mutually +exclusive ranges of integers that map to given values (or objects) The +new version of Array::IntSpan is able to consolidate ranges by +comparing adjacent values. + +Array::IntSpan::Fields brings the advantages of Array::IntSpan to +indices made of integer fields like an IP address and an ANSI SS7 +point code. + +Array::IntSpan::IP brings the advantages of Array::IntSpan to IP +address indices. Anywhere you use an index in Array::IntSpan, you can +use an IP address in one of three forms in Array::IntSpan::IP. + +Version 2.001 was heavily modified from version 1.01. The module was +heavily tested but you should test your application with v2.001 before +any important use. + + +--------------------------------------------------------------------- +INSTALLATION from CPAN + + gunzip -c .tar.gz | tar xvf - + cd + perl Makefile.PL + make test + make install + +INSTALLATION from git requires Dist::Zilla + +You must make sure that the following modules are installed: +Dist::Zilla::Plugin::MetaResources +Dist::Zilla::Plugin::Prepender +Dist::Zilla::Plugin::Prereqs +Dist::Zilla::PluginBundle::Filter + +On debian or ubuntu, do: + +sudo aptitude install \ + libdist-zilla-plugin-prepender-perl \ + libdist-zilla-plugins-cjm-perl \ + libdist-zilla-perl + + +Then run: + +dzil build + +or + +dzil test +dzil build + + diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..3f03846 --- /dev/null +++ b/dist.ini @@ -0,0 +1,47 @@ +name = Array-IntSpan +author = Dominique Dumont +license = Artistic_2_0 +copyright_holder = Dominique Dumont +copyright_year = 2014 + +[MetaResources] +homepage = https://github.com/dod38fr/array-intspan-perl +bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?Dist=Array-IntSpan +bugtracker.mailto = bug-project@rt.cpan.org +repository.url = https://github.com/dod38fr/array-intspan-perl.git +repository.web = https://github.com/dod38fr/array-intspan-perl +repository.type = git + +[@Filter] +-bundle = @Basic +-remove = Readme + +[MetaProvides::Package] + +[AutoPrereqs] +skip = ^[a-z\d]+$ +skip = ExtUtils::testlib +skip = Exporter + +[Prepender] +copyright=1 + +[NextRelease] +format = %v%T %{yyyy-MM-dd}d + +[PkgVersion] + +; use 'V=2.234 dzil release' to override version number +[Git::NextVersion] + +[Git::Check] +allow_dirty = dist.ini +allow_dirty = Changes + +[Git::Commit] + +[Git::Tag] +[Git::Push] + +[MetaJSON] +[MinimumPerlFast] diff --git a/lib/Array/IntSpan.pm b/lib/Array/IntSpan.pm new file mode 100644 index 0000000..b3f2c5c --- /dev/null +++ b/lib/Array/IntSpan.pm @@ -0,0 +1,805 @@ +# +# This file is part of Array-IntSpan +# +# This software is Copyright (c) 2014 by Dominique Dumont. +# +# This is free software, licensed under: +# +# The Artistic License 2.0 (GPL Compatible) +# +########################################################################## +# +# Array::IntSpan - a Module for handling arrays using IntSpan techniques +# +# Author: Toby Everett, Dominique Dumont +# +########################################################################## +# Copyright 2003-2004,2010,2014 Dominique Dumont. All rights reserved. +# Copyright 2000 Toby Everett. All rights reserved. +# +# This file is distributed under the Artistic 2.0 License. See +# https://www.perlfoundation.org/artistic-license-20.html +# +# For comments, questions, bugs or general interest, feel free to +# contact Dominique Dumont at ddumont@cpan.org +########################################################################## + +use strict; +use warnings ; + +package Array::IntSpan; +$Array::IntSpan::VERSION = '2.004'; + +sub min { my @a = sort {$a <=> $b} @_ ; return $a[0] ; } +sub max { my @a = sort {$b <=> $a} @_ ; return $a[0] ; } + +sub new { + my $class = shift; + + my $self = [@_]; + bless $self, $class; + $self->_check_structure; + return $self; +} + +#internal function +sub search { + my ($self,$start,$end,$index) = @_ ; + + # Binary search for the first element that is *entirely* before the + # element to be inserted + while ($start < $end) { + my $mid = int(($start+$end)/2); + if ($self->[$mid][1] < $index) { + $start = $mid+1; + } else { + $end = $mid; + } + } + return $start ; +} + +# clear the range. Note the the $self ref is preserved +sub clear { + my $self = shift; + @$self = () ; +} + +sub set_range_as_string { + my $self = shift; + my $str = shift; + + $str =~ s/\s//g; + + foreach my $substr (split /,/, $str) { + my @range = $substr =~ /-/ ? split /-/,$substr : ($substr) x 2; + $self->set_range(@range, @_); + } +} + +sub set { + my $self = shift; + my $idx = shift; + + $self->set_range($idx, $idx, @_); +} + +sub set_range { + my $self = shift; + + #Test that we were passed appropriate values + @_ == 3 or @_ == 4 or + croak("Array::IntSpan::set_range should be called with 3 values and an ". + "optional code ref."); + $_[0] <= $_[1] or + croak("Array::IntSpan::set_range called with bad indices: ". + "$_[0] and $_[1]."); + + not defined $_[3] or ref($_[3]) eq 'CODE' or + croak("Array::IntSpan::set_range called without 4th parameter ". + "set as a sub ref"); + + my ($offset,$length,@list) = $self -> get_splice_parms(@_) ; + + #print "splice $offset,$length,@list\n"; + splice @$self, $offset,$length,@list ; + + return $length ? 1 : 0 ; +} + +# not well tested or documented. May be useless... +sub check_clobber { + my $self = shift; + + my @clobbered = $self->clobbered_items(@_) ; + + map {warn "will clobber @$_ with @_\n" ;} @clobbered ; + + return @clobbered ; +} + +sub get_element + { + my ($self,$idx) = @_; + my $ref = $self->[$idx] ; + return () unless defined $ref ; + return @$ref ; + } + +# call-back: +# filler (start, end) +# copy (start, end, payload ) +# set (start, end, payload) + +sub get_range { + my $self = shift; + #my($new_elem) = [@_]; + my ($start_elem,$end_elem, $filler, $copy, $set) = @_ ; + + $copy = sub{$_[2];} unless defined $copy ; + + my $end_range = $#{$self}; + my $range_size = @$self ; # nb of elements + + # Before we binary search, first check if we fall before the range + if ($end_range < 0 or $self->[$end_range][1] < $start_elem) + { + my @arg = ref($filler) ? + ([$start_elem,$end_elem,&$filler($start_elem,$end_elem)]) : + defined $filler ? ([@_]) : () ; + push @$self, @arg if @arg; + return ref($self)->new(@arg) ; + } + + # Before we binary search, first check if we fall after the range + if ($end_elem < $self->[0][0]) + { + my @arg = ref($filler) ? + ([$start_elem,$end_elem,&$filler($start_elem,$end_elem)]) : + defined $filler ? ([@_]) : () ; + unshift @$self, @arg if @arg; + return ref($self)->new(@arg) ; + } + + my $start = $self->search(0, $range_size, $start_elem) ; + my $end = $self->search($start,$range_size, $end_elem) ; + + my $start_offset = $start_elem - $self->[$start][0] ; + my $end_offset = defined $self->[$end] ? + $end_elem - $self->[$end][0] : undef ; + + #print "get_range: start $start, end $end, start_offset $start_offset"; + #print ", end_offset $end_offset" if defined $end_offset ; + #print "\n"; + + my @extracted ; + my @replaced ; + my $length = 0; + + # handle the start + if (defined $filler and $start_offset < 0) + { + my $e = min ($end_elem, $self->[$start][0]-1) ; + my $new = ref($filler) ? &$filler($start_elem, $e) : $filler ; + my @a = ($start_elem, $e, $new) ; + # don't use \@a, as we don't want @extracted and @replaced to + # point to the same memory area. But $new must point to the same + # object + push @extracted, [ @a ] ; + push @replaced, [ @a ] ; + } + + if ($self->[$start][0] <= $end_elem) + { + my $s = max ($start_elem,$self->[$start][0]) ; + my $e = min ($end_elem, $self->[$start][1]) ; + my $payload = $self->[$start][2] ; + if ($self->[$start][0] < $s) + { + my $s1 = $self->[$start][0]; + my $e1 = $s - 1 ; + push @replaced, [$s1, $e1 , &$copy($s1,$e1,$payload) ]; + } + # must duplicate the start, end variable + push @extracted, [$s, $e, $payload]; + push @replaced, [$s, $e, $payload]; + if ($e < $self->[$start][1]) + { + my $s3 = $e+1 ; + my $e3 = $self->[$start][1] ; + push @replaced, [$s3, $e3, &$copy($s3, $e3,$payload) ] ; + } + &$set($s,$e, $payload) if defined $set ; + $length ++ ; + } + + # handle the middle if any + if ($start + 1 <= $end -1 ) + { + #print "adding " ; + foreach my $idx ( $start+1 .. $end - 1) + { + #print "idx $idx," ; + if (defined $filler) + { + my $start_fill = $self->[$idx-1][1]+1 ; + my $end_fill = $self->[$idx][0]-1 ; + if ($start_fill <= $end_fill) + { + my $new = ref($filler) ? &$filler($start_fill, $end_fill) + : $filler ; + push @extracted, [$start_fill, $end_fill, $new] ; + push @replaced, [$start_fill, $end_fill, $new]; + } + } + push @extracted, [@{$self->[$idx]}]; + push @replaced , [@{$self->[$idx]}]; + $length++ ; + } + #print "\n"; + } + + # handle the end + if ($end > $start) + { + if (defined $filler) + { + # must add end element filler + my $start_fill = $self->[$end-1][1]+1 ; + my $end_fill = (not defined $end_offset or $end_offset < 0) ? + $end_elem : $self->[$end][0]-1 ; + if ($start_fill <= $end_fill) + { + my $new = ref($filler) ? &$filler($start_fill, $end_fill) : + $filler ; + push @extracted, [$start_fill, $end_fill, $new] ; + push @replaced, [$start_fill, $end_fill, $new]; + } + } + + if (defined $end_offset and $end_offset >= 0) + { + my $payload = $self->[$end][2] ; + my $s = $self->[$end][0] ; + my @a = ($s,$end_elem, $payload) ; + push @extracted, [@a]; + push @replaced , [@a]; + if ($end_elem < $self->[$end][1]) + { + my $s2 = $end_elem + 1 ; + my $e2 = $self->[$end][1] ; + push @replaced , [$s2, $e2, &$copy($s2,$e2,$payload)]; + } + &$set($s,$end_elem, $payload) if defined $set ; + $length++ ; + } + } + + if (defined $filler) + { + splice (@$self, $start,$length , @replaced) ; + } + + my $ret = ref($self)->new(@extracted) ; + return $ret ; +} + +sub clobbered_items { + my $self = shift; + my($range_start,$range_stop,$range_value) = @_; + + my $item = $self->get_range($range_start,$range_stop) ; + + return grep {$_->[2] ne $range_value} @$item ; +} + + +# call-back: +# set (start, end, payload) +sub consolidate { + my ($self,$bottom,$top,$set) = @_; + + $bottom = 0 if (not defined $bottom or $bottom < 0 ); + $top = $#$self if (not defined $top or $top > $#$self) ; + + #print "consolidate from $top to $bottom\n"; + + for (my $i= $top; $i>0; $i--) + { + if ($self->[$i][2] eq $self->[$i-1][2] and + $self->[$i][0] == $self->[$i-1][1]+1 ) + { + #print "consolidate splice ",$i-1,",2\n"; + my ($s,$e,$p) = ($self->[$i-1][0], $self->[$i][1], $self->[$i][2]); + splice @$self, $i-1, 2, [$s, $e, $p] ; + $set->($s,$e,$p) if defined $set ; + } + } + +} + +sub set_consolidate_range { + my $self = shift; + + #Test that we were passed appropriate values + @_ == 3 or @_ == 5 or + croak("Array::IntSpan::set_range should be called with 3 values ". + "and 2 optional code ref."); + $_[0] <= $_[1] or + croak("Array::IntSpan::set_range called with bad indices: $_[0] and $_[1]."); + + not defined $_[3] or ref($_[3]) eq 'CODE' or + croak("Array::IntSpan::set_range called without 4th parameter set as a sub ref"); + + my ($offset,$length,@list) = $self -> get_splice_parms(@_[0,1,2,3]) ; + + #print "splice $offset,$length\n"; + splice @$self, $offset,$length,@list ; + my $nb = @list ; + + $self->consolidate($offset - 1 , $offset+ $nb , $_[4]) ; + + return $length ? 1 : 0 ;#($b , $t ) ; + +} + +# get_range_list +# scalar context -> return a string +# list context => returns list of list + +sub get_range_list { + my ($self, %options) = @_; + if (wantarray) { + return map { [ @$_[0,1] ] } @$self; + } + else { + return join ', ' , map { + my ($a,$b) = @$_; + $a == $b ? $a + : $a+1==$b ? join(', ',$a,$b) + : join('-',$a,$b); + } @$self; + } +} + +# internal function +# call-back: +# copy (start, end, payload ) +sub get_splice_parms { + my $self = shift; + my ($start_elem,$end_elem,$value,$copy) = @_ ; + + my $end_range = $#{$self}; + my $range_size = @$self ; # nb of elements + + #Before we binary search, we'll first check to see if this is an append operation + if ( $end_range < 0 or + $self->[$end_range][1] < $start_elem + ) + { + return defined $value ? ( $range_size, 0, [$start_elem,$end_elem,$value]) : + ($range_size, 0) ; + } + + # Check for prepend operation + if ($end_elem < $self->[0][0] ) { + return defined $value ? ( 0 , 0, [$start_elem,$end_elem,$value]) : (0,0); + } + + #Binary search for the first element after the last element that is entirely + #before the element to be inserted (say that ten times fast) + my $start = $self->search(0, $range_size, $start_elem) ; + my $end = $self->search($start,$range_size, $end_elem) ; + + my $start_offset = $start_elem - $self->[$start][0] ; + my $end_offset = defined $self->[$end] ? + $end_elem - $self->[$end][0] : undef ; + + #print "get_splice_parms: start $start, end $end, start_offset $start_offset"; + #print ", end_offset $end_offset" if defined $end_offset ; + #print "\n"; + + my @modified = () ; + + #If we are here, we need to test for whether we need to frag the + #conflicting element + if ($start_offset > 0) { + my $item = $self->[$start][2] ; + my $s = $self->[$start][0] ; + my $e = $start_elem-1 ; + my $new = defined($copy) ? $copy->($s,$e,$item) : $item ; + push @modified ,[$s, $e, $new ]; + } + + push @modified, [$start_elem,$end_elem,$value] if defined $value ; + + #Do a fragmentation check + if (defined $end_offset + and $end_offset >= 0 + and $end_elem < $self->[$end][1] + ) { + my $item = $self->[$end][2] ; + my $s = $end_elem+1 ; + my $e = $self->[$end][1] ; + my $new = defined($copy) ? $copy->($s,$e,$item) : $item ; + push @modified , [$s, $e, $new] ; + } + + my $extra = (defined $end_offset and $end_offset >= 0) ? 1 : 0 ; + + return ($start, $end - $start + $extra , @modified); +} + +sub lookup { + my $self = shift; + my($key) = @_; + + my($start, $end) = (0, $#{$self}); + return undef unless $end >= 0 ; # completely empty span + + while ($start < $end) { + my $mid = int(($start+$end)/2); + if ($self->[$mid][1] < $key) { + $start = $mid+1; + } else { + $end = $mid; + } + } + if ($self->[$start]->[0] <= $key && $self->[$start]->[1] >= $key) { + return $self->[$start]->[2]; + } + return undef; +} + +sub _check_structure { + my $self = shift; + + return unless $#$self >= 0; + + foreach my $i (0..$#$self) { + @{$self->[$i]} == 3 or + croak("Array::IntSpan::_check_structure failed - element $i lacks 3 entries."); + $self->[$i][0] <= $self->[$i][1] or + croak("Array::IntSpan::_check_structure failed - element $i has bad indices."); + if ($i > 0) { + $self->[$i-1][1] < $self->[$i][0] or + croak("Array::IntSpan::_check_structure failed - element $i (", + ,$self->[$i][0],",",$self->[$i][1], + ") doesn't come after previous element (", + $self->[$i-1][0],",",$self->[$i-1][1],")"); + } + } +} + +#The following code is courtesy of Mark Jacob-Dominus, +sub croak { + require Carp; + no warnings 'redefine' ; + *croak = \&Carp::croak; + goto &croak; +} + +1; + +__END__ + +=head1 NAME + +Array::IntSpan - Handles arrays of scalars or objects using integer ranges + +=head1 SYNOPSIS + + use Array::IntSpan; + + my $foo = Array::IntSpan->new([0, 59, 'F'], [60, 69, 'D'], [80, 89, 'B']); + + print "A score of 84% results in a ".$foo->lookup(84).".\n"; + unless (defined($foo->lookup(70))) { + print "The grade for the score 70% is currently undefined.\n"; + } + + $foo->set_range(70, 79, 'C'); + print "A score of 75% now results in a ".$foo->lookup(75).".\n"; + + $foo->set_range(0, 59, undef); + unless (defined($foo->lookup(40))) { + print "The grade for the score 40% is now undefined.\n"; + } + + $foo->set_range(87, 89, 'B+'); + $foo->set_range(85, 100, 'A'); + $foo->set_range(100, 1_000_000, 'A+'); + +=head1 DESCRIPTION + +C brings the speed advantages of C +(written by Steven McDougall) to arrays. Uses include manipulating +grades, routing tables, or any other situation where you have mutually +exclusive ranges of integers that map to given values. + +The new version of C is also able to consolidate the +ranges by comparing the adjacent values of the range. If 2 adjacent +values are identical, the 2 adjacent ranges are merged. + +=head1 Ranges of objects + +C can also handle objects instead of scalar values. + +But for the consolidation to work, the payload class must overload the +C<"">, C and C<==> operators to perform the consolidation +comparisons. + +When a get_range method is called to a range of objects, it will +return a new range of object referencess. These object references +points to the objects stored in the original range. In other words the +objects contained in the returned range are B copied. + +Thus if the user calls a methods on the objects contained in the +returned range, the method is actually invoked on the objects stored +in the original range. + +When a get_range method is called on a range of objects, several +things may happen: + +=over + +=item * + +The get_range spans empty slots. By default the returned range will +skip the empty slots. But the user may provide a callback to create +new objects (for instance). See details below. + +=item * + +The get_range splits existing ranges. By default, the split range will +contains the same object reference. The user may provide callback to +perform the object copy so that the split range will contains +different objects. See details below. + +=back + +=head1 Ranges specified with integer fields + +=over + +=item * + +C is also provided with the distribution. It lets +you use IP addresses in any of three forms (dotted decimal, network +string, and integer) for the indices into the array. See the POD for +that module for more information. See L for +details. + +=item * + +C is also provided with the distribution. It +let you specify an arbitrary specification to handle ranges with +strings made of several integer separared by dots (like IP addresses +of ANSI SS7 point codes). See L for details. + +=back + + +=head1 METHODS + +=head2 new (...) + +The C method takes an optional list of array elements. The +elements should be in the form C<[start_index, end_index, value]>. +They should be in sorted order and there should be no overlaps. The +internal method C<_check_structure> will be called to verify the data +is correct. If you wish to avoid the performance penalties of +checking the structure, you can use C to dump an object +and use that code to reconstitute it. + +=head2 clear + +Clear the range. + +=head2 set_range (start, end, value [, code ref] ) + +This method takes three parameters - the C, the +C, and the C. If you wish to erase a range, specify +C for the C. It properly deals with overlapping ranges +and will replace existing data as appropriate. If the new range lies +after the last existing range, the method will execute in O(1) time. +If the new range lies within the existing ranges, the method executes +in O(n) time, where n is the number of ranges. It does not consolidate +contiguous ranges that have the same C. + +If you have a large number of inserts to do, it would be beneficial to +sort them first. Sorting is O(n lg(n)), and since appending is O(1), +that will be considerably faster than the O(n^2) time for inserting n +unsorted elements. + +The method returns C<0> if there were no overlapping ranges and C<1> +if there were. + +The optional code ref is called back when an existing range is +split. For instance if the original range is C<[0,10,$foo_obj]> and +set_range is called with C<[5,7,$bar_obj']>, the callback will be called +twice: + + $callback->(0, 4,$foo_obj) + $callback->(8,10,$foo_obj) + +It will be the callback responsability to make sure that the range +C<0-4> and C<7-10> holds 2 I objects. + +=head2 set( index, value [, code ref] ) + +Set a single value. This may split an existing range. Actually calls: + + set_range( index, index, value [, code ref] ) + +=head2 set_range_as_string ( index, string [, code ref] ) + +Set one one several ranges specified with a string. Ranges are separated by "-". +Several ranges can be specified with commas. + +Example: + + set_range_as_string( '1-10,13, 14-20', 'foo') + +White space are ignored. + +=head2 get_range (start, end [, filler | undef , copy_cb [, set_cb]]) + +This method returns a range (actually an Array::IntSpan object) from +C to C. + +If C and C span empty slot in the original range, +get_range will skip the empty slots. If a C value is provided, +get_range will fill the slots with it. + + original range : [2-4,X],[7-9,Y],[12-14,Z] + get_range(3,8) : [3-4,X],[7-8,Y] + get_range(2,10,f) : [3-4,X],[5-6,f],[7-8,Y] + +If the C parameter is a CODE reference, the filler value will +be the one returned by the sub ref. The sub ref is invoked with +C<(start,end)>, i.e. the range of the empty span to fill +(C in the example above). When handling object, the +sub ref can invoke an object constructor. + +If C or C split an original range in 2, the default +behavior is to copy the value or object ref contained in the original +range: + + original range : [1-4,X] + split range : [1-1,X],[2-2,X],[3-4,X] + get_range(2) : [2-2,X] + +If the original range contains object, this may lead to +disapointing results. In the example below the 2 ranges contains +references (C) that points to the same object: + + original range : [1-4,obj_a] + split range : [1-1,obj_a],[2-2,obj_a],[3-4,obj_a] + get_range(2) : [2-2,obj_a] + +Which means that invoking a method on the object returned by +C will also be invoked on the range 1-4 of the original +range which may not be what you want. + +If C is invoked with a copy parameter (actually a code +reference), the result of this routine will be stored in the split +range I of the get_range: + + original range : [1-4,X] + get_range(2) : [2-2,X] + split range : [1-1,copy_of_X],[2-2,X],[3-4,copy_of_X] + +When dealing with object, the sub ref should provide a copy of the object: + + original range : [1-4,obj_a] + get_range(2) : [2-2,obj_a] + split range : [1-1,obj_a1],[2-2,obj_a],[3-4,obj_a2] + +Note that the C contained in the C and the +C contained in the returned range point to the I. + +The sub ref is invoked with C<(start,end,obj_a)> and is expected to +return a copy of C that will be stored in the split ranges. In +the example above, 2 different copies are made: C and +C. + +Last, a 3rd callback may be defined by the user: the C. This +callback will be used when the range start or end that holds an object +changes. In the example above, the C will be called this way: + + $obj_a->&$set_cb(2,2) ; + +As a matter of fact, the 3 callback can be used in the same call. In +the example below, C is invoked with 3 subs refs: +C<\&f,\&cp,\&set>: + + original range : [1-4,obj_a],[7-9,obj_b] + get_range(3-8,...) : [3-4,obj_a],[5-6,obj_fill],[7-8,obj_b] + split range : [1-2,obj_a1], [3-4,obj_a],[5-6,obj_fill], + [7-8,obj_b],[9-9,obj_b1] + +To obtain this, get_range will perform the following calls: + + $obj_fill = &f ; + $obj_a1 = &cp(5,6,obj_a); + &set(3,4,$obj_a) ; + $obj_b = &cp(9,9,obj_b) ; + &set(7-8,obj_b) ; + +=head2 get_range_list + +In scalar context, returns a list of range in a string like: "C<1-5,7,9-11>". + +In list context retunrs a list of list, E.g. C< ( [1,5], [7,7], 9,11])>. + +=head2 lookup( index ) + +This method takes as a single parameter the C to look up. If +there is an appropriate range, the method will return the associated +value. Otherwise, it returns C. + +=head2 get_element( element_number ) + +Returns an array containing the Nth range element: + + ( start, end, value ) + +=head2 consolidate( [ bottom, top , [ set_cb ]] ) + +This function scans the range from the range index C to C +and compare the values held by the adjacent ranges. If the values are +identical, the adjacent ranges are merged. + +The comparison is made with the C<==> operator. Objects stored in the +range B overload the C<==> operator. If not, the comparison is +made with the standard stringification of an object and the merge +never happens. + +If provided, the C is invoked on the contained object +after 2 ranges are merged. + +For instance, if C<"$obj_a" eq "$obj_b">: + + original range is : [1-4,obj_a],[5-9,obj_b] + consolidate(0,1,\&set) yields: [1-9,obj_a] + +And C performs this call: + + $set->(1,9,obj_a) ; + +Consolidate the whole range when called without parameters. + +=head1 CONTRIBUTORS + +=over + +=item * + +Mohammad S Anwar + +=back + +=head1 AUTHORS + +=over + +=item * + +Toby Everett, teverett@alascom.att.com + +=item * + +Dominique Dumont, ddumont@cpan.org + +=back + +Copyright (c) 2000 Toby Everett. +Copyright (c) 2003-2004,2014,2020 Dominique Dumont. +All rights reserved. This program is free software. + +This module is distributed under the Artistic 2.0 License. See +https://www.perlfoundation.org/artistic-license-20.html + +=cut + diff --git a/lib/Array/IntSpan/Fields.pm b/lib/Array/IntSpan/Fields.pm new file mode 100644 index 0000000..79524be --- /dev/null +++ b/lib/Array/IntSpan/Fields.pm @@ -0,0 +1,288 @@ +# +# This file is part of Array-IntSpan +# +# This software is Copyright (c) 2014 by Dominique Dumont. +# +# This is free software, licensed under: +# +# The Artistic License 2.0 (GPL Compatible) +# +########################################################################## +# +# Array::IntSpan::Fields - IntSpan array using integer fields as indices +# +# Author: Dominique Dumont +########################################################################## +# Copyright 2003 Dominique Dumont. All rights reserved. +# +# This module is distributed under the Artistic 2.0 License. See +# https://www.perlfoundation.org/artistic-license-20.html +# +# For comments, questions, bugs or general interest, feel free to +# contact Dominique Dumont ddumont@cpan.org +########################################################################## + +use strict; +use warnings; + +package Array::IntSpan::Fields; +$Array::IntSpan::Fields::VERSION = '2.004'; +use Array::IntSpan; +use Carp ; + +use overload + # this emulate the usage of Intspan + '@{}' => sub { return shift->{range} ;} , + # fallback on default behavior for all other operators + fallback => 1 ; + +sub new + { + my $proto = shift ; + my $class = ref($proto) || $proto; + my $format = shift ; + + if (ref $format) + { + # in fact the user want a regular IntSpan + return Array::IntSpan->new($format,@_); + } + + my @temp = @_ ; + my $self = {}; + bless $self, $class; + $self->set_format($format) ; + + foreach my $i (@temp) + { + $i->[0] = $self->field_to_int($i->[0]); + $i->[1] = $self->field_to_int($i->[1]); + } + + $self->{range}= Array::IntSpan->new(@temp) ; + + return $self; + } + +sub set_format + { + my ($self,$format) = @_ ; + croak "Unexpected format : $format" unless + $format =~ /^[\d\.]+$/ ; + + $self->{format} = $format ; + + my @array = split /\./, $self->{format} ; + # store nb of bit and corresponding bit mask + $self->{fields} = [map { [$_, (1<<$_) -1 ]} @array ] ; + } + +sub int_to_field + { + my $self = shift ; + my @all_int = @_ ; + my @result ; + + foreach my $int (@all_int) + { + my @res ; + foreach my $f (reverse @{$self->{fields}}) + { + unshift @res, ($f->[0] < 32 ? ($int & $f->[1]) : $int ) ; + $int >>= $f->[0] ; + } + push @result, join('.',@res) ; + } + + return wantarray ? @result : $result[0]; + } + +sub field_to_int + { + my $self = shift ; + + my @all_field = @_; + my @result ; + + foreach my $field (@all_field) + { + my $f = $self->{fields}; + my @array = split /\./,$field ; + + croak "Expected ",scalar @$f, + " fields for format $self->{format}, got ", + scalar @array," in '$field'\n" unless @array == @$f ; + + my $res = 0 ; + + my $i =0 ; + + while ($i <= $#array) + { + my $shift = $f->[$i][0] ; + croak "Field value $array[$i] too great. ", + "Max is $f->[$i][1] (bit width is $shift)" + if $shift<32 and $array[$i] >> $shift ; + + $res = ($res << $shift) + $array[$i++] ; + } + #print "field_to_int: changed $field to $res for format $self->{format}\n"; + push @result, $res ; + } + + return wantarray ? @result : $result[0]; + } + +sub get_range + { + my ($self,$s_field,$e_field) = splice @_,0,3 ; + my ($s, $e) = $self->field_to_int($s_field,$e_field) ; + my @newcb = $self->adapt_range_in_cb(@_) ; + + my $got = $self->{range}->get_range($s,$e,@newcb) ; + + my $ret = bless {range => $got }, ref($self) ; + $ret->set_format($self->{format}) ; + return $ret ; + } + +sub lookup + { + my $self = shift; + my @keys = $self->field_to_int(@_); + $self->{range}->lookup(@keys) ; + } + +sub clear + { + my $self = shift; + @{$self->{range}} = () ; + } + +sub consolidate + { + my ($self,$s_field,$e_field) = splice @_,0,3 ; + my ($s, $e) = $self->field_to_int($s_field,$e_field) + if defined $s_field and defined $e_field; + my @newcb = $self->adapt_range_in_cb(@_) if @_; + + return $self->{range}->consolidate($s,$e,@newcb) ; + } + + +foreach my $method (qw/set_range set_consolidate_range/) + { + no strict 'refs' ; + *$method = sub + { + my ($self,$s_field,$e_field,$value) = splice @_,0,4 ; + my ($s, $e) = $self->field_to_int($s_field,$e_field) ; + my @newcb = $self->adapt_range_in_cb(@_) ; + + return $self->{range}->$method ($s, $e, $value, @newcb); + }; + } + +sub adapt_range_in_cb + { + my $self = shift; + + # the callbacks will be called with ($start, $end,$payload) or + # ($start,$end) + my @callbacks = @_ ; + + return map + { + my $old_cb = $_; # required for closure to work + defined $old_cb ? + sub + { + my ($s_int,$e_int,$value) = @_ ; + my ($s,$e) = $self->int_to_field($s_int,$e_int) ; + $old_cb->($s,$e,$value); + } + : undef ; + } @callbacks ; + } + +sub get_element + { + my ($self,$idx) = @_; + my $elt = $self->{range}[$idx] || return () ; + my ($s_int,$e_int,$value) = @$elt ; + my ($s,$e) = $self->int_to_field($s_int,$e_int) ; + + return ($s,$e, $value) ; + } + +1; + +__END__ + +=head1 NAME + +Array::IntSpan::Fields - IntSpan array using integer fields as indices + +=head1 SYNOPSIS + + use Array::IntSpan::Fields; + + my $foo = Array::IntSpan::Fields + ->new( '1.2.4', + ['0.0.1','0.1.0','ab'], + ['1.0.0','1.0.3','cd']); + + print "Address 0.0.15 has ".$foo->lookup("0.0.15").".\n"; + + $foo->set_range('1.0.4','1.1.0','ef') ; + +=head1 DESCRIPTION + +C brings the advantages of C +to indices made of integer fields like an IP address and an ANSI SS7 point code. + +The number of integer and their maximum value is defined when calling +the constructor (or the C method). The example in the +synopsis defines an indice with 3 fields where their maximum values +are 1,3,15 (or 0x1,0x3,0xf). + +This module converts the fields into integer before storing them into +the L module. + +=head1 CONSTRUCTOR + +=head2 new (...) + +The first parameter defines the size of the integer of the fields, in +number of bits. For an IP address, the field definition would be +C<8,8,8,8>. + +=head1 METHODS + +All methods of L are available. + +=head2 set_format( field_description ) + +Set another field description. Beware: no conversion or checking is +done. When changing the format, old indices may become illegal. + +=head2 int_to_field ( integer ) + +Returns the field representation of the integer. + +=head2 field_to_int ( field ) + +Returns the integer value of the field. May craok if the fields values +are too great with respect to the filed description. + +=head1 AUTHOR + +Dominique Dumont, ddumont@cpan.org + +Copyright (c) 2003 Dominique Dumont. All rights reserved. + +This module is distributed under the Artistic 2.0 License. See +https://www.perlfoundation.org/artistic-license-20.html + +=cut + diff --git a/lib/Array/IntSpan/IP.pm b/lib/Array/IntSpan/IP.pm new file mode 100644 index 0000000..9e81295 --- /dev/null +++ b/lib/Array/IntSpan/IP.pm @@ -0,0 +1,172 @@ +# +# This file is part of Array-IntSpan +# +# This software is Copyright (c) 2014 by Dominique Dumont. +# +# This is free software, licensed under: +# +# The Artistic License 2.0 (GPL Compatible) +# +########################################################################## +# +# Array::IntSpan::IP - a Module for arrays using IP addresses as indices +# +# Author: Toby Everett +# Revision: 1.01 +# Last Change: Makefile.PL +########################################################################## +# Copyright 2000 Toby Everett. All rights reserved. +# +# This module is distributed under the Artistic 2.0 License. See +# https://www.perlfoundation.org/artistic-license-20.html +# +# For comments, questions, bugs or general interest, feel free to +# contact Toby Everett at teverett@alascom.att.com +########################################################################## + +use strict; + +use Array::IntSpan; + +package Array::IntSpan::IP; +$Array::IntSpan::IP::VERSION = '2.004'; +use vars qw($VERSION @ISA); + +$VERSION = '1.01'; + +@ISA = ('Array::IntSpan'); + +sub new { + my $class = shift; + my(@temp) = @_; + + foreach my $i (@temp) { + $i->[0] = &ip_as_int($i->[0]); + $i->[1] = &ip_as_int($i->[1]); + } + + return $class->SUPER::new(@temp); +} + +sub set_range { + my $self = shift; + my(@temp) = @_; + + $temp[0] = &ip_as_int($temp[0]); + $temp[1] = &ip_as_int($temp[1]); + + return $self->SUPER::set_range(@temp); +} + +sub lookup { + my $self = shift; + my($key) = @_; + + return $self->SUPER::lookup(&ip_as_int($key)); +} + +sub ip_as_int { + my($value) = @_; + + if ($value =~ /^(\d{1,3}\.){3}(\d{1,3})$/) { + my(@values) = split(/\./, $value); + scalar(grep {$_ > 255} @values) and croak("Unable to parse '$value' as an IP address."); + return 16777216*$values[0]+65536*$values[1]+256*$values[2]+$values[3]; + } elsif (length($value) == 4) { + return unpack('N', $value) + } elsif ($value =~ /^\d+$/) { + return int($value); + } else { + croak("Unable to parse '$value' as an IP address."); + } +} + +#The following code is courtesy of Mark Jacob-Dominus, + +sub croak { + require Carp; + *croak = \&Carp::croak; + goto &croak; +} + +1; + +__END__ + +=head1 NAME + +Array::IntSpan::IP - a Module for arrays using IP addresses as indices + +=head1 SYNOPSIS + + use Array::IntSpan::IP; + + my $foo = Array::IntSpan::IP->new(['123.45.67.0', '123.45.67.255', 'Network 1'], + ['123.45.68.0', '123.45.68.127', 'Network 2'], + ['123.45.68.128', '123.45.68.255', 'Network 3']); + + print "The address 123.45.68.37 is on network ".$foo->lookup("\173\105\150\45").".\n"; + unless (defined($foo->lookup(((123*256+45)*256+65)*256+67))) { + print "The address 123.45.65.67 is not on a known network.\n"; + } + + print "The address 123.45.68.177 is on network ".$foo->lookup("123.45.68.177").".\n"; + + $foo->set_range('123.45.68.128', '123.45.68.255', 'Network 4'); + print "The address 123.45.68.177 is now on network ".$foo->lookup("123.45.68.177").".\n"; + +=head1 DESCRIPTION + +C brings the advantages of C to IP +address indices. Anywhere you use an index in C, you +can use an IP address in one of three forms in C. +The three accepted forms are: + +=over 4 + +=item Dotted decimal + +This is the standard human-readable format for IP addresses. The +conversion checks that the octets are in the range 0-255. Example: +C<'123.45.67.89'>. + +=item Network string + +A four character string representing the octets in network +order. Example: C<"\173\105\150\131">. + +=item Integer + +A integer value representing the IP address. Example: +C<((123*256+45)*256+67)*256+89> or C<2066563929>. + +=back + +Note that the algorithm has no way of distinguishing between the +integer values 1000 through 9999 and the network string format. It +will presume network string format in these instances. For instance, +the integer C<1234> (representing the address C<'0.0.4.210'>) will be +interpreted as C<"\61\62\63\64">, or the IP address C<'49.50.51.52'>. +This is unavoidable since Perl does not strongly type integers and +strings separately and there is no other information available to +distinguish between the two in this situation. I do not expect that +this will be a problem in most situations. Most users will probably +use dotted decimal or network string notations, and even if they do +use the integer notation the likelyhood that they will be using the +addresses C<'0.0.3.232'> through C<'0.0.39.15'> as indices is +relatively low. + +=head1 METHODS + +=head2 ip_as_int + +The class method C takes as its one +parameter the IP address in one of the three formats mentioned above +and returns the integer notation. + +=head1 AUTHOR + +Toby Everett, teverett@alascom.att.com + +=cut + diff --git a/t/clobbered_items.t b/t/clobbered_items.t new file mode 100644 index 0000000..25702ef --- /dev/null +++ b/t/clobbered_items.t @@ -0,0 +1,35 @@ + +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 18 ; +use Data::Dumper ; + +use Array::IntSpan; + +my $trace = shift || 0 ; + +my @expect= ([1,3,'ab'],[5, 7, 'cd'], [13, 26, 'ef']) ; +my $r = Array::IntSpan->new(@expect) ; + +diag(Dumper $r) if $trace ; + +ok ( defined($r) , 'Array::IntSpan new() works') ; +is_deeply( $r , \@expect, 'new content ok') ; + +foreach my $t ( + [[32,34,'oops'],[]], + [[4,4,'oops'],[]], + [[24,26,'oops'],[[24,26,'ef']]], + [[24,29,'oops'],[[24,26,'ef']]], + [[10,16,'oops'],[[13,16,'ef']]], + [[20,24,'oops'],[[20,24,'ef']]], + [[0,9,'oops'],[[1,3,'ab'],[5,7,'cd']]], + [[0,6,'oops'],[[1,3,'ab'],[5,6,'cd']]], + ) + { + my @clobbered = $r->clobbered_items(@{$t->[0]}) ; + is(@$r, 3, 'check nb of items in range') || diag(Dumper $r); + is_deeply(\@clobbered, $t->[1], "clobbered_items @{$t->[0]}") || + diag(Dumper \@clobbered) ; + } + diff --git a/t/consolidate.t b/t/consolidate.t new file mode 100644 index 0000000..d55c627 --- /dev/null +++ b/t/consolidate.t @@ -0,0 +1,49 @@ + +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 27 ; +use Data::Dumper ; + +use Array::IntSpan; + +my $trace = shift || 0 ; + +my @expect= ([1,3,'ab'], [6, 7, 'cd'], [8, 13, 'ef'], [14, 14, 'ef']) ; +my $r = Array::IntSpan->new(@expect) ; + +diag(Dumper $r) if $trace ; + +ok ( defined($r) , 'Array::IntSpan new() works') ; +is_deeply( $r , \@expect, 'new content ok') ; + +$r->consolidate ; + +@expect= ([1,3,'ab'], [6, 7, 'cd'], [8, 14, 'ef']) ; +is_deeply( $r , \@expect, 'consolidate ok') || diag(Dumper $r); +diag(Dumper $r) if $trace ; + +my @sub = ( sub {"c:".$_[2];}, + sub {print "set called with @_\n";} ); + +foreach my $t ( + [[5,5,'cd'],0,[[1,3,'ab'], [5, 7, 'cd'], [8, 14, 'ef']]], + [[13,16,'ef'],1,[[1,3,'ab'], [5, 7, 'cd'], [8, 16, 'ef']]], + [[24,26,'ef'],0,[[1,3,'ab'], [5, 7, 'cd'], [8, 16, 'ef'],[24,26,'ef']]] , + [[19,22,'ef'],0,[[1,3,'ab'], [5, 7, 'cd'], [8, 16, 'ef'],[19,22,'ef'],[24,26,'ef']]], + [[23,23,'efa'],0,[[1,3,'ab'], [5, 7, 'cd'], [8, 16, 'ef'],[19,22,'ef'],[23,23,'efa'],[24,26,'ef']]], + [[23,23,'ef'],1,[[1,3,'ab'], [5, 7, 'cd'], [8, 16, 'ef'],[19,26,'ef']]], + [[17,18,'efb'],0,[[1,3,'ab'], [5, 7, 'cd'], [8, 16, 'ef'],[17,18,'efb'],[19,26,'ef']]], + [[17,18,'ef'],1,[[1,3,'ab'], [5, 7, 'cd'], [8 ,26,'ef']]], + [[8,12,undef],1,[[1,3,'ab'], [5, 7, 'cd'], [13 ,26,'ef']]], + [[8,12,'gh',@sub],0,[[1,3,'ab'], [5, 7, 'cd'],[8,12,'gh'], [13 ,26,'ef']]], + [[13,20,'gh',@sub],1,[[1,3,'ab'], [5, 7, 'cd'],[8,20,'gh'], [21 ,26,'c:ef']]], + [[6,7,'gh',@sub],1,[[1,3,'ab'], [5, 5, 'c:cd'],[6,20,'gh'], [21 ,26,'c:ef']]], + ) + { + my @range = @{$t->[0]} ; + is ($r->set_consolidate_range(@range),$t->[1], + "set_consolidate_range @range[0,1]") ; + is_deeply($r, $t->[2], "result of @range[0,1]") || + diag("Got ".Dumper($r)) ; + } + diff --git a/t/empty_span.t b/t/empty_span.t new file mode 100644 index 0000000..a101ce7 --- /dev/null +++ b/t/empty_span.t @@ -0,0 +1,23 @@ +# -*- cperl -*- + +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 7 ; +use Data::Dumper ; + +use Array::IntSpan; + +my $trace = shift || 0 ; + +my $r2 = Array::IntSpan->new() ; + +ok($r2, 'empty span created') ; + +# test for RT 61700 +is($r2 -> lookup(1),undef,"test lookup on empty span (RT 61700)") ; + +is(@{$r2->get_range(1,10)}, 0 , 'get on empty set works'); +is(@{$r2->set_range(1,10,'ab')}, 0 , 'set on empty set works'); +is(@{$r2->set_range(1,10,undef)}, 0 , 'go back to empty set'); +is(@$r2, 0 , 'set is empty'); +is(@{$r2->set_consolidate_range(1,10,'ab')}, 0 , 'set_consolidate_range on empty set works'); diff --git a/t/fields.t b/t/fields.t new file mode 100644 index 0000000..3d2c739 --- /dev/null +++ b/t/fields.t @@ -0,0 +1,67 @@ +use strict ; +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 27 ; +use Data::Dumper ; + +use Array::IntSpan::Fields ; + +my $trace = shift || 0 ; + +my @expect= (['0.0.1','0.1.0','ab'], + ['1.0.0','1.0.3','cd'], + ['1.0.4','1.1.0','ef']) ; +my $r = Array::IntSpan::Fields->new('1.2.4',@expect) ; + +ok ( defined($r) , 'Array::IntSpan::Fields new() works') ; + +is_deeply([$r->get_element(1)], ['1.0.0','1.0.3','cd'], 'get_element' ); + +foreach my $t (qw/0.0.10 0.3.0 1.0.0 1.2.3 0.1.0/) + { + my $int = $r-> field_to_int($t); + ok ($int, "field_to_int test $t -> $int") ; + is($r-> int_to_field($int), $t, + "int_to_field test $int -> $t") ; + } + +eval{$r-> field_to_int('2.0.0')} ; +like($@, qr/Field value 2 too great/, 'test field check') ; + +eval{$r-> field_to_int('1.0.17')} ; +like($@, qr/Field value 17 too great/, 'test field check') ; + + +$r->set_range('1.1.1','1.2.1','gh') ; +is($r->lookup('1.2.0'),'gh',"lookup test") ; + +my $res = $r->get_range('1.0.0','1.3.15') ; + +isa_ok($res,'Array::IntSpan::Fields') ; +is($res->lookup('1.0.0'),'cd','get range test 1') ; +is($res->lookup('1.0.5'),'ef','get range test 2') ; + +$r->set_range('1.1.5','1.2.5','sub',sub{"@_"}); +is($r->lookup('1.2.4'),'sub','set_range with sub') ; +is($r->lookup('1.1.4'),'1.1.1 1.1.4 gh','set_range with sub') ; + + +my $regular = Array::IntSpan::Fields->new([1,3,'ab'],[5, 7, 'cd']); +isa_ok($regular,'Array::IntSpan') ; + +my $int32 = Array::IntSpan::Fields->new('32',[1,3,'ab'],[5, 7, 'cd']); +isa_ok($int32,'Array::IntSpan::Fields') ; + +foreach my $t (qw/1 100/) + { + my $int = $int32-> field_to_int($t); + ok ($int, "field_to_int int 32 test $t -> $int") ; + is($int32-> int_to_field($int), $t, + "int_to_field int 32 test $int -> $t") ; + } + +eval{my $int2 = Array::IntSpan::Fields->new('2',[1,3,'ab'],[5, 7, 'cd']);}; +like($@, qr/Field value 5 too great. Max is 3/, + 'test field check') ; + + diff --git a/t/get_range.t b/t/get_range.t new file mode 100644 index 0000000..2b78134 --- /dev/null +++ b/t/get_range.t @@ -0,0 +1,157 @@ +# -*- cperl-mode -*- + +use strict ; +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 50 ; +use Data::Dumper ; + +use Array::IntSpan; +my $trace = shift || 0 ; + +# test min max +is(Array::IntSpan::min(9,10), 9,'min test 9,10') ; +is(Array::IntSpan::max(9,10),10,'max test 9,10') ; + + +my @expect= ([1,3,'ab'],[5, 7, 'cd'], [13, 26, 'ef']) ; +my $r = Array::IntSpan->new(@expect) ; + +diag(Dumper $r) if $trace ; + +ok ( defined($r) , 'Array::IntSpan new() works') ; +is_deeply( $r , \@expect, 'new content ok') ; + + +foreach my $t ( + [[32,34],[]], + [[4,4],[]], + [[24,26],[[24,26,'ef']]], + [[24,29],[[24,26,'ef']]], + [[10,16],[[13,16,'ef']]], + [[20,24],[[20,24,'ef']]], + [[0,9],[[1,3,'ab'],[5,7,'cd']]], + [[0,6],[[1,3,'ab'],[5,6,'cd']]], + ) + { + my $new = $r->get_range(@{$t->[0]}) ; + is_deeply($new, $t->[1], "get_range @{$t->[0]}") || + diag("From ".Dumper($r)."Got ".Dumper ($new)) ; + is(@$r, 3, 'check nb of items in range') || diag(Dumper $r); + } + +my $fill = 'fi' ; + +foreach my $t ( + [ + [32,34], + [[32,34,$fill]], + [@expect,[32,34,$fill]] + ], + [ + [0,0], + [[ 0, 0,$fill]], + [[0,0,$fill],@expect] + ], + [ + [5,5], + [[ 5, 5,'cd']], + [[1,3,'ab'],[ 5, 5,'cd'],[6, 7, 'cd'], [13, 26, 'ef']] + ], + [ + [24,26], + [[24,26,'ef' ]], + [[1,3,'ab'],[5, 7, 'cd'], [13, 23,'ef'],[24,26, 'ef']] + ], + [ + [24,29], + [[24,26,'ef'],[27,29,$fill]], + [[1,3,'ab'],[5, 7, 'cd'], [13, 23,'ef'],[24,26,'ef'],[27,29,$fill]] + ], + [ + [10,16], + [[10,12,$fill],[13,16,'ef']], + [[1,3,'ab'],[5, 7, 'cd'], [10,12,$fill],,[13,16,'ef'],[17, 26, 'ef']] + ], + [ + [20,24], + [[20,24,'ef']], + [[1,3,'ab'],[5, 7,'cd'],[13,19,'ef'],[20,24,'ef'],[25,26,'ef']] + ], + [ + [0,9], + [[0,0,$fill],[1,3,'ab'],[4,4,$fill],[5,7,'cd'],[8,9,$fill]], + [[0,0,$fill],[1,3,'ab'],[4,4,$fill],[5,7,'cd'],[8,9,$fill], [13, 26, 'ef']] + ], + [ + [0,6], + [[0,0,$fill],[1,3,'ab'],[4,4,$fill],[5,6,'cd']], + [[0,0,$fill],[1,3,'ab'],[4,4,$fill],[5,6,'cd'],[7,7,'cd'], [13, 26, 'ef']] + ], + [ + [2,5], + [[2,3,'ab'],[4,4,$fill],[5, 5, 'cd']], + [[1,1,'ab'],[2,3,'ab'],[4,4,$fill],[5, 5, 'cd'],[6, 7, 'cd'], [13, 26, 'ef']] + ] + ) + { + my $r2 = Array::IntSpan->new(@expect) ; + my $old = Dumper($r2) ; + my $new = $r2->get_range(@{$t->[0]}, $fill) ; + is_deeply($new, $t->[1], "get_range with fill @{$t->[0]}") || + diag("From ".$old."Got ".Dumper ($new)) ; + is_deeply($r2, $t->[2], "range after get_range with fill") || + diag("From ".$old."Expected ".Dumper($t->[2])."Got ".Dumper ($r2)) ; + } + +my $sub = sub { "sfi"}; +$fill = &$sub ; + +foreach my $t ( + [[30,39],[[30,39,$fill]],[@expect,[30,39,$fill]]], + [ + [0,9], + [[0,0,$fill],[1,3,'ab'],[4,4,$fill],[5,7,'cd'],[8,9,$fill]], + [[0,0,$fill],[1,3,'ab'],[4,4,$fill],[5,7, 'cd'],[8,9,$fill], [13, 26, 'ef']] + ], + ) + { + my $r2 = Array::IntSpan->new(@expect) ; + my $old = Dumper($r2) ; + my $new = $r2->get_range(@{$t->[0]}, $sub) ; + is_deeply($new, $t->[1], "get_range with fill sub @{$t->[0]}") || + diag("From ".$old."Got ".Dumper ($new)) ; + is_deeply($r2, $t->[2], "range after get_range with sub") || + diag("From ".$old."Expected ".Dumper($t->[2])."Got ".Dumper ($r2)) ; + } + +@expect=([9,9,'ab'],[10,10,'bc'],[11,11,'cd'],[12,12,'ef']); +foreach my $t ( + [ + [9,10], + [[9,9,'ab'],[10,10,'bc']], + [@expect] + ], + [ + [9,12], + [@expect], + [@expect] + ] + ) + { + my $r2 = Array::IntSpan->new(@expect) ; + my $old = Dumper($r2) ; + my $new = $r2->get_range(@{$t->[0]}, $sub) ; + is_deeply($new, $t->[1], "get_range with fill sub @{$t->[0]}") || + diag("From ".$old."Got ".Dumper ($new)) ; + is_deeply($r2, $t->[2], "range after get_range with sub") || + diag("From ".$old."Expected ".Dumper($t->[2])."Got ".Dumper ($r2)) ; + } + +@expect= ([1,3,'ab'],[5, 5, 'cd'], [13, 26, 'ef']) ; +my $rs = Array::IntSpan->new(@expect) ; + +is_deeply([ $rs->get_range_list ], [[1,3],[5, 5], [13, 26] ], "get_ranges in list context"); +is_deeply(scalar $rs->get_range_list, '1-3, 5, 13-26', "get_ranges in scalar context"); + +diag(Dumper $r) if $trace ; diff --git a/t/get_splice_parms.t b/t/get_splice_parms.t new file mode 100644 index 0000000..aaa6467 --- /dev/null +++ b/t/get_splice_parms.t @@ -0,0 +1,55 @@ + +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 30 ; +use Data::Dumper ; + +use Array::IntSpan; + +my $trace = shift || 0 ; + +my @expect= ([1,3,'ab'],[6,9,'cd']) ; +my $r = Array::IntSpan->new(@expect) ; + +diag(Dumper $r) if $trace ; + +ok ( defined($r) , 'Array::IntSpan new() works') ; +is_deeply( $r , \@expect, 'new content ok') ; + +my $spawn = sub { 'sp:'.$_[2] ;} ; + +foreach my $a ( + [[0, 0,'bc'],[0,0,[0, 0,'bc']]], + [[0, 1,'bc'],[0,1,[0, 1,'bc'],[2,3,'ab']]], + [[0, 3,'bc'],[0,1,[0, 3,'bc']]], + [[0, 4,'bc'],[0,1,[0, 4,'bc']]], + [[0, 5,'bc'],[0,1,[0, 5,'bc']]], + [[0, 6,'bc'],[0,2,[0, 6,'bc'],[7,9,'cd']]], + [[0, 9,'bc'],[0,2,[0, 9,'bc']]], + [[0,10,'bc'],[0,2,[0,10,'bc']]], + [[1, 3,'bc'],[0,1,[1, 3,'bc']]], + [[1, 2,'bc'],[0,1,[1, 2,'bc'],[3, 3,'ab']]], + [[2, 2,'bc'],[0,1,[1, 1,'ab'],[2, 2,'bc'],[3,3,'ab']]], + [[2, 3,'bc'],[0,1,[1, 1,'ab'],[2, 3,'bc']]], + [[2, 5,'bc'],[0,1,[1, 1,'ab'],[2, 5,'bc']]], + [[2, 8,'bc'],[0,2,[1, 1,'ab'],[2, 8,'bc'],[9,9,'cd']]], + [[2, 9,'bc'],[0,2,[1, 1,'ab'],[2, 9,'bc']]], + [[2,10,'bc'],[0,2,[1, 1,'ab'],[2,10,'bc']]], + [[4, 4,'bc'],[1,0,[4, 4,'bc']]], + [[5, 6,'bc'],[1,1,[5, 6,'bc'],[7,9,'cd']]], + [[5, 9,'bc'],[1,1,[5, 9,'bc']]], + [[5,11,'bc'],[1,1,[5,11,'bc']]], + [[6, 6,'bc'],[1,1,[6, 6,'bc'],[7,9,'cd']]], + [[6, 9,'bc'],[1,1,[6, 9,'bc']]], + [[7, 9,'bc'],[1,1,[6, 6,'cd'],[7,9,'bc']]], + [[9,11,'bc'],[1,1,[6, 8,'cd'],[9,11,'bc']]], + [[10,11,'bc'],[2,0,[10,11,'bc']]], + [[10,11,'bc', $spawn],[2,0,[10,11,'bc']]], + [[9,11,'bc', $spawn],[1,1,[6, 8,'sp:cd'],[9,11,'bc']]], + [[2, 2,'bc', $spawn],[0,1,[1, 1,'sp:ab'],[2, 2,'bc'],[3,3,'sp:ab']]], + ) + { + my @r = $r->get_splice_parms(@{$a->[0]}) ; + is_deeply(\@r, $a->[1], "get_splice_parms @{$a->[0]}") || diag(Dumper \@r); + } + diff --git a/t/search.t b/t/search.t new file mode 100644 index 0000000..502f8ec --- /dev/null +++ b/t/search.t @@ -0,0 +1,23 @@ + +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 9 ; +use Data::Dumper ; + +use Array::IntSpan; + +my $trace = shift || 0 ; + +my @expect= ([1,3,'ab'],[6,9,'cd']) ; +my $r = Array::IntSpan->new(@expect) ; + +diag(Dumper $r) if $trace ; + +ok ( defined($r) , 'Array::IntSpan new() works') ; +is_deeply( $r , \@expect, 'new content ok') ; + +foreach my $a ( [2,0], [3,0], [4,1], [4,1], [6,1], [9,1] , [10,2]) + { + is($r->search(0,2,$a->[0]), $a->[1], "search(0,2,$a->[0], $a->[1] )"); + } + diff --git a/t/set_range.t b/t/set_range.t new file mode 100644 index 0000000..a14eaa3 --- /dev/null +++ b/t/set_range.t @@ -0,0 +1,46 @@ +# -*- cperl-mode -*- + +use warnings FATAL => qw(all); +use ExtUtils::testlib; +use Test::More tests => 10 ; +use Data::Dumper ; + +use Array::IntSpan; + +my $trace = shift || 0 ; + +my @expect= ([1,3,'ab'],[6,9,'cd']) ; +my $r = Array::IntSpan->new(@expect) ; + +diag(Dumper $r) if $trace ; + +ok ( defined($r) , 'Array::IntSpan new() works') ; +is_deeply( $r , \@expect, 'new content ok') ; + +my @range = (12,14,'ef') ; +is ($r->set_range(@range),0, 'set_range after') ; +push @expect, [@range] ; +is_deeply( $r , \@expect ) ; + +is($r->lookup(13), 'ef', 'lookup 13') ; +diag(Dumper $r) if $trace ; + +@range = (8,13,'ef') ; +@expect = ([1, 3, 'ab'], [6, 7, 'cd'], [8, 13, 'ef'], [14, 14, 'ef']) ; +is ($r->set_range(@range),1, "set_range @range") ; +is_deeply($r, \@expect) || diag(Dumper $r); +diag(Dumper $r) if $trace ; + +my $sub = sub {"c:".$_[2];} ; + +@range = (10,13,'ef2') ; +@expect = ([1, 3, 'ab'], [6, 7, 'cd'], [8, 9, 'c:ef'], [10, 13, 'ef2'], [14, 14, 'ef']) ; +is ($r->set_range(@range,$sub),1, "set_range @range with sub") ; +is_deeply($r, \@expect) || diag(Dumper $r); +diag(Dumper $r) if $trace ; + +my $rs = Array::IntSpan->new() ; +$rs->set('21','bar'); +$rs->set_range_as_string('1-10 ,13, 14-20', 'foo') ; +is_deeply($rs, [[1,10,'foo'],[13,13,'foo'],[14,20,'foo'],[21,21,'bar']],"set_range_as_string") + || diag(Dumper $rs);