openkylin
/
libarray-intspan-perl
mirror of https://gitee.com/openkylin/libarray-intspan-perl.git
9
0
Fork 1
Code Issues Projects Releases Wiki Activity

Import Upstream version 2.004

This commit is contained in:
denghao 2022-09-02 08:44:07 +03:00
commit 6cd3c9f4be
19 changed files with 2313 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

94
Changes Normal file
View File

@ -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 <ddumont@cpan.org> 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

207
LICENSE Normal file
View File

@ -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.

20
MANIFEST Normal file
View File

@ -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

67
META.json Normal file
View File

@ -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"
}

37
META.yml Normal file
View File

@ -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

58
Makefile.PL Normal file
View File

@ -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);

63
README Normal file
View File

@ -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 <dist_file>.tar.gz | tar xvf -
cd <dist_directory>
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

47
dist.ini Normal file
View File

@ -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]

805
lib/Array/IntSpan.pm Normal file
View File

@ -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<Array::IntSpan> brings the speed advantages of C<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.
The new version of C<Array::IntSpan> 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<Array::IntSpan> can also handle objects instead of scalar values.
But for the consolidation to work, the payload class must overload the
C<"">, C<eq> 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<not> 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<Array::IntSpan::IP> 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<Array::IntSpan::IP> for
details.
=item *
C<Array::IntSpan::Fields> 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<Array::IntSpan::Fields> for details.
=back
=head1 METHODS
=head2 new (...)
The C<new> 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<Data::Dumper> 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<start_index>, the
C<end_index>, and the C<value>. If you wish to erase a range, specify
C<undef> for the C<value>. 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<value>.
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<different> 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<start> to C<end>.
If C<start> and C<end> span empty slot in the original range,
get_range will skip the empty slots. If a C<filler> 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<filler> 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<get_range(5,6)> in the example above). When handling object, the
sub ref can invoke an object constructor.
If C<start> or C<end> 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<obj_a>) 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<get_range(2)> will also be invoked on the range 1-4 of the original
range which may not be what you want.
If C<get_range> is invoked with a copy parameter (actually a code
reference), the result of this routine will be stored in the split
range I<outside> 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<obj_a> contained in the C<split range> and the
C<obj_a> contained in the returned range point to the I<same object>.
The sub ref is invoked with C<(start,end,obj_a)> and is expected to
return a copy of C<obj_a> that will be stored in the split ranges. In
the example above, 2 different copies are made: C<obj_a1> and
C<obj_a2>.
Last, a 3rd callback may be defined by the user: the C<set_cb>. This
callback will be used when the range start or end that holds an object
changes. In the example above, the C<set_cb> 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<get_range> 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<index> to look up. If
there is an appropriate range, the method will return the associated
value. Otherwise, it returns C<undef>.
=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<bottom> to C<top>
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<must> 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<set_cb> 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<consolidate> performs this call:
$set->(1,9,obj_a) ;
Consolidate the whole range when called without parameters.
=head1 CONTRIBUTORS
=over
=item *
Mohammad S Anwar <mohammad.anwar@yahoo.com>
=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

288
lib/Array/IntSpan/Fields.pm Normal file
View File

@ -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<Array::IntSpan::Fields> brings the advantages of C<Array::IntSpan>
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<set_format> 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<Array::IntSpan> 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<Array::IntSpan> 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

172
lib/Array/IntSpan/IP.pm Normal file
View File

@ -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<Array::IntSpan::IP> brings the advantages of C<Array::IntSpan> to IP
address indices. Anywhere you use an index in C<Array::IntSpan>, you
can use an IP address in one of three forms in C<Array::IntSpan::IP>.
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<Array::IntSpan::IP::ip_as_int> 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

35
t/clobbered_items.t Normal file
View File

@ -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) ;
}

49
t/consolidate.t Normal file
View File

@ -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)) ;
}

23
t/empty_span.t Normal file
View File

@ -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');

67
t/fields.t Normal file
View File

@ -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') ;

157
t/get_range.t Normal file
View File

@ -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 ;

55
t/get_splice_parms.t Normal file
View File

@ -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);
}

23
t/search.t Normal file
View File

@ -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] )");
}

46
t/set_range.t Normal file
View File

@ -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);