# dist_name: name of the package in cpan if it differs from name (ex.: LWP != libwww-perl)
@required_modules = (
{ name => "parent", url => "http://search.cpan.org/~corion/", debian => 'libparent-perl' },
- { name => "Algorithm::CheckDigits", url => "http://search.cpan.org/dist/Algorithm-CheckDigits/", debian => 'libalgorithm-checkdigits-perl' },
+ { name => "Algorithm::CheckDigits", url => "http://search.cpan.org/~mamawe/", debian => 'libalgorithm-checkdigits-perl' },
{ name => "Archive::Zip", version => '1.16', url => "http://search.cpan.org/~phred/", debian => 'libarchive-zip-perl' },
{ name => "CGI", version => '3.43', url => "http://search.cpan.org/~leejo/", debian => 'libcgi-pm-perl' }, # 4.09 is not core anymore (perl 5.20)
{ name => "Clone", url => "http://search.cpan.org/~rdf/", debian => 'libclone-perl' },
{ name => "Config::Std", url => "http://search.cpan.org/~dconway/", debian => 'libconfig-std-perl' },
+ { name => "Daemon::Generic", version => '0.71', url => "http://search.cpan.org/~muir/", },
{ name => "DateTime", url => "http://search.cpan.org/~drolsky/", debian => 'libdatetime-perl' },
+ { name => "DateTime::Event::Cron", version => '0.08', url => "http://search.cpan.org/~msisk/", },
{ name => "DateTime::Format::Strptime", url => "http://search.cpan.org/~drolsky/", debian => 'libdatetime-format-strptime-perl' },
+ { name => "DateTime::Set", version => '0.12', url => "http://search.cpan.org/~fglock/", debian => 'libdatetime-set-perl' },
{ name => "DBI", version => '1.50', url => "http://search.cpan.org/~timb/", debian => 'libdbi-perl' },
{ name => "DBD::Pg", version => '1.49', url => "http://search.cpan.org/~dbdpg/", debian => 'libdbd-pg-perl' },
{ name => "Digest::SHA", url => "http://search.cpan.org/~mshelor/", debian => 'libdigest-sha-perl' },
- { name => "Email::Address", url => "http://search.cpan.org/~rjbs/", debian => 'libemail-address-perl' },
+ { name => "Exception::Lite", url => "http://search.cpan.org/~elisheva/", },
+ { name => "Email::Address", version => '1.888', url => "http://search.cpan.org/~rjbs/", debian => 'libemail-address-perl' },
{ name => "Email::MIME", url => "http://search.cpan.org/~rjbs/", debian => 'libemail-mime-perl' },
{ name => "FCGI", version => '0.72', url => "http://search.cpan.org/~mstrout/", debian => 'libfcgi-perl' },
{ name => "File::Copy::Recursive", url => "http://search.cpan.org/~dmuey/", debian => 'libfile-copy-recursive-perl' },
+ { name => "File::Flock", version => '2008.01', url => "http://search.cpan.org/~muir/", },
{ name => "File::MimeInfo", url => "http://search.cpan.org/~michielb/", debian => 'libfile-mimeinfo-perl' },
{ name => "GD", url => "http://search.cpan.org/~lds/", debian => 'libgd-gd2-perl', },
{ name => 'HTML::Parser', url => 'http://search.cpan.org/~gaas/', debian => 'libhtml-parser-perl', },
{ name => 'HTML::Restrict', url => 'http://search.cpan.org/~oalders/', },
{ name => "Image::Info", url => "http://search.cpan.org/~srezic/", debian => 'libimage-info-perl' },
{ name => "JSON", url => "http://search.cpan.org/~makamaka", debian => 'libjson-perl' },
- { name => "List::MoreUtils", version => '0.21', url => "http://search.cpan.org/~vparseval/", debian => 'liblist-moreutils-perl' },
- { name => "List::UtilsBy", url => "http://search.cpan.org/~pevans/", debian => 'liblist-utilsby-perl' },
+ { name => "List::MoreUtils", version => '0.30', url => "http://search.cpan.org/~vparseval/", debian => 'liblist-moreutils-perl' },
+ { name => "List::UtilsBy", version => '0.09', url => "http://search.cpan.org/~pevans/", debian => 'liblist-utilsby-perl' },
{ name => "LWP::Authen::Digest", url => "http://search.cpan.org/~gaas/", debian => 'libwww-perl', dist_name => 'libwww-perl' },
{ name => "LWP::UserAgent", url => "http://search.cpan.org/~gaas/", debian => 'libwww-perl', dist_name => 'libwww-perl' },
{ name => "Params::Validate", url => "http://search.cpan.org/~drolsky/", debian => 'libparams-validate-perl' },
- { name => "PBKDF2::Tiny", version => '0.005', url => "http://search.cpan.org/~arodland/", },
+ { name => "PBKDF2::Tiny", version => '0.005', url => "http://search.cpan.org/~dagolden/", debian => 'libpbkdf2-tiny-perl' },
{ name => "PDF::API2", version => '2.000', url => "http://search.cpan.org/~areibens/", debian => 'libpdf-api2-perl' },
+ { name => "Regexp::IPv6", version => '0.03', url => "http://search.cpan.org/~salva/", debian => 'libregexp-ipv6-perl' },
{ name => "Rose::Object", url => "http://search.cpan.org/~jsiracusa/", debian => 'librose-object-perl' },
{ name => "Rose::DB", url => "http://search.cpan.org/~jsiracusa/", debian => 'librose-db-perl' },
{ name => "Rose::DB::Object", version => 0.788, url => "http://search.cpan.org/~jsiracusa/", debian => 'librose-db-object-perl' },
+ { name => "Set::Infinite", version => '0.63', url => "http://search.cpan.org/~fglock/", },
+ { name => "Set::Crontab", version => '1.03', url => "http://search.cpan.org/~ams/", },
{ name => "String::ShellQuote", version => 1.01, url => "http://search.cpan.org/~rosch/", debian => 'libstring-shellquote-perl' },
{ name => "Sort::Naturally", url => "http://search.cpan.org/~sburke/", debian => 'libsort-naturally-perl' },
# Test::Harness is core, so no Debian packages. Test::Harness 3.00 was first packaged in 5.10.1
+++ /dev/null
-
-package DateTime::Set;
-
-use strict;
-use Carp;
-use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
-use DateTime 0.12; # this is for version checking only
-use DateTime::Duration;
-use DateTime::Span;
-use Set::Infinite 0.59;
-use Set::Infinite::_recurrence;
-
-use vars qw( $VERSION );
-
-use constant INFINITY => 100 ** 100 ** 100 ;
-use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
-
-BEGIN {
- $VERSION = '0.28';
-}
-
-
-sub _fix_datetime {
- # internal function -
- # (not a class method)
- #
- # checks that the parameter is an object, and
- # also protects the object against mutation
-
- return $_[0]
- unless defined $_[0]; # error
- return $_[0]->clone
- if ref( $_[0] ); # "immutable" datetime
- return DateTime::Infinite::Future->new
- if $_[0] == INFINITY; # Inf
- return DateTime::Infinite::Past->new
- if $_[0] == NEG_INFINITY; # -Inf
- return $_[0]; # error
-}
-
-sub _fix_return_datetime {
- my ( $dt, $dt_arg ) = @_;
-
- # internal function -
- # (not a class method)
- #
- # checks that the returned datetime has the same
- # time zone as the parameter
-
- # TODO: set locale
-
- return unless $dt;
- return unless $dt_arg;
- if ( $dt_arg->can('time_zone_long_name') &&
- !( $dt_arg->time_zone_long_name eq 'floating' ) )
- {
- $dt->set_time_zone( $dt_arg->time_zone );
- }
- return $dt;
-}
-
-sub iterate {
- # deprecated method - use map() or grep() instead
- my ( $self, $callback ) = @_;
- my $class = ref( $self );
- my $return = $class->empty_set;
- $return->{set} = $self->{set}->iterate(
- sub {
- my $min = $_[0]->min;
- $callback->( $min->clone ) if ref($min);
- }
- );
- $return;
-}
-
-sub map {
- my ( $self, $callback ) = @_;
- my $class = ref( $self );
- die "The callback parameter to map() must be a subroutine reference"
- unless ref( $callback ) eq 'CODE';
- my $return = $class->empty_set;
- $return->{set} = $self->{set}->iterate(
- sub {
- local $_ = $_[0]->min;
- next unless ref( $_ );
- $_ = $_->clone;
- my @list = $callback->();
- my $set = Set::Infinite::_recurrence->new();
- $set = $set->union( $_ ) for @list;
- return $set;
- }
- );
- $return;
-}
-
-sub grep {
- my ( $self, $callback ) = @_;
- my $class = ref( $self );
- die "The callback parameter to grep() must be a subroutine reference"
- unless ref( $callback ) eq 'CODE';
- my $return = $class->empty_set;
- $return->{set} = $self->{set}->iterate(
- sub {
- local $_ = $_[0]->min;
- next unless ref( $_ );
- $_ = $_->clone;
- my $result = $callback->();
- return $_ if $result;
- return;
- }
- );
- $return;
-}
-
-sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }
-
-sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }
-
-sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
-
-sub add_duration {
- my ( $self, $dur ) = @_;
- $dur = $dur->clone; # $dur must be "immutable"
-
- $self->{set} = $self->{set}->iterate(
- sub {
- my $min = $_[0]->min;
- $min->clone->add_duration( $dur ) if ref($min);
- },
- backtrack_callback => sub {
- my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
- if ( ref($min) )
- {
- $min = $min->clone;
- $min->subtract_duration( $dur );
- }
- if ( ref($max) )
- {
- $max = $max->clone;
- $max->subtract_duration( $dur );
- }
- return Set::Infinite::_recurrence->new( $min, $max );
- },
- );
- $self;
-}
-
-sub set_time_zone {
- my ( $self, $tz ) = @_;
-
- $self->{set} = $self->{set}->iterate(
- sub {
- my $min = $_[0]->min;
- $min->clone->set_time_zone( $tz ) if ref($min);
- },
- backtrack_callback => sub {
- my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
- if ( ref($min) )
- {
- $min = $min->clone;
- $min->set_time_zone( $tz );
- }
- if ( ref($max) )
- {
- $max = $max->clone;
- $max->set_time_zone( $tz );
- }
- return Set::Infinite::_recurrence->new( $min, $max );
- },
- );
- $self;
-}
-
-sub set {
- my $self = shift;
- my %args = validate( @_,
- { locale => { type => SCALAR | OBJECT,
- default => undef },
- }
- );
- $self->{set} = $self->{set}->iterate(
- sub {
- my $min = $_[0]->min;
- $min->clone->set( %args ) if ref($min);
- },
- );
- $self;
-}
-
-sub from_recurrence {
- my $class = shift;
-
- my %args = @_;
- my %param;
-
- # Parameter renaming, such that we can use either
- # recurrence => xxx or next => xxx, previous => xxx
- $param{next} = delete $args{recurrence} || delete $args{next};
- $param{previous} = delete $args{previous};
-
- $param{span} = delete $args{span};
- # they might be specifying a span using begin / end
- $param{span} = DateTime::Span->new( %args ) if keys %args;
-
- my $self = {};
-
- die "Not enough arguments in from_recurrence()"
- unless $param{next} || $param{previous};
-
- if ( ! $param{previous} )
- {
- my $data = {};
- $param{previous} =
- sub {
- _callback_previous ( _fix_datetime( $_[0] ), $param{next}, $data );
- }
- }
- else
- {
- my $previous = $param{previous};
- $param{previous} =
- sub {
- $previous->( _fix_datetime( $_[0] ) );
- }
- }
-
- if ( ! $param{next} )
- {
- my $data = {};
- $param{next} =
- sub {
- _callback_next ( _fix_datetime( $_[0] ), $param{previous}, $data );
- }
- }
- else
- {
- my $next = $param{next};
- $param{next} =
- sub {
- $next->( _fix_datetime( $_[0] ) );
- }
- }
-
- my ( $min, $max );
- $max = $param{previous}->( DateTime::Infinite::Future->new );
- $min = $param{next}->( DateTime::Infinite::Past->new );
- $max = INFINITY if $max->is_infinite;
- $min = NEG_INFINITY if $min->is_infinite;
-
- my $base_set = Set::Infinite::_recurrence->new( $min, $max );
- $base_set = $base_set->intersection( $param{span}->{set} )
- if $param{span};
-
- # warn "base set is $base_set\n";
-
- my $data = {};
- $self->{set} =
- $base_set->_recurrence(
- $param{next},
- $param{previous},
- $data,
- );
- bless $self, $class;
-
- return $self;
-}
-
-sub from_datetimes {
- my $class = shift;
- my %args = validate( @_,
- { dates =>
- { type => ARRAYREF,
- },
- }
- );
- my $self = {};
- $self->{set} = Set::Infinite::_recurrence->new;
- # possible optimization: sort datetimes and use "push"
- for( @{ $args{dates} } )
- {
- # DateTime::Infinite objects are not welcome here,
- # but this is not enforced (it does't hurt)
-
- carp "The 'dates' argument to from_datetimes() must only contain ".
- "datetime objects"
- unless UNIVERSAL::can( $_, 'utc_rd_values' );
-
- $self->{set} = $self->{set}->union( $_->clone );
- }
-
- bless $self, $class;
- return $self;
-}
-
-sub empty_set {
- my $class = shift;
-
- return bless { set => Set::Infinite::_recurrence->new }, $class;
-}
-
-sub clone {
- my $self = bless { %{ $_[0] } }, ref $_[0];
- $self->{set} = $_[0]->{set}->copy;
- return $self;
-}
-
-# default callback that returns the
-# "previous" value in a callback recurrence.
-#
-# This is used to simulate a 'previous' callback,
-# when then 'previous' argument in 'from_recurrence' is missing.
-#
-sub _callback_previous {
- my ($value, $callback_next, $callback_info) = @_;
- my $previous = $value->clone;
-
- return $value if $value->is_infinite;
-
- my $freq = $callback_info->{freq};
- unless (defined $freq)
- {
- # This is called just once, to setup the recurrence frequency
- my $previous = $callback_next->( $value );
- my $next = $callback_next->( $previous );
- $freq = 2 * ( $previous - $next );
- # save it for future use with this same recurrence
- $callback_info->{freq} = $freq;
- }
-
- $previous->add_duration( $freq );
- $previous = $callback_next->( $previous );
- if ($previous >= $value)
- {
- # This error happens if the event frequency oscilates widely
- # (more than 100% of difference from one interval to next)
- my @freq = $freq->deltas;
- print STDERR "_callback_previous: Delta components are: @freq\n";
- warn "_callback_previous: iterator can't find a previous value, got ".
- $previous->ymd." after ".$value->ymd;
- }
- my $previous1;
- while (1)
- {
- $previous1 = $previous->clone;
- $previous = $callback_next->( $previous );
- return $previous1 if $previous >= $value;
- }
-}
-
-# default callback that returns the
-# "next" value in a callback recurrence.
-#
-# This is used to simulate a 'next' callback,
-# when then 'next' argument in 'from_recurrence' is missing.
-#
-sub _callback_next {
- my ($value, $callback_previous, $callback_info) = @_;
- my $next = $value->clone;
-
- return $value if $value->is_infinite;
-
- my $freq = $callback_info->{freq};
- unless (defined $freq)
- {
- # This is called just once, to setup the recurrence frequency
- my $next = $callback_previous->( $value );
- my $previous = $callback_previous->( $next );
- $freq = 2 * ( $next - $previous );
- # save it for future use with this same recurrence
- $callback_info->{freq} = $freq;
- }
-
- $next->add_duration( $freq );
- $next = $callback_previous->( $next );
- if ($next <= $value)
- {
- # This error happens if the event frequency oscilates widely
- # (more than 100% of difference from one interval to next)
- my @freq = $freq->deltas;
- print STDERR "_callback_next: Delta components are: @freq\n";
- warn "_callback_next: iterator can't find a previous value, got ".
- $next->ymd." before ".$value->ymd;
- }
- my $next1;
- while (1)
- {
- $next1 = $next->clone;
- $next = $callback_previous->( $next );
- return $next1 if $next >= $value;
- }
-}
-
-sub iterator {
- my $self = shift;
-
- my %args = @_;
- my $span;
- $span = delete $args{span};
- $span = DateTime::Span->new( %args ) if %args;
-
- return $self->intersection( $span ) if $span;
- return $self->clone;
-}
-
-
-# next() gets the next element from an iterator()
-# next( $dt ) returns the next element after a datetime.
-sub next {
- my $self = shift;
- return undef unless ref( $self->{set} );
-
- if ( @_ )
- {
- if ( $self->{set}->_is_recurrence )
- {
- return _fix_return_datetime(
- $self->{set}->{param}[0]->( $_[0] ), $_[0] );
- }
- else
- {
- my $span = DateTime::Span->from_datetimes( after => $_[0] );
- return _fix_return_datetime(
- $self->intersection( $span )->next, $_[0] );
- }
- }
-
- my ($head, $tail) = $self->{set}->first;
- $self->{set} = $tail;
- return $head->min if defined $head;
- return $head;
-}
-
-# previous() gets the last element from an iterator()
-# previous( $dt ) returns the previous element before a datetime.
-sub previous {
- my $self = shift;
- return undef unless ref( $self->{set} );
-
- if ( @_ )
- {
- if ( $self->{set}->_is_recurrence )
- {
- return _fix_return_datetime(
- $self->{set}->{param}[1]->( $_[0] ), $_[0] );
- }
- else
- {
- my $span = DateTime::Span->from_datetimes( before => $_[0] );
- return _fix_return_datetime(
- $self->intersection( $span )->previous, $_[0] );
- }
- }
-
- my ($head, $tail) = $self->{set}->last;
- $self->{set} = $tail;
- return $head->max if defined $head;
- return $head;
-}
-
-# "current" means less-or-equal to a datetime
-sub current {
- my $self = shift;
-
- return undef unless ref( $self->{set} );
-
- if ( $self->{set}->_is_recurrence )
- {
- my $tmp = $self->next( $_[0] );
- return $self->previous( $tmp );
- }
-
- return $_[0] if $self->contains( $_[0] );
- $self->previous( $_[0] );
-}
-
-sub closest {
- my $self = shift;
- # return $_[0] if $self->contains( $_[0] );
- my $dt1 = $self->current( $_[0] );
- my $dt2 = $self->next( $_[0] );
-
- return $dt2 unless defined $dt1;
- return $dt1 unless defined $dt2;
-
- my $delta = $_[0] - $dt1;
- return $dt1 if ( $dt2 - $delta ) >= $_[0];
-
- return $dt2;
-}
-
-sub as_list {
- my $self = shift;
- return undef unless ref( $self->{set} );
-
- my %args = @_;
- my $span;
- $span = delete $args{span};
- $span = DateTime::Span->new( %args ) if %args;
-
- my $set = $self->clone;
- $set = $set->intersection( $span ) if $span;
-
- return if $set->{set}->is_null; # nothing = empty
-
- # Note: removing this line means we may end up in an infinite loop!
- ## return undef if $set->{set}->is_too_complex; # undef = no begin/end
-
- return undef
- if $set->max->is_infinite ||
- $set->min->is_infinite;
-
- my @result;
- my $next = $self->min;
- if ( $span ) {
- my $next1 = $span->min;
- $next = $next1 if $next1 && $next1 > $next;
- $next = $self->current( $next );
- }
- my $last = $self->max;
- if ( $span ) {
- my $last1 = $span->max;
- $last = $last1 if $last1 && $last1 < $last;
- }
- do {
- push @result, $next if !$span || $span->contains($next);
- $next = $self->next( $next );
- }
- while $next && $next <= $last;
- return @result;
-}
-
-sub intersection {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
- return $tmp;
-}
-
-sub intersects {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- unless ( $set2->can( 'union' ) )
- {
- if ( $set1->{set}->_is_recurrence )
- {
- for ( $set2, @_ )
- {
- return 1 if $set1->current( $_ ) == $_;
- }
- return 0;
- }
- $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
- }
- return $set1->{set}->intersects( $set2->{set} );
-}
-
-sub contains {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- unless ( $set2->can( 'union' ) )
- {
- if ( $set1->{set}->_is_recurrence )
- {
- for ( $set2, @_ )
- {
- return 0 unless $set1->current( $_ ) == $_;
- }
- return 1;
- }
- $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
- }
- return $set1->{set}->contains( $set2->{set} );
-}
-
-sub union {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->union( $set2->{set} );
- bless $tmp, 'DateTime::SpanSet'
- if $set2->isa('DateTime::Span') or $set2->isa('DateTime::SpanSet');
- return $tmp;
-}
-
-sub complement {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- if (defined $set2)
- {
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = $class->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- # TODO: "compose complement";
- $tmp->{set} = $set1->{set}->complement( $set2->{set} );
- }
- else
- {
- $tmp->{set} = $set1->{set}->complement;
- bless $tmp, 'DateTime::SpanSet';
- }
- return $tmp;
-}
-
-sub min {
- return _fix_datetime( $_[0]->{set}->min );
-}
-
-sub max {
- return _fix_datetime( $_[0]->{set}->max );
-}
-
-# returns a DateTime::Span
-sub span {
- my $set = $_[0]->{set}->span;
- my $self = bless { set => $set }, 'DateTime::Span';
- return $self;
-}
-
-sub count {
- my ($self) = shift;
- return undef unless ref( $self->{set} );
-
- my %args = @_;
- my $span;
- $span = delete $args{span};
- $span = DateTime::Span->new( %args ) if %args;
-
- my $set = $self->clone;
- $set = $set->intersection( $span ) if $span;
-
- return $set->{set}->count
- unless $set->{set}->is_too_complex;
-
- return undef
- if $set->max->is_infinite ||
- $set->min->is_infinite;
-
- my $count = 0;
- my $iter = $set->iterator;
- $count++ while $iter->next;
- return $count;
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-DateTime::Set - Datetime sets and set math
-
-=head1 SYNOPSIS
-
- use DateTime;
- use DateTime::Set;
-
- $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
- $set1 = DateTime::Set->from_datetimes( dates => [ $date1 ] );
- # set1 = 2002-03-11
-
- $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
- $set2 = DateTime::Set->from_datetimes( dates => [ $date1, $date2 ] );
- # set2 = 2002-03-11, and 2003-04-12
-
- $date3 = DateTime->new( year => 2003, month => 4, day => 1 );
- print $set2->next( $date3 )->ymd; # 2003-04-12
- print $set2->previous( $date3 )->ymd; # 2002-03-11
- print $set2->current( $date3 )->ymd; # 2002-03-11
- print $set2->closest( $date3 )->ymd; # 2003-04-12
-
- # a 'monthly' recurrence:
- $set = DateTime::Set->from_recurrence(
- recurrence => sub {
- return $_[0] if $_[0]->is_infinite;
- return $_[0]->truncate( to => 'month' )->add( months => 1 )
- },
- span => $date_span1, # optional span
- );
-
- $set = $set1->union( $set2 ); # like "OR", "insert", "both"
- $set = $set1->complement( $set2 ); # like "delete", "remove"
- $set = $set1->intersection( $set2 ); # like "AND", "while"
- $set = $set1->complement; # like "NOT", "negate", "invert"
-
- if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
- if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
-
- # data extraction
- $date = $set1->min; # first date of the set
- $date = $set1->max; # last date of the set
-
- $iter = $set1->iterator;
- while ( $dt = $iter->next ) {
- print $dt->ymd;
- };
-
-=head1 DESCRIPTION
-
-DateTime::Set is a module for datetime sets. It can be used to handle
-two different types of sets.
-
-The first is a fixed set of predefined datetime objects. For example,
-if we wanted to create a set of datetimes containing the birthdays of
-people in our family for the current year.
-
-The second type of set that it can handle is one based on a
-recurrence, such as "every Wednesday", or "noon on the 15th day of
-every month". This type of set can have fixed starting and ending
-datetimes, but neither is required. So our "every Wednesday set"
-could be "every Wednesday from the beginning of time until the end of
-time", or "every Wednesday after 2003-03-05 until the end of time", or
-"every Wednesday between 2003-03-05 and 2004-01-07".
-
-This module also supports set math operations, so you do things like
-create a new set from the union or difference of two sets, check
-whether a datetime is a member of a given set, etc.
-
-This is different from a C<DateTime::Span>, which handles a continuous
-range as opposed to individual datetime points. There is also a module
-C<DateTime::SpanSet> to handle sets of spans.
-
-=head1 METHODS
-
-=over 4
-
-=item * from_datetimes
-
-Creates a new set from a list of datetimes.
-
- $dates = DateTime::Set->from_datetimes( dates => [ $dt1, $dt2, $dt3 ] );
-
-The datetimes can be objects from class C<DateTime>, or from a
-C<DateTime::Calendar::*> class.
-
-C<DateTime::Infinite::*> objects are not valid set members.
-
-=item * from_recurrence
-
-Creates a new set specified via a "recurrence" callback.
-
- $months = DateTime::Set->from_recurrence(
- span => $dt_span_this_year, # optional span
- recurrence => sub {
- return $_[0]->truncate( to => 'month' )->add( months => 1 )
- },
- );
-
-The C<span> parameter is optional. It must be a C<DateTime::Span> object.
-
-The span can also be specified using C<begin> / C<after> and C<before>
-/ C<end> parameters, as in the C<DateTime::Span> constructor. In this
-case, if there is a C<span> parameter it will be ignored.
-
- $months = DateTime::Set->from_recurrence(
- after => $dt_now,
- recurrence => sub {
- return $_[0]->truncate( to => 'month' )->add( months => 1 );
- },
- );
-
-The recurrence function will be passed a single parameter, a datetime
-object. The parameter can be an object from class C<DateTime>, or from
-one of the C<DateTime::Calendar::*> classes. The parameter can also
-be a C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>
-object.
-
-The recurrence must return the I<next> event after that object. There
-is no guarantee as to what the returned object will be set to, only
-that it will be greater than the object passed to the recurrence.
-
-If there are no more datetimes after the given parameter, then the
-recurrence function should return C<DateTime::Infinite::Future>.
-
-It is ok to modify the parameter C<$_[0]> inside the recurrence
-function. There are no side-effects.
-
-For example, if you wanted a recurrence that generated datetimes in
-increments of 30 seconds, it would look like this:
-
- sub every_30_seconds {
- my $dt = shift;
- if ( $dt->second < 30 ) {
- return $dt->truncate( to => 'minute' )->add( seconds => 30 );
- } else {
- return $dt->truncate( to => 'minute' )->add( minutes => 1 );
- }
- }
-
-Note that this recurrence takes leap seconds into account. Consider
-using C<truncate()> in this manner to avoid complicated arithmetic
-problems!
-
-It is also possible to create a recurrence by specifying either or both
-of 'next' and 'previous' callbacks.
-
-The callbacks can return C<DateTime::Infinite::Future> and
-C<DateTime::Infinite::Past> objects, in order to define I<bounded
-recurrences>. In this case, both 'next' and 'previous' callbacks must
-be defined:
-
- # "monthly from $dt until forever"
-
- my $months = DateTime::Set->from_recurrence(
- next => sub {
- return $dt if $_[0] < $dt;
- $_[0]->truncate( to => 'month' );
- $_[0]->add( months => 1 );
- return $_[0];
- },
- previous => sub {
- my $param = $_[0]->clone;
- $_[0]->truncate( to => 'month' );
- $_[0]->subtract( months => 1 ) if $_[0] == $param;
- return $_[0] if $_[0] >= $dt;
- return DateTime::Infinite::Past->new;
- },
- );
-
-Bounded recurrences are easier to write using C<span> parameters. See above.
-
-See also C<DateTime::Event::Recurrence> and the other
-C<DateTime::Event::*> factory modules for generating specialized
-recurrences, such as sunrise and sunset times, and holidays.
-
-=item * empty_set
-
-Creates a new empty set.
-
- $set = DateTime::Set->empty_set;
- print "empty set" unless defined $set->max;
-
-=item * clone
-
-This object method returns a replica of the given object.
-
-C<clone> is useful if you want to apply a transformation to a set,
-but you want to keep the previous value:
-
- $set2 = $set1->clone;
- $set2->add_duration( year => 1 ); # $set1 is unaltered
-
-=item * add_duration( $duration )
-
-This method adds the specified duration to every element of the set.
-
- $dt_dur = new DateTime::Duration( year => 1 );
- $set->add_duration( $dt_dur );
-
-The original set is modified. If you want to keep the old values use:
-
- $new_set = $set->clone->add_duration( $dt_dur );
-
-=item * add
-
-This method is syntactic sugar around the C<add_duration()> method.
-
- $meetings_2004 = $meetings_2003->clone->add( years => 1 );
-
-=item * subtract_duration( $duration_object )
-
-When given a C<DateTime::Duration> object, this method simply calls
-C<invert()> on that object and passes that new duration to the
-C<add_duration> method.
-
-=item * subtract( DateTime::Duration->new parameters )
-
-Like C<add()>, this is syntactic sugar for the C<subtract_duration()>
-method.
-
-=item * set_time_zone( $tz )
-
-This method will attempt to apply the C<set_time_zone> method to every
-datetime in the set.
-
-=item * set( locale => .. )
-
-This method can be used to change the C<locale> of a datetime set.
-
-=item * min
-
-=item * max
-
-The first and last C<DateTime> in the set. These methods may return
-C<undef> if the set is empty. It is also possible that these methods
-may return a C<DateTime::Infinite::Past> or
-C<DateTime::Infinite::Future> object.
-
-These methods return just a I<copy> of the actual boundary value.
-If you modify the result, the set will not be modified.
-
-=item * span
-
-Returns the total span of the set, as a C<DateTime::Span> object.
-
-=item * iterator / next / previous
-
-These methods can be used to iterate over the datetimes in a set.
-
- $iter = $set1->iterator;
- while ( $dt = $iter->next ) {
- print $dt->ymd;
- }
-
- # iterate backwards
- $iter = $set1->iterator;
- while ( $dt = $iter->previous ) {
- print $dt->ymd;
- }
-
-The boundaries of the iterator can be limited by passing it a C<span>
-parameter. This should be a C<DateTime::Span> object which delimits
-the iterator's boundaries. Optionally, instead of passing an object,
-you can pass any parameters that would work for one of the
-C<DateTime::Span> class's constructors, and an object will be created
-for you.
-
-Obviously, if the span you specify is not restricted both at the start
-and end, then your iterator may iterate forever, depending on the
-nature of your set. User beware!
-
-The C<next()> or C<previous()> method will return C<undef> when there
-are no more datetimes in the iterator.
-
-=item * as_list
-
-Returns the set elements as a list of C<DateTime> objects. Just as
-with the C<iterator()> method, the C<as_list()> method can be limited
-by a span.
-
- my @dt = $set->as_list( span => $span );
-
-Applying C<as_list()> to a large recurrence set is a very expensive
-operation, both in CPU time and in the memory used. If you I<really>
-need to extract elements from a large set, you can limit the set with
-a shorter span:
-
- my @short_list = $large_set->as_list( span => $short_span );
-
-For I<infinite> sets, C<as_list()> will return C<undef>. Please note
-that this is explicitly not an empty list, since an empty list is a
-valid return value for empty sets!
-
-=item * count
-
-Returns a count of C<DateTime> objects in the set. Just as with the
-C<iterator()> method, the C<count()> method can be limited by a span.
-
- defined( my $n = $set->count) or die "can't count";
-
- my $n = $set->count( span => $span );
- die "can't count" unless defined $n;
-
-Applying C<count()> to a large recurrence set is a very expensive
-operation, both in CPU time and in the memory used. If you I<really>
-need to count elements from a large set, you can limit the set with a
-shorter span:
-
- my $count = $large_set->count( span => $short_span );
-
-For I<infinite> sets, C<count()> will return C<undef>. Please note
-that this is explicitly not a scalar zero, since a zero count is a
-valid return value for empty sets!
-
-=item * union
-
-=item * intersection
-
-=item * complement
-
-These set operation methods can accept a C<DateTime> list, a
-C<DateTime::Set>, a C<DateTime::Span>, or a C<DateTime::SpanSet>
-object as an argument.
-
- $set = $set1->union( $set2 ); # like "OR", "insert", "both"
- $set = $set1->complement( $set2 ); # like "delete", "remove"
- $set = $set1->intersection( $set2 ); # like "AND", "while"
- $set = $set1->complement; # like "NOT", "negate", "invert"
-
-The C<union> of a C<DateTime::Set> with a C<DateTime::Span> or a
-C<DateTime::SpanSet> object returns a C<DateTime::SpanSet> object.
-
-If C<complement> is called without any arguments, then the result is a
-C<DateTime::SpanSet> object representing the spans between each of the
-set's elements. If complement is given an argument, then the return
-value is a C<DateTime::Set> object representing the I<set difference>
-between the sets.
-
-All other operations will always return a C<DateTime::Set>.
-
-=item * intersects
-
-=item * contains
-
-These set operations result in a boolean value.
-
- if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
- if ( $set1->contains( $dt ) ) { ... # like "is-fully-inside"
-
-These methods can accept a C<DateTime> list, a C<DateTime::Set>, a
-C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
-
-=item * previous
-
-=item * next
-
-=item * current
-
-=item * closest
-
- my $dt = $set->next( $dt );
- my $dt = $set->previous( $dt );
- my $dt = $set->current( $dt );
- my $dt = $set->closest( $dt );
-
-These methods are used to find a set member relative to a given
-datetime.
-
-The C<current()> method returns C<$dt> if $dt is an event, otherwise
-it returns the previous event.
-
-The C<closest()> method returns C<$dt> if $dt is an event, otherwise
-it returns the closest event (previous or next).
-
-All of these methods may return C<undef> if there is no matching
-datetime in the set.
-
-These methods will try to set the returned value to the same time zone
-as the argument, unless the argument has a 'floating' time zone.
-
-=item * map ( sub { ... } )
-
- # example: remove the hour:minute:second information
- $set = $set2->map(
- sub {
- return $_->truncate( to => day );
- }
- );
-
- # example: postpone or antecipate events which
- # match datetimes within another set
- $set = $set2->map(
- sub {
- return $_->add( days => 1 ) while $holidays->contains( $_ );
- }
- );
-
-This method is the "set" version of Perl "map".
-
-It evaluates a subroutine for each element of the set (locally setting
-"$_" to each datetime) and returns the set composed of the results of
-each such evaluation.
-
-Like Perl "map", each element of the set may produce zero, one, or
-more elements in the returned value.
-
-Unlike Perl "map", changing "$_" does not change the original
-set. This means that calling map in void context has no effect.
-
-The callback subroutine may be called later in the program, due to
-lazy evaluation. So don't count on subroutine side-effects. For
-example, a C<print> inside the subroutine may happen later than you
-expect.
-
-The callback return value is expected to be within the span of the
-C<previous> and the C<next> element in the original set. This is a
-limitation of the backtracking algorithm used in the C<Set::Infinite>
-library.
-
-For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
-result for the value C<2010> is expected to be within the span C<[
-2001 .. 2015 ]>.
-
-=item * grep ( sub { ... } )
-
- # example: filter out any sundays
- $set = $set2->grep(
- sub {
- return ( $_->day_of_week != 7 );
- }
- );
-
-This method is the "set" version of Perl "grep".
-
-It evaluates a subroutine for each element of the set (locally setting
-"$_" to each datetime) and returns the set consisting of those
-elements for which the expression evaluated to true.
-
-Unlike Perl "grep", changing "$_" does not change the original
-set. This means that calling grep in void context has no effect.
-
-Changing "$_" does change the resulting set.
-
-The callback subroutine may be called later in the program, due to
-lazy evaluation. So don't count on subroutine side-effects. For
-example, a C<print> inside the subroutine may happen later than you
-expect.
-
-=item * iterate ( sub { ... } )
-
-I<deprecated method - please use "map" or "grep" instead.>
-
-=back
-
-=head1 SUPPORT
-
-Support is offered through the C<datetime@perl.org> mailing list.
-
-Please report bugs using rt.cpan.org
-
-=head1 AUTHOR
-
-Flavio Soibelmann Glock <fglock@pucrs.br>
-
-The API was developed together with Dave Rolsky and the DateTime
-Community.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
-This program is free software; you can distribute it and/or modify it
-under the same terms as Perl itself.
-
-The full text of the license can be found in the LICENSE file included
-with this module.
-
-=head1 SEE ALSO
-
-Set::Infinite
-
-For details on the Perl DateTime Suite project please see
-L<http://datetime.perl.org>.
-
-=cut
-
+++ /dev/null
-# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package DateTime::Span;
-
-use strict;
-
-use DateTime::Set;
-use DateTime::SpanSet;
-
-use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
-use vars qw( $VERSION );
-
-use constant INFINITY => DateTime::INFINITY;
-use constant NEG_INFINITY => DateTime::NEG_INFINITY;
-$VERSION = $DateTime::Set::VERSION;
-
-sub set_time_zone {
- my ( $self, $tz ) = @_;
-
- $self->{set} = $self->{set}->iterate(
- sub {
- my %tmp = %{ $_[0]->{list}[0] };
- $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
- $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
- \%tmp;
- }
- );
- return $self;
-}
-
-# note: the constructor must clone its DateTime parameters, such that
-# the set elements become immutable
-sub from_datetimes {
- my $class = shift;
- my %args = validate( @_,
- { start =>
- { type => OBJECT,
- optional => 1,
- },
- end =>
- { type => OBJECT,
- optional => 1,
- },
- after =>
- { type => OBJECT,
- optional => 1,
- },
- before =>
- { type => OBJECT,
- optional => 1,
- },
- }
- );
- my $self = {};
- my $set;
-
- die "No arguments given to DateTime::Span->from_datetimes\n"
- unless keys %args;
-
- if ( exists $args{start} && exists $args{after} ) {
- die "Cannot give both start and after arguments to DateTime::Span->from_datetimes\n";
- }
- if ( exists $args{end} && exists $args{before} ) {
- die "Cannot give both end and before arguments to DateTime::Span->from_datetimes\n";
- }
-
- my ( $start, $open_start, $end, $open_end );
- ( $start, $open_start ) = ( NEG_INFINITY, 0 );
- ( $start, $open_start ) = ( $args{start}, 0 ) if exists $args{start};
- ( $start, $open_start ) = ( $args{after}, 1 ) if exists $args{after};
- ( $end, $open_end ) = ( INFINITY, 0 );
- ( $end, $open_end ) = ( $args{end}, 0 ) if exists $args{end};
- ( $end, $open_end ) = ( $args{before}, 1 ) if exists $args{before};
-
- if ( $start > $end ) {
- die "Span cannot start after the end in DateTime::Span->from_datetimes\n";
- }
- $set = Set::Infinite::_recurrence->new( $start, $end );
- if ( $start != $end ) {
- # remove start, such that we have ">" instead of ">="
- $set = $set->complement( $start ) if $open_start;
- # remove end, such that we have "<" instead of "<="
- $set = $set->complement( $end ) if $open_end;
- }
-
- $self->{set} = $set;
- bless $self, $class;
- return $self;
-}
-
-sub from_datetime_and_duration {
- my $class = shift;
- my %args = @_;
-
- my $key;
- my $dt;
- # extract datetime parameters
- for ( qw( start end before after ) ) {
- if ( exists $args{$_} ) {
- $key = $_;
- $dt = delete $args{$_};
- }
- }
-
- # extract duration parameters
- my $dt_duration;
- if ( exists $args{duration} ) {
- $dt_duration = $args{duration};
- }
- else {
- $dt_duration = DateTime::Duration->new( %args );
- }
- # warn "Creating span from $key => ".$dt->datetime." and $dt_duration";
- my $other_date = $dt->clone->add_duration( $dt_duration );
- # warn "Creating span from $key => ".$dt->datetime." and ".$other_date->datetime;
- my $other_key;
- if ( $dt_duration->is_positive ) {
- # check if have to invert keys
- $key = 'after' if $key eq 'end';
- $key = 'start' if $key eq 'before';
- $other_key = 'before';
- }
- else {
- # check if have to invert keys
- $other_key = 'end' if $key eq 'after';
- $other_key = 'before' if $key eq 'start';
- $key = 'start';
- }
- return $class->new( $key => $dt, $other_key => $other_date );
-}
-
-# This method is intentionally not documented. It's really only for
-# use by ::Set and ::SpanSet's as_list() and iterator() methods.
-sub new {
- my $class = shift;
- my %args = @_;
-
- # If we find anything _not_ appropriate for from_datetimes, we
- # assume it must be for durations, and call this constructor.
- # This way, we don't need to hardcode the DateTime::Duration
- # parameters.
- foreach ( keys %args )
- {
- return $class->from_datetime_and_duration(%args)
- unless /^(?:before|after|start|end)$/;
- }
-
- return $class->from_datetimes(%args);
-}
-
-sub clone {
- bless {
- set => $_[0]->{set}->copy,
- }, ref $_[0];
-}
-
-# Set::Infinite methods
-
-sub intersection {
- my ($set1, $set2) = @_;
- my $class = ref($set1);
- my $tmp = {}; # $class->new();
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
-
- # intersection() can generate something more complex than a span.
- bless $tmp, 'DateTime::SpanSet';
-
- return $tmp;
-}
-
-sub intersects {
- my ($set1, $set2) = @_;
- my $class = ref($set1);
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
- unless $set2->can( 'union' );
- return $set1->{set}->intersects( $set2->{set} );
-}
-
-sub contains {
- my ($set1, $set2) = @_;
- my $class = ref($set1);
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
- unless $set2->can( 'union' );
- return $set1->{set}->contains( $set2->{set} );
-}
-
-sub union {
- my ($set1, $set2) = @_;
- my $class = ref($set1);
- my $tmp = {}; # $class->new();
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->union( $set2->{set} );
-
- # union() can generate something more complex than a span.
- bless $tmp, 'DateTime::SpanSet';
-
- # # We have to check it's internal structure to find out.
- # if ( $#{ $tmp->{set}->{list} } != 0 ) {
- # bless $tmp, 'Date::SpanSet';
- # }
-
- return $tmp;
-}
-
-sub complement {
- my ($set1, $set2) = @_;
- my $class = ref($set1);
- my $tmp = {}; # $class->new;
- if (defined $set2) {
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2 ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->complement( $set2->{set} );
- }
- else {
- $tmp->{set} = $set1->{set}->complement;
- }
-
- # complement() can generate something more complex than a span.
- bless $tmp, 'DateTime::SpanSet';
-
- # # We have to check it's internal structure to find out.
- # if ( $#{ $tmp->{set}->{list} } != 0 ) {
- # bless $tmp, 'Date::SpanSet';
- # }
-
- return $tmp;
-}
-
-sub start {
- return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
-}
-
-*min = \&start;
-
-sub end {
- return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
-}
-
-*max = \&end;
-
-sub start_is_open {
- # min_a returns info about the set boundary
- my ($min, $open) = $_[0]->{set}->min_a;
- return $open;
-}
-
-sub start_is_closed { $_[0]->start_is_open ? 0 : 1 }
-
-sub end_is_open {
- # max_a returns info about the set boundary
- my ($max, $open) = $_[0]->{set}->max_a;
- return $open;
-}
-
-sub end_is_closed { $_[0]->end_is_open ? 0 : 1 }
-
-
-# span == $self
-sub span { @_ }
-
-sub duration {
- my $dur;
-
- local $@;
- eval {
- local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
- $dur = $_[0]->end->subtract_datetime_absolute( $_[0]->start )
- };
-
- return $dur if defined $dur;
-
- return DateTime::Infinite::Future->new -
- DateTime::Infinite::Past->new;
-}
-*size = \&duration;
-
-1;
-
-__END__
-
-=head1 NAME
-
-DateTime::Span - Datetime spans
-
-=head1 SYNOPSIS
-
- use DateTime;
- use DateTime::Span;
-
- $date1 = DateTime->new( year => 2002, month => 3, day => 11 );
- $date2 = DateTime->new( year => 2003, month => 4, day => 12 );
- $set2 = DateTime::Span->from_datetimes( start => $date1, end => $date2 );
- # set2 = 2002-03-11 until 2003-04-12
-
- $set = $set1->union( $set2 ); # like "OR", "insert", "both"
- $set = $set1->complement( $set2 ); # like "delete", "remove"
- $set = $set1->intersection( $set2 ); # like "AND", "while"
- $set = $set1->complement; # like "NOT", "negate", "invert"
-
- if ( $set1->intersects( $set2 ) ) { ... # like "touches", "interferes"
- if ( $set1->contains( $set2 ) ) { ... # like "is-fully-inside"
-
- # data extraction
- $date = $set1->start; # first date of the span
- $date = $set1->end; # last date of the span
-
-=head1 DESCRIPTION
-
-C<DateTime::Span> is a module for handling datetime spans, otherwise
-known as ranges or periods ("from X to Y, inclusive of all datetimes
-in between").
-
-This is different from a C<DateTime::Set>, which is made of individual
-datetime points as opposed to a range. There is also a module
-C<DateTime::SpanSet> to handle sets of spans.
-
-=head1 METHODS
-
-=over 4
-
-=item * from_datetimes
-
-Creates a new span based on a starting and ending datetime.
-
-A 'closed' span includes its end-dates:
-
- $span = DateTime::Span->from_datetimes( start => $dt1, end => $dt2 );
-
-An 'open' span does not include its end-dates:
-
- $span = DateTime::Span->from_datetimes( after => $dt1, before => $dt2 );
-
-A 'semi-open' span includes one of its end-dates:
-
- $span = DateTime::Span->from_datetimes( start => $dt1, before => $dt2 );
- $span = DateTime::Span->from_datetimes( after => $dt1, end => $dt2 );
-
-A span might have just a beginning date, or just an ending date.
-These spans end, or start, in an imaginary 'forever' date:
-
- $span = DateTime::Span->from_datetimes( start => $dt1 );
- $span = DateTime::Span->from_datetimes( end => $dt2 );
- $span = DateTime::Span->from_datetimes( after => $dt1 );
- $span = DateTime::Span->from_datetimes( before => $dt2 );
-
-You cannot give both a "start" and "after" argument, nor can you give
-both an "end" and "before" argument. Either of these conditions will
-cause the C<from_datetimes()> method to die.
-
-To summarize, a datetime passed as either "start" or "end" is included
-in the span. A datetime passed as either "after" or "before" is
-excluded from the span.
-
-=item * from_datetime_and_duration
-
-Creates a new span.
-
- $span = DateTime::Span->from_datetime_and_duration(
- start => $dt1, duration => $dt_dur1 );
- $span = DateTime::Span->from_datetime_and_duration(
- after => $dt1, hours => 12 );
-
-The new "end of the set" is I<open> by default.
-
-=item * clone
-
-This object method returns a replica of the given object.
-
-=item * set_time_zone( $tz )
-
-This method accepts either a time zone object or a string that can be
-passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
-If the new time zone's offset is different from the old time zone,
-then the I<local> time is adjusted accordingly.
-
-If the old time zone was a floating time zone, then no adjustments to
-the local time are made, except to account for leap seconds. If the
-new time zone is floating, then the I<UTC> time is adjusted in order
-to leave the local time untouched.
-
-=item * duration
-
-The total size of the set, as a C<DateTime::Duration> object, or as a
-scalar containing infinity.
-
-Also available as C<size()>.
-
-=item * start
-
-=item * end
-
-First or last dates in the span.
-
-It is possible that the return value from these methods may be a
-C<DateTime::Infinite::Future> or a C<DateTime::Infinite::Past>xs object.
-
-If the set ends C<before> a date C<$dt>, it returns C<$dt>. Note that
-in this case C<$dt> is not a set element - but it is a set boundary.
-
-=cut
-
-# scalar containing either negative infinity
-# or positive infinity.
-
-=item * start_is_closed
-
-=item * end_is_closed
-
-Returns true if the first or last dates belong to the span ( begin <= x <= end ).
-
-=item * start_is_open
-
-=item * end_is_open
-
-Returns true if the first or last dates are excluded from the span ( begin < x < end ).
-
-=item * union
-
-=item * intersection
-
-=item * complement
-
-Set operations may be performed not only with C<DateTime::Span>
-objects, but also with C<DateTime::Set> and C<DateTime::SpanSet>
-objects. These set operations always return a C<DateTime::SpanSet>
-object.
-
- $set = $span->union( $set2 ); # like "OR", "insert", "both"
- $set = $span->complement( $set2 ); # like "delete", "remove"
- $set = $span->intersection( $set2 ); # like "AND", "while"
- $set = $span->complement; # like "NOT", "negate", "invert"
-
-=item * intersects
-
-=item * contains
-
-These set functions return a boolean value.
-
- if ( $span->intersects( $set2 ) ) { ... # like "touches", "interferes"
- if ( $span->contains( $dt ) ) { ... # like "is-fully-inside"
-
-These methods can accept a C<DateTime>, C<DateTime::Set>,
-C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
-
-=back
-
-=head1 SUPPORT
-
-Support is offered through the C<datetime@perl.org> mailing list.
-
-Please report bugs using rt.cpan.org
-
-=head1 AUTHOR
-
-Flavio Soibelmann Glock <fglock@pucrs.br>
-
-The API was developed together with Dave Rolsky and the DateTime Community.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003-2006 Flavio Soibelmann Glock. All rights reserved.
-This program is free software; you can distribute it and/or modify it
-under the same terms as Perl itself.
-
-The full text of the license can be found in the LICENSE file
-included with this module.
-
-=head1 SEE ALSO
-
-Set::Infinite
-
-For details on the Perl DateTime Suite project please see
-L<http://datetime.perl.org>.
-
-=cut
-
+++ /dev/null
-# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package DateTime::SpanSet;
-
-use strict;
-
-use DateTime::Set;
-use DateTime::Infinite;
-
-use Carp;
-use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF ARRAYREF );
-use vars qw( $VERSION );
-
-use constant INFINITY => 100 ** 100 ** 100 ;
-use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
-$VERSION = $DateTime::Set::VERSION;
-
-sub iterate {
- my ( $self, $callback ) = @_;
- my $class = ref( $self );
- my $return = $class->empty_set;
- $return->{set} = $self->{set}->iterate(
- sub {
- my $span = bless { set => $_[0] }, 'DateTime::Span';
- $callback->( $span->clone );
- $span = $span->{set}
- if UNIVERSAL::can( $span, 'union' );
- return $span;
- }
- );
- $return;
-}
-
-sub map {
- my ( $self, $callback ) = @_;
- my $class = ref( $self );
- die "The callback parameter to map() must be a subroutine reference"
- unless ref( $callback ) eq 'CODE';
- my $return = $class->empty_set;
- $return->{set} = $self->{set}->iterate(
- sub {
- local $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
- my @list = $callback->();
- my $set = $class->empty_set;
- $set = $set->union( $_ ) for @list;
- return $set->{set};
- }
- );
- $return;
-}
-
-sub grep {
- my ( $self, $callback ) = @_;
- my $class = ref( $self );
- die "The callback parameter to grep() must be a subroutine reference"
- unless ref( $callback ) eq 'CODE';
- my $return = $class->empty_set;
- $return->{set} = $self->{set}->iterate(
- sub {
- local $_ = bless { set => $_[0]->clone }, 'DateTime::Span';
- my $result = $callback->();
- return $_ if $result;
- return;
- }
- );
- $return;
-}
-
-sub set_time_zone {
- my ( $self, $tz ) = @_;
-
- # TODO - use iterate() instead
-
- my $result = $self->{set}->iterate(
- sub {
- my %tmp = %{ $_[0]->{list}[0] };
- $tmp{a} = $tmp{a}->clone->set_time_zone( $tz ) if ref $tmp{a};
- $tmp{b} = $tmp{b}->clone->set_time_zone( $tz ) if ref $tmp{b};
- \%tmp;
- },
- backtrack_callback => sub {
- my ( $min, $max ) = ( $_[0]->min, $_[0]->max );
- if ( ref($min) )
- {
- $min = $min->clone;
- $min->set_time_zone( 'floating' );
- }
- if ( ref($max) )
- {
- $max = $max->clone;
- $max->set_time_zone( 'floating' );
- }
- return Set::Infinite::_recurrence->new( $min, $max );
- },
- );
-
- ### this code enables 'subroutine method' behaviour
- $self->{set} = $result;
- return $self;
-}
-
-sub from_spans {
- my $class = shift;
- my %args = validate( @_,
- { spans =>
- { type => ARRAYREF,
- optional => 1,
- },
- }
- );
- my $self = {};
- my $set = Set::Infinite::_recurrence->new();
- $set = $set->union( $_->{set} ) for @{ $args{spans} };
- $self->{set} = $set;
- bless $self, $class;
- return $self;
-}
-
-sub from_set_and_duration {
- # set => $dt_set, days => 1
- my $class = shift;
- my %args = @_;
- my $set = delete $args{set} ||
- carp "from_set_and_duration needs a 'set' parameter";
-
- $set = $set->as_set
- if UNIVERSAL::can( $set, 'as_set' );
- unless ( UNIVERSAL::can( $set, 'union' ) ) {
- carp "'set' must be a set" };
-
- my $duration = delete $args{duration} ||
- new DateTime::Duration( %args );
- my $end_set = $set->clone->add_duration( $duration );
- return $class->from_sets( start_set => $set,
- end_set => $end_set );
-}
-
-sub from_sets {
- my $class = shift;
- my %args = validate( @_,
- { start_set =>
- { # can => 'union',
- optional => 0,
- },
- end_set =>
- { # can => 'union',
- optional => 0,
- },
- }
- );
- my $start_set = delete $args{start_set};
- my $end_set = delete $args{end_set};
-
- $start_set = $start_set->as_set
- if UNIVERSAL::can( $start_set, 'as_set' );
- $end_set = $end_set->as_set
- if UNIVERSAL::can( $end_set, 'as_set' );
-
- unless ( UNIVERSAL::can( $start_set, 'union' ) ) {
- carp "'start_set' must be a set" };
- unless ( UNIVERSAL::can( $end_set, 'union' ) ) {
- carp "'end_set' must be a set" };
-
- my $self;
- $self->{set} = $start_set->{set}->until(
- $end_set->{set} );
- bless $self, $class;
- return $self;
-}
-
-sub start_set {
- if ( exists $_[0]->{set}{method} &&
- $_[0]->{set}{method} eq 'until' )
- {
- return bless { set => $_[0]->{set}{parent}[0] }, 'DateTime::Set';
- }
- my $return = DateTime::Set->empty_set;
- $return->{set} = $_[0]->{set}->start_set;
- $return;
-}
-
-sub end_set {
- if ( exists $_[0]->{set}{method} &&
- $_[0]->{set}{method} eq 'until' )
- {
- return bless { set => $_[0]->{set}{parent}[1] }, 'DateTime::Set';
- }
- my $return = DateTime::Set->empty_set;
- $return->{set} = $_[0]->{set}->end_set;
- $return;
-}
-
-sub empty_set {
- my $class = shift;
-
- return bless { set => Set::Infinite::_recurrence->new }, $class;
-}
-
-sub clone {
- bless {
- set => $_[0]->{set}->copy,
- }, ref $_[0];
-}
-
-
-sub iterator {
- my $self = shift;
-
- my %args = @_;
- my $span;
- $span = delete $args{span};
- $span = DateTime::Span->new( %args ) if %args;
-
- return $self->intersection( $span ) if $span;
- return $self->clone;
-}
-
-
-# next() gets the next element from an iterator()
-sub next {
- my ($self) = shift;
-
- # TODO: this is fixing an error from elsewhere
- # - find out what's going on! (with "sunset.pl")
- return undef unless ref $self->{set};
-
- if ( @_ )
- {
- my $max;
- $max = $_[0]->max if UNIVERSAL::can( $_[0], 'union' );
- $max = $_[0] if ! defined $max;
-
- return undef if ! ref( $max ) && $max == INFINITY;
-
- my $span = DateTime::Span->from_datetimes( start => $max );
- my $iterator = $self->intersection( $span );
- my $return = $iterator->next;
-
- return $return if ! defined $return;
- return $return if ! $return->intersects( $max );
-
- return $iterator->next;
- }
-
- my ($head, $tail) = $self->{set}->first;
- $self->{set} = $tail;
- return $head unless ref $head;
- my $return = {
- set => $head,
- };
- bless $return, 'DateTime::Span';
- return $return;
-}
-
-# previous() gets the last element from an iterator()
-sub previous {
- my ($self) = shift;
-
- return undef unless ref $self->{set};
-
- if ( @_ )
- {
- my $min;
- $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
- $min = $_[0] if ! defined $min;
-
- return undef if ! ref( $min ) && $min == INFINITY;
-
- my $span = DateTime::Span->from_datetimes( end => $min );
- my $iterator = $self->intersection( $span );
- my $return = $iterator->previous;
-
- return $return if ! defined $return;
- return $return if ! $return->intersects( $min );
-
- return $iterator->previous;
- }
-
- my ($head, $tail) = $self->{set}->last;
- $self->{set} = $tail;
- return $head unless ref $head;
- my $return = {
- set => $head,
- };
- bless $return, 'DateTime::Span';
- return $return;
-}
-
-# "current" means less-or-equal to a DateTime
-sub current {
- my $self = shift;
-
- my $previous;
- my $next;
- {
- my $min;
- $min = $_[0]->min if UNIVERSAL::can( $_[0], 'union' );
- $min = $_[0] if ! defined $min;
- return undef if ! ref( $min ) && $min == INFINITY;
- my $span = DateTime::Span->from_datetimes( end => $min );
- my $iterator = $self->intersection( $span );
- $previous = $iterator->previous;
- $span = DateTime::Span->from_datetimes( start => $min );
- $iterator = $self->intersection( $span );
- $next = $iterator->next;
- }
- return $previous unless defined $next;
-
- my $dt1 = defined $previous
- ? $next->union( $previous )
- : $next;
-
- my $return = $dt1->intersected_spans( $_[0] );
-
- $return = $previous
- if !defined $return->max;
-
- bless $return, 'DateTime::SpanSet'
- if defined $return;
- return $return;
-}
-
-sub closest {
- my $self = shift;
- my $dt = shift;
-
- my $dt1 = $self->current( $dt );
- my $dt2 = $self->next( $dt );
- bless $dt2, 'DateTime::SpanSet'
- if defined $dt2;
-
- return $dt2 unless defined $dt1;
- return $dt1 unless defined $dt2;
-
- $dt = DateTime::Set->from_datetimes( dates => [ $dt ] )
- unless UNIVERSAL::can( $dt, 'union' );
-
- return $dt1 if $dt1->contains( $dt );
-
- my $delta = $dt->min - $dt1->max;
- return $dt1 if ( $dt2->min - $delta ) >= $dt->max;
-
- return $dt2;
-}
-
-sub as_list {
- my $self = shift;
- return undef unless ref( $self->{set} );
-
- my %args = @_;
- my $span;
- $span = delete $args{span};
- $span = DateTime::Span->new( %args ) if %args;
-
- my $set = $self->clone;
- $set = $set->intersection( $span ) if $span;
-
- # Note: removing this line means we may end up in an infinite loop!
- return undef if $set->{set}->is_too_complex; # undef = no begin/end
-
- # return if $set->{set}->is_null; # nothing = empty
- my @result;
- # we should extract _copies_ of the set elements,
- # such that the user can't modify the set indirectly
-
- my $iter = $set->iterator;
- while ( my $dt = $iter->next )
- {
- push @result, $dt
- if ref( $dt ); # we don't want to return INFINITY value
- };
-
- return @result;
-}
-
-# Set::Infinite methods
-
-sub intersection {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->intersection( $set2->{set} );
- return $tmp;
-}
-
-sub intersected_spans {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->intersected_spans( $set2->{set} );
- return $tmp;
-}
-
-sub intersects {
- my ($set1, $set2) = ( shift, shift );
-
- unless ( $set2->can( 'union' ) )
- {
- for ( $set2, @_ )
- {
- return 1 if $set1->contains( $_ );
- }
- return 0;
- }
-
- my $class = ref($set1);
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- return $set1->{set}->intersects( $set2->{set} );
-}
-
-sub contains {
- my ($set1, $set2) = ( shift, shift );
-
- unless ( $set2->can( 'union' ) )
- {
- if ( exists $set1->{set}{method} &&
- $set1->{set}{method} eq 'until' )
- {
- my $start_set = $set1->start_set;
- my $end_set = $set1->end_set;
-
- for ( $set2, @_ )
- {
- my $start = $start_set->next( $set2 );
- my $end = $end_set->next( $set2 );
-
- goto ABORT unless defined $start && defined $end;
-
- return 0 if $start < $end;
- }
- return 1;
-
- ABORT: ;
- # don't know
- }
- }
-
- my $class = ref($set1);
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- return $set1->{set}->contains( $set2->{set} );
-}
-
-sub union {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->union( $set2->{set} );
- return $tmp;
-}
-
-sub complement {
- my ($set1, $set2) = ( shift, shift );
- my $class = ref($set1);
- my $tmp = $class->empty_set();
- if (defined $set2) {
- $set2 = $set2->as_spanset
- if $set2->can( 'as_spanset' );
- $set2 = $set2->as_set
- if $set2->can( 'as_set' );
- $set2 = DateTime::Set->from_datetimes( dates => [ $set2, @_ ] )
- unless $set2->can( 'union' );
- $tmp->{set} = $set1->{set}->complement( $set2->{set} );
- }
- else {
- $tmp->{set} = $set1->{set}->complement;
- }
- return $tmp;
-}
-
-sub min {
- return DateTime::Set::_fix_datetime( $_[0]->{set}->min );
-}
-
-sub max {
- return DateTime::Set::_fix_datetime( $_[0]->{set}->max );
-}
-
-# returns a DateTime::Span
-sub span {
- my $set = $_[0]->{set}->span;
- my $self = bless { set => $set }, 'DateTime::Span';
- return $self;
-}
-
-# returns a DateTime::Duration
-sub duration {
- my $dur;
-
- return DateTime::Duration->new( seconds => 0 )
- if $_[0]->{set}->is_empty;
-
- local $@;
- eval {
- local $SIG{__DIE__}; # don't want to trap this (rt ticket 5434)
- $dur = $_[0]->{set}->size
- };
-
- return $dur if defined $dur && ref( $dur );
- return DateTime::Infinite::Future->new -
- DateTime::Infinite::Past->new;
- # return INFINITY;
-}
-*size = \&duration;
-
-1;
-
-__END__
-
-=head1 NAME
-
-DateTime::SpanSet - set of DateTime spans
-
-=head1 SYNOPSIS
-
- $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span, $dt_span ] );
-
- $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
- $set = $spanset->complement( $set2 ); # like "delete", "remove"
- $set = $spanset->intersection( $set2 ); # like "AND", "while"
- $set = $spanset->complement; # like "NOT", "negate", "invert"
-
- if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
- if ( $spanset->contains( $set2 ) ) { ... # like "is-fully-inside"
-
- # data extraction
- $date = $spanset->min; # first date of the set
- $date = $spanset->max; # last date of the set
-
- $iter = $spanset->iterator;
- while ( $dt = $iter->next ) {
- # $dt is a DateTime::Span
- print $dt->start->ymd; # first date of span
- print $dt->end->ymd; # last date of span
- };
-
-=head1 DESCRIPTION
-
-C<DateTime::SpanSet> is a class that represents sets of datetime
-spans. An example would be a recurring meeting that occurs from
-13:00-15:00 every Friday.
-
-This is different from a C<DateTime::Set>, which is made of individual
-datetime points as opposed to ranges.
-
-=head1 METHODS
-
-=over 4
-
-=item * from_spans
-
-Creates a new span set from one or more C<DateTime::Span> objects.
-
- $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span ] );
-
-=item * from_set_and_duration
-
-Creates a new span set from one or more C<DateTime::Set> objects and a
-duration.
-
-The duration can be a C<DateTime::Duration> object, or the parameters
-to create a new C<DateTime::Duration> object, such as "days",
-"months", etc.
-
- $spanset =
- DateTime::SpanSet->from_set_and_duration
- ( set => $dt_set, days => 1 );
-
-=item * from_sets
-
-Creates a new span set from two C<DateTime::Set> objects.
-
-One set defines the I<starting dates>, and the other defines the I<end
-dates>.
-
- $spanset =
- DateTime::SpanSet->from_sets
- ( start_set => $dt_set1, end_set => $dt_set2 );
-
-The spans have the starting date C<closed>, and the end date C<open>,
-like in C<[$dt1, $dt2)>.
-
-If an end date comes without a starting date before it, then it
-defines a span like C<(-inf, $dt)>.
-
-If a starting date comes without an end date after it, then it defines
-a span like C<[$dt, inf)>.
-
-=item * empty_set
-
-Creates a new empty set.
-
-=item * clone
-
-This object method returns a replica of the given object.
-
-=item * set_time_zone( $tz )
-
-This method accepts either a time zone object or a string that can be
-passed as the "name" parameter to C<< DateTime::TimeZone->new() >>.
-If the new time zone's offset is different from the old time zone,
-then the I<local> time is adjusted accordingly.
-
-If the old time zone was a floating time zone, then no adjustments to
-the local time are made, except to account for leap seconds. If the
-new time zone is floating, then the I<UTC> time is adjusted in order
-to leave the local time untouched.
-
-=item * min
-
-=item * max
-
-First or last dates in the set. These methods may return C<undef> if
-the set is empty. It is also possible that these methods may return a
-scalar containing infinity or negative infinity.
-
-=item * duration
-
-The total size of the set, as a C<DateTime::Duration> object.
-
-The duration may be infinite.
-
-Also available as C<size()>.
-
-=item * span
-
-The total span of the set, as a C<DateTime::Span> object.
-
-=item * next
-
- my $span = $set->next( $dt );
-
-This method is used to find the next span in the set,
-after a given datetime or span.
-
-The return value is a C<DateTime::Span>, or C<undef> if there is no matching
-span in the set.
-
-=item * previous
-
- my $span = $set->previous( $dt );
-
-This method is used to find the previous span in the set,
-before a given datetime or span.
-
-The return value is a C<DateTime::Span>, or C<undef> if there is no matching
-span in the set.
-
-
-=item * current
-
- my $span = $set->current( $dt );
-
-This method is used to find the "current" span in the set,
-that intersects a given datetime or span. If no current span
-is found, then the "previous" span is returned.
-
-The return value is a C<DateTime::SpanSet>, or C<undef> if there is no
-matching span in the set.
-
-If a span parameter is given, it may happen that "current" returns
-more than one span.
-
-See also: C<intersected_spans()> method.
-
-=item * closest
-
- my $span = $set->closest( $dt );
-
-This method is used to find the "closest" span in the set, given a
-datetime or span.
-
-The return value is a C<DateTime::SpanSet>, or C<undef> if the set is
-empty.
-
-If a span parameter is given, it may happen that "closest" returns
-more than one span.
-
-=item * as_list
-
-Returns a list of C<DateTime::Span> objects.
-
- my @dt_span = $set->as_list( span => $span );
-
-Just as with the C<iterator()> method, the C<as_list()> method can be
-limited by a span.
-
-Applying C<as_list()> to a large recurring spanset is a very expensive
-operation, both in CPU time and in the memory used.
-
-For this reason, when C<as_list()> operates on large recurrence sets,
-it will return at most approximately 200 spans. For larger sets, and
-for I<infinite> sets, C<as_list()> will return C<undef>.
-
-Please note that this is explicitly not an empty list, since an empty
-list is a valid return value for empty sets!
-
-If you I<really> need to extract spans from a large set, you can:
-
-- limit the set with a shorter span:
-
- my @short_list = $large_set->as_list( span => $short_span );
-
-- use an iterator:
-
- my @large_list;
- my $iter = $large_set->iterator;
- push @large_list, $dt while $dt = $iter->next;
-
-=item * union
-
-=item * intersection
-
-=item * complement
-
-Set operations may be performed not only with C<DateTime::SpanSet>
-objects, but also with C<DateTime>, C<DateTime::Set> and
-C<DateTime::Span> objects. These set operations always return a
-C<DateTime::SpanSet> object.
-
- $set = $spanset->union( $set2 ); # like "OR", "insert", "both"
- $set = $spanset->complement( $set2 ); # like "delete", "remove"
- $set = $spanset->intersection( $set2 ); # like "AND", "while"
- $set = $spanset->complement; # like "NOT", "negate", "invert"
-
-=item * intersected_spans
-
-This method can accept a C<DateTime> list, a C<DateTime::Set>, a
-C<DateTime::Span>, or a C<DateTime::SpanSet> object as an argument.
-
- $set = $set1->intersected_spans( $set2 );
-
-The method always returns a C<DateTime::SpanSet> object, containing
-all spans that are intersected by the given set.
-
-Unlike the C<intersection> method, the spans are not modified. See
-diagram below:
-
- set1 [....] [....] [....] [....]
- set2 [................]
-
- intersection [.] [....] [.]
-
- intersected_spans [....] [....] [....]
-
-=item * intersects
-
-=item * contains
-
-These set functions return a boolean value.
-
- if ( $spanset->intersects( $set2 ) ) { ... # like "touches", "interferes"
- if ( $spanset->contains( $dt ) ) { ... # like "is-fully-inside"
-
-These methods can accept a C<DateTime>, C<DateTime::Set>,
-C<DateTime::Span>, or C<DateTime::SpanSet> object as an argument.
-
-=item * iterator / next / previous
-
-This method can be used to iterate over the spans in a set.
-
- $iter = $spanset->iterator;
- while ( $dt = $iter->next ) {
- # $dt is a DateTime::Span
- print $dt->min->ymd; # first date of span
- print $dt->max->ymd; # last date of span
- }
-
-The boundaries of the iterator can be limited by passing it a C<span>
-parameter. This should be a C<DateTime::Span> object which delimits
-the iterator's boundaries. Optionally, instead of passing an object,
-you can pass any parameters that would work for one of the
-C<DateTime::Span> class's constructors, and an object will be created
-for you.
-
-Obviously, if the span you specify does is not restricted both at the
-start and end, then your iterator may iterate forever, depending on
-the nature of your set. User beware!
-
-The C<next()> or C<previous()> methods will return C<undef> when there
-are no more spans in the iterator.
-
-=item * start_set
-
-=item * end_set
-
-These methods do the inverse of the C<from_sets> method:
-
-C<start_set> retrieves a DateTime::Set with the start datetime of each
-span.
-
-C<end_set> retrieves a DateTime::Set with the end datetime of each
-span.
-
-=item * map ( sub { ... } )
-
- # example: enlarge the spans
- $set = $set2->map(
- sub {
- my $start = $_->start;
- my $end = $_->end;
- return DateTime::Span->from_datetimes(
- start => $start,
- before => $end,
- );
- }
- );
-
-This method is the "set" version of Perl "map".
-
-It evaluates a subroutine for each element of the set (locally setting
-"$_" to each DateTime::Span) and returns the set composed of the
-results of each such evaluation.
-
-Like Perl "map", each element of the set may produce zero, one, or
-more elements in the returned value.
-
-Unlike Perl "map", changing "$_" does not change the original
-set. This means that calling map in void context has no effect.
-
-The callback subroutine may not be called immediately. Don't count on
-subroutine side-effects. For example, a C<print> inside the subroutine
-may happen later than you expect.
-
-The callback return value is expected to be within the span of the
-C<previous> and the C<next> element in the original set.
-
-For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
-result for the value C<2010> is expected to be within the span C<[
-2001 .. 2015 ]>.
-
-=item * grep ( sub { ... } )
-
- # example: filter out all spans happening today
- my $today = DateTime->today;
- $set = $set2->grep(
- sub {
- return ( ! $_->contains( $today ) );
- }
- );
-
-This method is the "set" version of Perl "grep".
-
-It evaluates a subroutine for each element of the set (locally setting
-"$_" to each DateTime::Span) and returns the set consisting of those
-elements for which the expression evaluated to true.
-
-Unlike Perl "grep", changing "$_" does not change the original
-set. This means that calling grep in void context has no effect.
-
-Changing "$_" does change the resulting set.
-
-The callback subroutine may not be called immediately. Don't count on
-subroutine side-effects. For example, a C<print> inside the subroutine
-may happen later than you expect.
-
-=item * iterate
-
-I<Internal method - use "map" or "grep" instead.>
-
-This function apply a callback subroutine to all elements of a set and
-returns the resulting set.
-
-The parameter C<$_[0]> to the callback subroutine is a
-C<DateTime::Span> object.
-
-If the callback returns C<undef>, the datetime is removed from the
-set:
-
- sub remove_sundays {
- $_[0] unless $_[0]->start->day_of_week == 7;
- }
-
-The callback return value is expected to be within the span of the
-C<previous> and the C<next> element in the original set.
-
-For example: given the set C<[ 2001, 2010, 2015 ]>, the callback
-result for the value C<2010> is expected to be within the span C<[
-2001 .. 2015 ]>.
-
-The callback subroutine may not be called immediately. Don't count on
-subroutine side-effects. For example, a C<print> inside the subroutine
-may happen later than you expect.
-
-=back
-
-=head1 SUPPORT
-
-Support is offered through the C<datetime@perl.org> mailing list.
-
-Please report bugs using rt.cpan.org
-
-=head1 AUTHOR
-
-Flavio Soibelmann Glock <fglock@pucrs.br>
-
-The API was developed together with Dave Rolsky and the DateTime Community.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
-This program is free software; you can distribute it and/or
-modify it under the same terms as Perl itself.
-
-The full text of the license can be found in the LICENSE file
-included with this module.
-
-=head1 SEE ALSO
-
-Set::Infinite
-
-For details on the Perl DateTime Suite project please see
-L<http://datetime.perl.org>.
-
-=cut
-
+++ /dev/null
-package Email::Address;
-use strict;
-## no critic RequireUseWarnings
-# support pre-5.6
-
-use vars qw[$VERSION $COMMENT_NEST_LEVEL $STRINGIFY
- $COLLAPSE_SPACES
- %PARSE_CACHE %FORMAT_CACHE %NAME_CACHE
- $addr_spec $angle_addr $name_addr $mailbox];
-
-my $NOCACHE;
-
-$VERSION = '1.888';
-$COMMENT_NEST_LEVEL ||= 2;
-$STRINGIFY ||= 'format';
-$COLLAPSE_SPACES = 1 unless defined $COLLAPSE_SPACES; # who wants //=? me!
-
-=head1 NAME
-
-Email::Address - RFC 2822 Address Parsing and Creation
-
-=head1 SYNOPSIS
-
- use Email::Address;
-
- my @addresses = Email::Address->parse($line);
- my $address = Email::Address->new(Casey => 'casey@localhost');
-
- print $address->format;
-
-=head1 VERSION
-
-version 1.886
-
- $Id: /my/pep/Email-Address/trunk/lib/Email/Address.pm 31900 2007-06-23T01:25:34.344997Z rjbs $
-
-=head1 DESCRIPTION
-
-This class implements a regex-based RFC 2822 parser that locates email
-addresses in strings and returns a list of C<Email::Address> objects found.
-Alternatley you may construct objects manually. The goal of this software is to
-be correct, and very very fast.
-
-=cut
-
-my $CTL = q{\x00-\x1F\x7F};
-my $special = q{()<>\\[\\]:;@\\\\,."};
-
-my $text = qr/[^\x0A\x0D]/;
-
-my $quoted_pair = qr/\\$text/;
-
-my $ctext = qr/(?>[^()\\]+)/;
-my ($ccontent, $comment) = (q{})x2;
-for (1 .. $COMMENT_NEST_LEVEL) {
- $ccontent = qr/$ctext|$quoted_pair|$comment/;
- $comment = qr/\s*\((?:\s*$ccontent)*\s*\)\s*/;
-}
-my $cfws = qr/$comment|\s+/;
-
-my $atext = qq/[^$CTL$special\\s]/;
-my $atom = qr/$cfws*$atext+$cfws*/;
-my $dot_atom_text = qr/$atext+(?:\.$atext+)*/;
-my $dot_atom = qr/$cfws*$dot_atom_text$cfws*/;
-
-my $qtext = qr/[^\\"]/;
-my $qcontent = qr/$qtext|$quoted_pair/;
-my $quoted_string = qr/$cfws*"$qcontent+"$cfws*/;
-
-my $word = qr/$atom|$quoted_string/;
-
-# XXX: This ($phrase) used to just be: my $phrase = qr/$word+/; It was changed
-# to resolve bug 22991, creating a significant slowdown. Given current speed
-# problems. Once 16320 is resolved, this section should be dealt with.
-# -- rjbs, 2006-11-11
-#my $obs_phrase = qr/$word(?:$word|\.|$cfws)*/;
-
-# XXX: ...and the above solution caused endless problems (never returned) when
-# examining this address, now in a test:
-# admin+=E6=96=B0=E5=8A=A0=E5=9D=A1_Weblog-- ATAT --test.socialtext.com
-# So we disallow the hateful CFWS in this context for now. Of modern mail
-# agents, only Apple Web Mail 2.0 is known to produce obs-phrase.
-# -- rjbs, 2006-11-19
-my $simple_word = qr/$atom|\.|\s*"$qcontent+"\s*/;
-my $obs_phrase = qr/$simple_word+/;
-
-my $phrase = qr/$obs_phrase|(?:$word+)/;
-
-my $local_part = qr/$dot_atom|$quoted_string/;
-my $dtext = qr/[^\[\]\\]/;
-my $dcontent = qr/$dtext|$quoted_pair/;
-my $domain_literal = qr/$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*/;
-my $domain = qr/$dot_atom|$domain_literal/;
-
-my $display_name = $phrase;
-
-=head2 Package Variables
-
-Several regular expressions used in this package are useful to others.
-For convenience, these variables are declared as package variables that
-you may access from your program.
-
-These regular expressions conform to the rules specified in RFC 2822.
-
-You can access these variables using the full namespace. If you want
-short names, define them yourself.
-
- my $addr_spec = $Email::Address::addr_spec;
-
-=over 4
-
-=item $Email::Address::addr_spec
-
-This regular expression defined what an email address is allowed to
-look like.
-
-=item $Email::Address::angle_addr
-
-This regular expression defines an C<$addr_spec> wrapped in angle
-brackets.
-
-=item $Email::Address::name_addr
-
-This regular expression defines what an email address can look like
-with an optional preceeding display name, also known as the C<phrase>.
-
-=item $Email::Address::mailbox
-
-This is the complete regular expression defining an RFC 2822 emial
-address with an optional preceeding display name and optional
-following comment.
-
-=back
-
-=cut
-
-$addr_spec = qr/$local_part\@$domain/;
-$angle_addr = qr/$cfws*<$addr_spec>$cfws*/;
-$name_addr = qr/$display_name?$angle_addr/;
-$mailbox = qr/(?:$name_addr|$addr_spec)$comment*/;
-
-sub _PHRASE () { 0 }
-sub _ADDRESS () { 1 }
-sub _COMMENT () { 2 }
-sub _ORIGINAL () { 3 }
-sub _IN_CACHE () { 4 }
-
-=head2 Class Methods
-
-=over 4
-
-=item parse
-
- my @addrs = Email::Address->parse(
- q[me@local, Casey <me@local>, "Casey" <me@local> (West)]
- );
-
-This method returns a list of C<Email::Address> objects it finds
-in the input string.
-
-The specification for an email address allows for infinitley
-nestable comments. That's nice in theory, but a little over done.
-By default this module allows for two (C<2>) levels of nested
-comments. If you think you need more, modify the
-C<$Email::Address::COMMENT_NEST_LEVEL> package variable to allow
-more.
-
- $Email::Address::COMMENT_NEST_LEVEL = 10; # I'm deep
-
-The reason for this hardly limiting limitation is simple: efficiency.
-
-Long strings of whitespace can be problematic for this module to parse, a bug
-which has not yet been adequately addressed. The default behavior is now to
-collapse multiple spaces into a single space, which avoids this problem. To
-prevent this behavior, set C<$Email::Address::COLLAPSE_SPACES> to zero. This
-variable will go away when the bug is resolved properly.
-
-=cut
-
-sub __get_cached_parse {
- return if $NOCACHE;
-
- my ($class, $line) = @_;
-
- return @{$PARSE_CACHE{$line}} if exists $PARSE_CACHE{$line};
- return;
-}
-
-sub __cache_parse {
- return if $NOCACHE;
-
- my ($class, $line, $addrs) = @_;
-
- $PARSE_CACHE{$line} = $addrs;
-}
-
-sub parse {
- my ($class, $line) = @_;
- return unless $line;
-
- $line =~ s/[ \t]+/ /g if $COLLAPSE_SPACES;
-
- if (my @cached = $class->__get_cached_parse($line)) {
- return @cached;
- }
-
- my (@mailboxes) = ($line =~ /$mailbox/go);
- my @addrs;
- foreach (@mailboxes) {
- my $original = $_;
-
- my @comments = /($comment)/go;
- s/$comment//go if @comments;
-
- my ($user, $host, $com);
- ($user, $host) = ($1, $2) if s/<($local_part)\@($domain)>//o;
- if (! defined($user) || ! defined($host)) {
- s/($local_part)\@($domain)//o;
- ($user, $host) = ($1, $2);
- }
-
- my ($phrase) = /($display_name)/o;
-
- for ( $phrase, $host, $user, @comments ) {
- next unless defined $_;
- s/^\s+//;
- s/\s+$//;
- $_ = undef unless length $_;
- }
-
- my $new_comment = join q{ }, @comments;
- push @addrs,
- $class->new($phrase, "$user\@$host", $new_comment, $original);
- $addrs[-1]->[_IN_CACHE] = [ \$line, $#addrs ]
- }
-
- $class->__cache_parse($line, \@addrs);
- return @addrs;
-}
-
-=pod
-
-=item new
-
- my $address = Email::Address->new(undef, 'casey@local');
- my $address = Email::Address->new('Casey West', 'casey@local');
- my $address = Email::Address->new(undef, 'casey@local', '(Casey)');
-
-Constructs and returns a new C<Email::Address> object. Takes four
-positional arguments: phrase, email, and comment, and original string.
-
-The original string should only really be set using C<parse>.
-
-=cut
-
-sub new { bless [@_[1..4]], $_[0] }
-
-=pod
-
-=item purge_cache
-
- Email::Address->purge_cache;
-
-One way this module stays fast is with internal caches. Caches live
-in memory and there is the remote possibility that you will have a
-memory problem. In the off chance that you think you're one of those
-people, this class method will empty those caches.
-
-I've loaded over 12000 objects and not encountered a memory problem.
-
-=cut
-
-sub purge_cache {
- %NAME_CACHE = ();
- %FORMAT_CACHE = ();
- %PARSE_CACHE = ();
-}
-
-=item disable_cache
-
-=item enable_cache
-
- Email::Address->disable_cache if memory_low();
-
-If you'd rather not cache address parses at all, you can disable (and reenable) the Email::Address cache with these methods. The cache is enabled by default.
-
-=cut
-
-sub disable_cache {
- my ($class) = @_;
- $class->purge_cache;
- $NOCACHE = 1;
-}
-
-sub enable_cache {
- $NOCACHE = undef;
-}
-
-=pod
-
-=back
-
-=head2 Instance Methods
-
-=over 4
-
-=item phrase
-
- my $phrase = $address->phrase;
- $address->phrase( "Me oh my" );
-
-Accessor and mutator for the phrase portion of an address.
-
-=item address
-
- my $addr = $address->address;
- $addr->address( "me@PROTECTED.com" );
-
-Accessor and mutator for the address portion of an address.
-
-=item comment
-
- my $comment = $address->comment;
- $address->comment( "(Work address)" );
-
-Accessor and mutator for the comment portion of an address.
-
-=item original
-
- my $orig = $address->original;
-
-Accessor for the original address found when parsing, or passed
-to C<new>.
-
-=item host
-
- my $host = $address->host;
-
-Accessor for the host portion of an address's address.
-
-=item user
-
- my $user = $address->user;
-
-Accessor for the user portion of an address's address.
-
-=cut
-
-BEGIN {
- my %_INDEX = (
- phrase => _PHRASE,
- address => _ADDRESS,
- comment => _COMMENT,
- original => _ORIGINAL,
- );
-
- for my $method (keys %_INDEX) {
- no strict 'refs';
- my $index = $_INDEX{ $method };
- *$method = sub {
- if ($_[1]) {
- if ($_[0][_IN_CACHE]) {
- my $replicant = bless [ @{$_[0]} ] => ref $_[0];
- $PARSE_CACHE{ ${ $_[0][_IN_CACHE][0] } }[ $_[0][_IN_CACHE][1] ]
- = $replicant;
- $_[0][_IN_CACHE] = undef;
- }
- $_[0]->[ $index ] = $_[1];
- } else {
- $_[0]->[ $index ];
- }
- };
- }
-}
-
-sub host { ($_[0]->[_ADDRESS] =~ /\@($domain)/o)[0] }
-sub user { ($_[0]->[_ADDRESS] =~ /($local_part)\@/o)[0] }
-
-=pod
-
-=item format
-
- my $printable = $address->format;
-
-Returns a properly formatted RFC 2822 address representing the
-object.
-
-=cut
-
-sub format {
- local $^W = 0; ## no critic
- return $FORMAT_CACHE{"@{$_[0]}"} if exists $FORMAT_CACHE{"@{$_[0]}"};
- $FORMAT_CACHE{"@{$_[0]}"} = $_[0]->_format;
-}
-
-sub _format {
- my ($self) = @_;
-
- unless (
- defined $self->[_PHRASE] && length $self->[_PHRASE]
- ||
- defined $self->[_COMMENT] && length $self->[_COMMENT]
- ) {
- return $self->[_ADDRESS];
- }
-
- my $format = sprintf q{%s <%s> %s},
- $self->_enquoted_phrase, $self->[_ADDRESS], $self->[_COMMENT];
-
- $format =~ s/^\s+//;
- $format =~ s/\s+$//;
-
- return $format;
-}
-
-sub _enquoted_phrase {
- my ($self) = @_;
-
- my $phrase = $self->[_PHRASE];
-
- # if it's encoded -- rjbs, 2007-02-28
- return $phrase if $phrase =~ /\A=\?.+\?=\z/;
-
- $phrase =~ s/\A"(.+)"\z/$1/;
- $phrase =~ s/\"/\\"/g;
-
- return qq{"$phrase"};
-}
-
-=pod
-
-=item name
-
- my $name = $address->name;
-
-This method tries very hard to determine the name belonging to the address.
-First the C<phrase> is checked. If that doesn't work out the C<comment>
-is looked into. If that still doesn't work out, the C<user> portion of
-the C<address> is returned.
-
-This method does B<not> try to massage any name it identifies and instead
-leaves that up to someone else. Who is it to decide if someone wants their
-name capitalized, or if they're Irish?
-
-=cut
-
-sub name {
- local $^W = 0;
- return $NAME_CACHE{"@{$_[0]}"} if exists $NAME_CACHE{"@{$_[0]}"};
- my ($self) = @_;
- my $name = q{};
- if ( $name = $self->[_PHRASE] ) {
- $name =~ s/^"//;
- $name =~ s/"$//;
- $name =~ s/($quoted_pair)/substr $1, -1/goe;
- } elsif ( $name = $self->[_COMMENT] ) {
- $name =~ s/^\(//;
- $name =~ s/\)$//;
- $name =~ s/($quoted_pair)/substr $1, -1/goe;
- $name =~ s/$comment/ /go;
- } else {
- ($name) = $self->[_ADDRESS] =~ /($local_part)\@/o;
- }
- $NAME_CACHE{"@{$_[0]}"} = $name;
-}
-
-=pod
-
-=back
-
-=head2 Overloaded Operators
-
-=over 4
-
-=item stringify
-
- print "I have your email address, $address.";
-
-Objects stringify to C<format> by default. It's possible that you don't
-like that idea. Okay, then, you can change it by modifying
-C<$Email:Address::STRINGIFY>. Please consider modifying this package
-variable using C<local>. You might step on someone else's toes if you
-don't.
-
- {
- local $Email::Address::STRINGIFY = 'address';
- print "I have your address, $address.";
- # geeknest.com
- }
- print "I have your address, $address.";
- # "Casey West" <casey@geeknest.com>
-
-=cut
-
-sub as_string {
- warn 'altering $Email::Address::STRINGIFY is deprecated; subclass instead'
- if $STRINGIFY ne 'format';
-
- $_[0]->can($STRINGIFY)->($_[0]);
-}
-
-use overload '""' => 'as_string';
-
-=pod
-
-=back
-
-=cut
-
-1;
-
-__END__
-
-=head2 Did I Mention Fast?
-
-On his 1.8GHz Apple MacBook, rjbs gets these results:
-
- $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 5
- Rate Mail::Address Email::Address
- Mail::Address 2.59/s -- -44%
- Email::Address 4.59/s 77% --
-
- $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 25
- Rate Mail::Address Email::Address
- Mail::Address 2.58/s -- -67%
- Email::Address 7.84/s 204% --
-
- $ perl -Ilib bench/ea-vs-ma.pl bench/corpus.txt 50
- Rate Mail::Address Email::Address
- Mail::Address 2.57/s -- -70%
- Email::Address 8.53/s 232% --
-
-...unfortunately, a known bug causes a loss of speed the string to parse has
-certain known characteristics, and disabling cache will also degrade
-performance.
-
-=head1 PERL EMAIL PROJECT
-
-This module is maintained by the Perl Email Project
-
-L<http://emailproject.perl.org/wiki/Email::Address>
-
-=head1 SEE ALSO
-
-L<Email::Simple>, L<perl>.
-
-=head1 AUTHOR
-
-Originally by Casey West, <F<casey@geeknest.com>>.
-
-Maintained, 2006-2007, Ricardo SIGNES <F<rjbs@cpan.org>>.
-
-=head1 ACKNOWLEDGEMENTS
-
-Thanks to Kevin Riggle and Tatsuhiko Miyagawa for tests for annoying phrase-quoting bugs!
-
-=head1 COPYRIGHT
-
-Copyright (c) 2004 Casey West. All rights reserved. This module is free
-software; you can redistribute it and/or modify it under the same terms as Perl
-itself.
-
-=cut
-
+++ /dev/null
-package List::MoreUtils;
-
-use 5.00503;
-use strict;
-use Exporter ();
-use DynaLoader ();
-
-use vars qw{ $VERSION @ISA @EXPORT_OK %EXPORT_TAGS };
-BEGIN {
- $VERSION = '0.30';
- @ISA = qw{ Exporter DynaLoader };
- @EXPORT_OK = qw{
- any all none notall true false
- firstidx first_index lastidx last_index
- insert_after insert_after_string
- apply indexes
- after after_incl before before_incl
- firstval first_value lastval last_value
- each_array each_arrayref
- pairwise natatime
- mesh zip uniq distinct
- minmax part
- };
- %EXPORT_TAGS = (
- all => \@EXPORT_OK,
- );
-
- # Load the XS at compile-time so that redefinition warnings will be
- # thrown correctly if the XS versions of part or indexes loaded
- eval {
- # PERL_DL_NONLAZY must be false, or any errors in loading will just
- # cause the perl code to be tested
- local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY};
-
- bootstrap List::MoreUtils $VERSION;
- 1;
-
- } unless $ENV{LIST_MOREUTILS_PP};
-}
-
-# Always use Perl apply() until memory leaks are resolved.
-sub apply (&@) {
- my $action = shift;
- &$action foreach my @values = @_;
- wantarray ? @values : $values[-1];
-}
-
-# Always use Perl part() until memory leaks are resolved.
-sub part (&@) {
- my ($code, @list) = @_;
- my @parts;
- push @{ $parts[ $code->($_) ] }, $_ foreach @list;
- return @parts;
-}
-
-# Always use Perl indexes() until memory leaks are resolved.
-sub indexes (&@) {
- my $test = shift;
- grep {
- local *_ = \$_[$_];
- $test->()
- } 0 .. $#_;
-}
-
-# Load the pure-Perl versions of the other functions if needed
-eval <<'END_PERL' unless defined &any;
-
-# Use pure scalar boolean return values for compatibility with XS
-use constant YES => ! 0;
-use constant NO => ! 1;
-
-sub any (&@) {
- my $f = shift;
- foreach ( @_ ) {
- return YES if $f->();
- }
- return NO;
-}
-
-sub all (&@) {
- my $f = shift;
- foreach ( @_ ) {
- return NO unless $f->();
- }
- return YES;
-}
-
-sub none (&@) {
- my $f = shift;
- foreach ( @_ ) {
- return NO if $f->();
- }
- return YES;
-}
-
-sub notall (&@) {
- my $f = shift;
- foreach ( @_ ) {
- return YES unless $f->();
- }
- return NO;
-}
-
-sub true (&@) {
- my $f = shift;
- my $count = 0;
- foreach ( @_ ) {
- $count++ if $f->();
- }
- return $count;
-}
-
-sub false (&@) {
- my $f = shift;
- my $count = 0;
- foreach ( @_ ) {
- $count++ unless $f->();
- }
- return $count;
-}
-
-sub firstidx (&@) {
- my $f = shift;
- foreach my $i ( 0 .. $#_ ) {
- local *_ = \$_[$i];
- return $i if $f->();
- }
- return -1;
-}
-
-sub lastidx (&@) {
- my $f = shift;
- foreach my $i ( reverse 0 .. $#_ ) {
- local *_ = \$_[$i];
- return $i if $f->();
- }
- return -1;
-}
-
-sub insert_after (&$\@) {
- my ($f, $val, $list) = @_;
- my $c = -1;
- local *_;
- foreach my $i ( 0 .. $#$list ) {
- $_ = $list->[$i];
- $c = $i, last if $f->();
- }
- @$list = (
- @{$list}[ 0 .. $c ],
- $val,
- @{$list}[ $c + 1 .. $#$list ],
- ) and return 1 if $c != -1;
- return 0;
-}
-
-sub insert_after_string ($$\@) {
- my ($string, $val, $list) = @_;
- my $c = -1;
- foreach my $i ( 0 .. $#$list ) {
- local $^W = 0;
- $c = $i, last if $string eq $list->[$i];
- }
- @$list = (
- @{$list}[ 0 .. $c ],
- $val,
- @{$list}[ $c + 1 .. $#$list ],
- ) and return 1 if $c != -1;
- return 0;
-}
-
-sub after (&@) {
- my $test = shift;
- my $started;
- my $lag;
- grep $started ||= do {
- my $x = $lag;
- $lag = $test->();
- $x
- }, @_;
-}
-
-sub after_incl (&@) {
- my $test = shift;
- my $started;
- grep $started ||= $test->(), @_;
-}
-
-sub before (&@) {
- my $test = shift;
- my $more = 1;
- grep $more &&= ! $test->(), @_;
-}
-
-sub before_incl (&@) {
- my $test = shift;
- my $more = 1;
- my $lag = 1;
- grep $more &&= do {
- my $x = $lag;
- $lag = ! $test->();
- $x
- }, @_;
-}
-
-sub lastval (&@) {
- my $test = shift;
- my $ix;
- for ( $ix = $#_; $ix >= 0; $ix-- ) {
- local *_ = \$_[$ix];
- my $testval = $test->();
-
- # Simulate $_ as alias
- $_[$ix] = $_;
- return $_ if $testval;
- }
- return undef;
-}
-
-sub firstval (&@) {
- my $test = shift;
- foreach ( @_ ) {
- return $_ if $test->();
- }
- return undef;
-}
-
-sub pairwise (&\@\@) {
- my $op = shift;
-
- # Symbols for caller's input arrays
- use vars qw{ @A @B };
- local ( *A, *B ) = @_;
-
- # Localise $a, $b
- my ( $caller_a, $caller_b ) = do {
- my $pkg = caller();
- no strict 'refs';
- \*{$pkg.'::a'}, \*{$pkg.'::b'};
- };
-
- # Loop iteration limit
- my $limit = $#A > $#B? $#A : $#B;
-
- # This map expression is also the return value
- local( *$caller_a, *$caller_b );
- map {
- # Assign to $a, $b as refs to caller's array elements
- ( *$caller_a, *$caller_b ) = \( $A[$_], $B[$_] );
-
- # Perform the transformation
- $op->();
- } 0 .. $limit;
-}
-
-sub each_array (\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
- return each_arrayref(@_);
-}
-
-sub each_arrayref {
- my @list = @_; # The list of references to the arrays
- my $index = 0; # Which one the caller will get next
- my $max = 0; # Number of elements in longest array
-
- # Get the length of the longest input array
- foreach ( @list ) {
- unless ( ref $_ eq 'ARRAY' ) {
- require Carp;
- Carp::croak("each_arrayref: argument is not an array reference\n");
- }
- $max = @$_ if @$_ > $max;
- }
-
- # Return the iterator as a closure wrt the above variables.
- return sub {
- if ( @_ ) {
- my $method = shift;
- unless ( $method eq 'index' ) {
- require Carp;
- Carp::croak("each_array: unknown argument '$method' passed to iterator.");
- }
-
- # Return current (last fetched) index
- return undef if $index == 0 || $index > $max;
- return $index - 1;
- }
-
- # No more elements to return
- return if $index >= $max;
- my $i = $index++;
-
- # Return ith elements
- return map $_->[$i], @list;
- }
-}
-
-sub natatime ($@) {
- my $n = shift;
- my @list = @_;
- return sub {
- return splice @list, 0, $n;
- }
-}
-
-sub mesh (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
- my $max = -1;
- $max < $#$_ && ( $max = $#$_ ) foreach @_;
- map {
- my $ix = $_;
- map $_->[$ix], @_;
- } 0 .. $max;
-}
-
-sub uniq (@) {
- my %seen = ();
- grep { not $seen{$_}++ } @_;
-}
-
-sub minmax (@) {
- return unless @_;
- my $min = my $max = $_[0];
-
- for ( my $i = 1; $i < @_; $i += 2 ) {
- if ( $_[$i-1] <= $_[$i] ) {
- $min = $_[$i-1] if $min > $_[$i-1];
- $max = $_[$i] if $max < $_[$i];
- } else {
- $min = $_[$i] if $min > $_[$i];
- $max = $_[$i-1] if $max < $_[$i-1];
- }
- }
-
- if ( @_ & 1 ) {
- my $i = $#_;
- if ($_[$i-1] <= $_[$i]) {
- $min = $_[$i-1] if $min > $_[$i-1];
- $max = $_[$i] if $max < $_[$i];
- } else {
- $min = $_[$i] if $min > $_[$i];
- $max = $_[$i-1] if $max < $_[$i-1];
- }
- }
-
- return ($min, $max);
-}
-
-sub _XScompiled {
- return 0;
-}
-
-END_PERL
-die $@ if $@;
-
-# Function aliases
-*first_index = \&firstidx;
-*last_index = \&lastidx;
-*first_value = \&firstval;
-*last_value = \&lastval;
-*zip = \&mesh;
-*distinct = \&uniq;
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-List::MoreUtils - Provide the stuff missing in List::Util
-
-=head1 SYNOPSIS
-
- use List::MoreUtils qw{
- any all none notall true false
- firstidx first_index lastidx last_index
- insert_after insert_after_string
- apply indexes
- after after_incl before before_incl
- firstval first_value lastval last_value
- each_array each_arrayref
- pairwise natatime
- mesh zip uniq distinct minmax part
- };
-
-=head1 DESCRIPTION
-
-B<List::MoreUtils> provides some trivial but commonly needed functionality on
-lists which is not going to go into L<List::Util>.
-
-All of the below functions are implementable in only a couple of lines of Perl
-code. Using the functions from this module however should give slightly better
-performance as everything is implemented in C. The pure-Perl implementation of
-these functions only serves as a fallback in case the C portions of this module
-couldn't be compiled on this machine.
-
-=over 4
-
-=item any BLOCK LIST
-
-Returns a true value if any item in LIST meets the criterion given through
-BLOCK. Sets C<$_> for each item in LIST in turn:
-
- print "At least one value undefined"
- if any { ! defined($_) } @list;
-
-Returns false otherwise, or if LIST is empty.
-
-=item all BLOCK LIST
-
-Returns a true value if all items in LIST meet the criterion given through
-BLOCK. Sets C<$_> for each item in LIST in turn:
-
- print "All items defined"
- if all { defined($_) } @list;
-
-Returns false otherwise, or if LIST is empty.
-
-=item none BLOCK LIST
-
-Logically the negation of C<any>. Returns a true value if no item in LIST meets
-the criterion given through BLOCK. Sets C<$_> for each item in LIST in turn:
-
- print "No value defined"
- if none { defined($_) } @list;
-
-Returns false otherwise, or if LIST is empty.
-
-=item notall BLOCK LIST
-
-Logically the negation of C<all>. Returns a true value if not all items in LIST
-meet the criterion given through BLOCK. Sets C<$_> for each item in LIST in
-turn:
-
- print "Not all values defined"
- if notall { defined($_) } @list;
-
-Returns false otherwise, or if LIST is empty.
-
-=item true BLOCK LIST
-
-Counts the number of elements in LIST for which the criterion in BLOCK is true.
-Sets C<$_> for each item in LIST in turn:
-
- printf "%i item(s) are defined", true { defined($_) } @list;
-
-=item false BLOCK LIST
-
-Counts the number of elements in LIST for which the criterion in BLOCK is false.
-Sets C<$_> for each item in LIST in turn:
-
- printf "%i item(s) are not defined", false { defined($_) } @list;
-
-=item firstidx BLOCK LIST
-
-=item first_index BLOCK LIST
-
-Returns the index of the first element in LIST for which the criterion in BLOCK
-is true. Sets C<$_> for each item in LIST in turn:
-
- my @list = (1, 4, 3, 2, 4, 6);
- printf "item with index %i in list is 4", firstidx { $_ == 4 } @list;
- __END__
- item with index 1 in list is 4
-
-Returns C<-1> if no such item could be found.
-
-C<first_index> is an alias for C<firstidx>.
-
-=item lastidx BLOCK LIST
-
-=item last_index BLOCK LIST
-
-Returns the index of the last element in LIST for which the criterion in BLOCK
-is true. Sets C<$_> for each item in LIST in turn:
-
- my @list = (1, 4, 3, 2, 4, 6);
- printf "item with index %i in list is 4", lastidx { $_ == 4 } @list;
- __END__
- item with index 4 in list is 4
-
-Returns C<-1> if no such item could be found.
-
-C<last_index> is an alias for C<lastidx>.
-
-=item insert_after BLOCK VALUE LIST
-
-Inserts VALUE after the first item in LIST for which the criterion in BLOCK is
-true. Sets C<$_> for each item in LIST in turn.
-
- my @list = qw/This is a list/;
- insert_after { $_ eq "a" } "longer" => @list;
- print "@list";
- __END__
- This is a longer list
-
-=item insert_after_string STRING VALUE LIST
-
-Inserts VALUE after the first item in LIST which is equal to STRING.
-
- my @list = qw/This is a list/;
- insert_after_string "a", "longer" => @list;
- print "@list";
- __END__
- This is a longer list
-
-=item apply BLOCK LIST
-
-Applies BLOCK to each item in LIST and returns a list of the values after BLOCK
-has been applied. In scalar context, the last element is returned. This
-function is similar to C<map> but will not modify the elements of the input
-list:
-
- my @list = (1 .. 4);
- my @mult = apply { $_ *= 2 } @list;
- print "\@list = @list\n";
- print "\@mult = @mult\n";
- __END__
- @list = 1 2 3 4
- @mult = 2 4 6 8
-
-Think of it as syntactic sugar for
-
- for (my @mult = @list) { $_ *= 2 }
-
-=item before BLOCK LIST
-
-Returns a list of values of LIST upto (and not including) the point where BLOCK
-returns a true value. Sets C<$_> for each element in LIST in turn.
-
-=item before_incl BLOCK LIST
-
-Same as C<before> but also includes the element for which BLOCK is true.
-
-=item after BLOCK LIST
-
-Returns a list of the values of LIST after (and not including) the point
-where BLOCK returns a true value. Sets C<$_> for each element in LIST in turn.
-
- @x = after { $_ % 5 == 0 } (1..9); # returns 6, 7, 8, 9
-
-=item after_incl BLOCK LIST
-
-Same as C<after> but also inclues the element for which BLOCK is true.
-
-=item indexes BLOCK LIST
-
-Evaluates BLOCK for each element in LIST (assigned to C<$_>) and returns a list
-of the indices of those elements for which BLOCK returned a true value. This is
-just like C<grep> only that it returns indices instead of values:
-
- @x = indexes { $_ % 2 == 0 } (1..10); # returns 1, 3, 5, 7, 9
-
-=item firstval BLOCK LIST
-
-=item first_value BLOCK LIST
-
-Returns the first element in LIST for which BLOCK evaluates to true. Each
-element of LIST is set to C<$_> in turn. Returns C<undef> if no such element
-has been found.
-
-C<first_val> is an alias for C<firstval>.
-
-=item lastval BLOCK LIST
-
-=item last_value BLOCK LIST
-
-Returns the last value in LIST for which BLOCK evaluates to true. Each element
-of LIST is set to C<$_> in turn. Returns C<undef> if no such element has been
-found.
-
-C<last_val> is an alias for C<lastval>.
-
-=item pairwise BLOCK ARRAY1 ARRAY2
-
-Evaluates BLOCK for each pair of elements in ARRAY1 and ARRAY2 and returns a
-new list consisting of BLOCK's return values. The two elements are set to C<$a>
-and C<$b>. Note that those two are aliases to the original value so changing
-them will modify the input arrays.
-
- @a = (1 .. 5);
- @b = (11 .. 15);
- @x = pairwise { $a + $b } @a, @b; # returns 12, 14, 16, 18, 20
-
- # mesh with pairwise
- @a = qw/a b c/;
- @b = qw/1 2 3/;
- @x = pairwise { ($a, $b) } @a, @b; # returns a, 1, b, 2, c, 3
-
-=item each_array ARRAY1 ARRAY2 ...
-
-Creates an array iterator to return the elements of the list of arrays ARRAY1,
-ARRAY2 throughout ARRAYn in turn. That is, the first time it is called, it
-returns the first element of each array. The next time, it returns the second
-elements. And so on, until all elements are exhausted.
-
-This is useful for looping over more than one array at once:
-
- my $ea = each_array(@a, @b, @c);
- while ( my ($a, $b, $c) = $ea->() ) { .... }
-
-The iterator returns the empty list when it reached the end of all arrays.
-
-If the iterator is passed an argument of 'C<index>', then it retuns
-the index of the last fetched set of values, as a scalar.
-
-=item each_arrayref LIST
-
-Like each_array, but the arguments are references to arrays, not the
-plain arrays.
-
-=item natatime BLOCK LIST
-
-Creates an array iterator, for looping over an array in chunks of
-C<$n> items at a time. (n at a time, get it?). An example is
-probably a better explanation than I could give in words.
-
-Example:
-
- my @x = ('a' .. 'g');
- my $it = natatime 3, @x;
- while (my @vals = $it->())
- {
- print "@vals\n";
- }
-
-This prints
-
- a b c
- d e f
- g
-
-=item mesh ARRAY1 ARRAY2 [ ARRAY3 ... ]
-
-=item zip ARRAY1 ARRAY2 [ ARRAY3 ... ]
-
-Returns a list consisting of the first elements of each array, then
-the second, then the third, etc, until all arrays are exhausted.
-
-Examples:
-
- @x = qw/a b c d/;
- @y = qw/1 2 3 4/;
- @z = mesh @x, @y; # returns a, 1, b, 2, c, 3, d, 4
-
- @a = ('x');
- @b = ('1', '2');
- @c = qw/zip zap zot/;
- @d = mesh @a, @b, @c; # x, 1, zip, undef, 2, zap, undef, undef, zot
-
-C<zip> is an alias for C<mesh>.
-
-=item uniq LIST
-
-=item distinct LIST
-
-Returns a new list by stripping duplicate values in LIST. The order of
-elements in the returned list is the same as in LIST. In scalar context,
-returns the number of unique elements in LIST.
-
- my @x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 1 2 3 5 4
- my $x = uniq 1, 1, 2, 2, 3, 5, 3, 4; # returns 5
-
-=item minmax LIST
-
-Calculates the minimum and maximum of LIST and returns a two element list with
-the first element being the minimum and the second the maximum. Returns the
-empty list if LIST was empty.
-
-The C<minmax> algorithm differs from a naive iteration over the list where each
-element is compared to two values being the so far calculated min and max value
-in that it only requires 3n/2 - 2 comparisons. Thus it is the most efficient
-possible algorithm.
-
-However, the Perl implementation of it has some overhead simply due to the fact
-that there are more lines of Perl code involved. Therefore, LIST needs to be
-fairly big in order for C<minmax> to win over a naive implementation. This
-limitation does not apply to the XS version.
-
-=item part BLOCK LIST
-
-Partitions LIST based on the return value of BLOCK which denotes into which
-partition the current value is put.
-
-Returns a list of the partitions thusly created. Each partition created is a
-reference to an array.
-
- my $i = 0;
- my @part = part { $i++ % 2 } 1 .. 8; # returns [1, 3, 5, 7], [2, 4, 6, 8]
-
-You can have a sparse list of partitions as well where non-set partitions will
-be undef:
-
- my @part = part { 2 } 1 .. 10; # returns undef, undef, [ 1 .. 10 ]
-
-Be careful with negative values, though:
-
- my @part = part { -1 } 1 .. 10;
- __END__
- Modification of non-creatable array value attempted, subscript -1 ...
-
-Negative values are only ok when they refer to a partition previously created:
-
- my @idx = ( 0, 1, -1 );
- my $i = 0;
- my @part = part { $idx[$++ % 3] } 1 .. 8; # [1, 4, 7], [2, 3, 5, 6, 8]
-
-=back
-
-=head1 EXPORTS
-
-Nothing by default. To import all of this module's symbols, do the conventional
-
- use List::MoreUtils ':all';
-
-It may make more sense though to only import the stuff your program actually
-needs:
-
- use List::MoreUtils qw{ any firstidx };
-
-=head1 ENVIRONMENT
-
-When C<LIST_MOREUTILS_PP> is set, the module will always use the pure-Perl
-implementation and not the XS one. This environment variable is really just
-there for the test-suite to force testing the Perl implementation, and possibly
-for reporting of bugs. I don't see any reason to use it in a production
-environment.
-
-=head1 BUGS
-
-There is a problem with a bug in 5.6.x perls. It is a syntax error to write
-things like:
-
- my @x = apply { s/foo/bar/ } qw{ foo bar baz };
-
-It has to be written as either
-
- my @x = apply { s/foo/bar/ } 'foo', 'bar', 'baz';
-
-or
-
- my @x = apply { s/foo/bar/ } my @dummy = qw/foo bar baz/;
-
-Perl 5.5.x and Perl 5.8.x don't suffer from this limitation.
-
-If you have a functionality that you could imagine being in this module, please
-drop me a line. This module's policy will be less strict than L<List::Util>'s
-when it comes to additions as it isn't a core module.
-
-When you report bugs, it would be nice if you could additionally give me the
-output of your program with the environment variable C<LIST_MOREUTILS_PP> set
-to a true value. That way I know where to look for the problem (in XS,
-pure-Perl or possibly both).
-
-=head1 SUPPORT
-
-Bugs should always be submitted via the CPAN bug tracker.
-
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=List-MoreUtils>
-
-=head1 THANKS
-
-Credits go to a number of people: Steve Purkis for giving me namespace advice
-and James Keenan and Terrence Branno for their effort of keeping the CPAN
-tidier by making L<List::Utils> obsolete.
-
-Brian McCauley suggested the inclusion of apply() and provided the pure-Perl
-implementation for it.
-
-Eric J. Roode asked me to add all functions from his module C<List::MoreUtil>
-into this one. With minor modifications, the pure-Perl implementations of those
-are by him.
-
-The bunch of people who almost immediately pointed out the many problems with
-the glitchy 0.07 release (Slaven Rezic, Ron Savage, CPAN testers).
-
-A particularly nasty memory leak was spotted by Thomas A. Lowery.
-
-Lars Thegler made me aware of problems with older Perl versions.
-
-Anno Siegel de-orphaned each_arrayref().
-
-David Filmer made me aware of a problem in each_arrayref that could ultimately
-lead to a segfault.
-
-Ricardo Signes suggested the inclusion of part() and provided the
-Perl-implementation.
-
-Robin Huston kindly fixed a bug in perl's MULTICALL API to make the
-XS-implementation of part() work.
-
-=head1 TODO
-
-A pile of requests from other people is still pending further processing in
-my mailbox. This includes:
-
-=over 4
-
-=item * List::Util export pass-through
-
-Allow B<List::MoreUtils> to pass-through the regular L<List::Util>
-functions to end users only need to C<use> the one module.
-
-=item * uniq_by(&@)
-
-Use code-reference to extract a key based on which the uniqueness is
-determined. Suggested by Aaron Crane.
-
-=item * delete_index
-
-=item * random_item
-
-=item * random_item_delete_index
-
-=item * list_diff_hash
-
-=item * list_diff_inboth
-
-=item * list_diff_infirst
-
-=item * list_diff_insecond
-
-These were all suggested by Dan Muey.
-
-=item * listify
-
-Always return a flat list when either a simple scalar value was passed or an
-array-reference. Suggested by Mark Summersault.
-
-=back
-
-=head1 SEE ALSO
-
-L<List::Util>
-
-=head1 AUTHOR
-
-Tassilo von Parseval E<lt>tassilo.von.parseval@rwth-aachen.deE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2004 - 2010 by Tassilo von Parseval
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself, either Perl version 5.8.4 or,
-at your option, any later version of Perl 5 you may have available.
-
-=cut
+++ /dev/null
-# You may distribute under the terms of either the GNU General Public License
-# or the Artistic License (the same terms as Perl itself)
-#
-# (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk
-
-package List::UtilsBy;
-
-use strict;
-use warnings;
-
-our $VERSION = '0.09';
-
-use Exporter 'import';
-
-our @EXPORT_OK = qw(
- sort_by
- nsort_by
- rev_sort_by
- rev_nsort_by
-
- max_by nmax_by
- min_by nmin_by
-
- uniq_by
-
- partition_by
- count_by
-
- zip_by
- unzip_by
-
- extract_by
-
- weighted_shuffle_by
-
- bundle_by
-);
-
-=head1 NAME
-
-C<List::UtilsBy> - higher-order list utility functions
-
-=head1 SYNOPSIS
-
- use List::UtilsBy qw( nsort_by min_by );
-
- use File::stat qw( stat );
- my @files_by_age = nsort_by { stat($_)->mtime } @files;
-
- my $shortest_name = min_by { length } @names;
-
-=head1 DESCRIPTION
-
-This module provides a number of list utility functions, all of which take an
-initial code block to control their behaviour. They are variations on similar
-core perl or C<List::Util> functions of similar names, but which use the block
-to control their behaviour. For example, the core Perl function C<sort> takes
-a list of values and returns them, sorted into order by their string value.
-The C<sort_by> function sorts them according to the string value returned by
-the extra function, when given each value.
-
- my @names_sorted = sort @names;
-
- my @people_sorted = sort_by { $_->name } @people;
-
-=cut
-
-=head1 FUNCTIONS
-
-=cut
-
-=head2 @vals = sort_by { KEYFUNC } @vals
-
-Returns the list of values sorted according to the string values returned by
-the C<KEYFUNC> block or function. A typical use of this may be to sort objects
-according to the string value of some accessor, such as
-
- sort_by { $_->name } @people
-
-The key function is called in scalar context, being passed each value in turn
-as both C<$_> and the only argument in the parameters, C<@_>. The values are
-then sorted according to string comparisons on the values returned.
-
-This is equivalent to
-
- sort { $a->name cmp $b->name } @people
-
-except that it guarantees the C<name> accessor will be executed only once per
-value.
-
-One interesting use-case is to sort strings which may have numbers embedded in
-them "naturally", rather than lexically.
-
- sort_by { s/(\d+)/sprintf "%09d", $1/eg; $_ } @strings
-
-This sorts strings by generating sort keys which zero-pad the embedded numbers
-to some level (9 digits in this case), helping to ensure the lexical sort puts
-them in the correct order.
-
-=cut
-
-sub sort_by(&@)
-{
- my $keygen = shift;
-
- my @keys = map { local $_ = $_; scalar $keygen->( $_ ) } @_;
- return @_[ sort { $keys[$a] cmp $keys[$b] } 0 .. $#_ ];
-}
-
-=head2 @vals = nsort_by { KEYFUNC } @vals
-
-Similar to C<sort_by> but compares its key values numerically.
-
-=cut
-
-sub nsort_by(&@)
-{
- my $keygen = shift;
-
- my @keys = map { local $_ = $_; scalar $keygen->( $_ ) } @_;
- return @_[ sort { $keys[$a] <=> $keys[$b] } 0 .. $#_ ];
-}
-
-=head2 @vals = rev_sort_by { KEYFUNC } @vals
-
-=head2 @vals = rev_nsort_by { KEYFUNC } @vals
-
-Similar to C<sort_by> and C<nsort_by> but returns the list in the reverse
-order. Equivalent to
-
- @vals = reverse sort_by { KEYFUNC } @vals
-
-except that these functions are slightly more efficient because they avoid
-the final C<reverse> operation.
-
-=cut
-
-sub rev_sort_by(&@)
-{
- my $keygen = shift;
-
- my @keys = map { local $_ = $_; scalar $keygen->( $_ ) } @_;
- return @_[ sort { $keys[$b] cmp $keys[$a] } 0 .. $#_ ];
-}
-
-sub rev_nsort_by(&@)
-{
- my $keygen = shift;
-
- my @keys = map { local $_ = $_; scalar $keygen->( $_ ) } @_;
- return @_[ sort { $keys[$b] <=> $keys[$a] } 0 .. $#_ ];
-}
-
-=head2 $optimal = max_by { KEYFUNC } @vals
-
-=head2 @optimal = max_by { KEYFUNC } @vals
-
-Returns the (first) value from C<@vals> that gives the numerically largest
-result from the key function.
-
- my $tallest = max_by { $_->height } @people
-
- use File::stat qw( stat );
- my $newest = max_by { stat($_)->mtime } @files;
-
-In scalar context, the first maximal value is returned. In list context, a
-list of all the maximal values is returned. This may be used to obtain
-positions other than the first, if order is significant.
-
-If called on an empty list, an empty list is returned.
-
-For symmetry with the C<nsort_by> function, this is also provided under the
-name C<nmax_by> since it behaves numerically.
-
-=cut
-
-sub max_by(&@)
-{
- my $code = shift;
-
- return unless @_;
-
- local $_;
-
- my @maximal = $_ = shift @_;
- my $max = $code->( $_ );
-
- foreach ( @_ ) {
- my $this = $code->( $_ );
- if( $this > $max ) {
- @maximal = $_;
- $max = $this;
- }
- elsif( wantarray and $this == $max ) {
- push @maximal, $_;
- }
- }
-
- return wantarray ? @maximal : $maximal[0];
-}
-
-*nmax_by = \&max_by;
-
-=head2 $optimal = min_by { KEYFUNC } @vals
-
-=head2 @optimal = min_by { KEYFUNC } @vals
-
-Similar to C<max_by> but returns values which give the numerically smallest
-result from the key function. Also provided as C<nmin_by>
-
-=cut
-
-sub min_by(&@)
-{
- my $code = shift;
-
- return unless @_;
-
- local $_;
-
- my @minimal = $_ = shift @_;
- my $min = $code->( $_ );
-
- foreach ( @_ ) {
- my $this = $code->( $_ );
- if( $this < $min ) {
- @minimal = $_;
- $min = $this;
- }
- elsif( wantarray and $this == $min ) {
- push @minimal, $_;
- }
- }
-
- return wantarray ? @minimal : $minimal[0];
-}
-
-*nmin_by = \&min_by;
-
-=head2 @vals = uniq_by { KEYFUNC } @vals
-
-Returns a list of the subset of values for which the key function block
-returns unique values. The first value yielding a particular key is chosen,
-subsequent values are rejected.
-
- my @some_fruit = uniq_by { $_->colour } @fruit;
-
-To select instead the last value per key, reverse the input list. If the order
-of the results is significant, don't forget to reverse the result as well:
-
- my @some_fruit = reverse uniq_by { $_->colour } reverse @fruit;
-
-=cut
-
-sub uniq_by(&@)
-{
- my $code = shift;
-
- my %present;
- return grep {
- my $key = $code->( local $_ = $_ );
- !$present{$key}++
- } @_;
-}
-
-=head2 %parts = partition_by { KEYFUNC } @vals
-
-Returns a key/value list of ARRAY refs containing all the original values
-distributed according to the result of the key function block. Each value will
-be an ARRAY ref containing all the values which returned the string from the
-key function, in their original order.
-
- my %balls_by_colour = partition_by { $_->colour } @balls;
-
-Because the values returned by the key function are used as hash keys, they
-ought to either be strings, or at least well-behaved as strings (such as
-numbers, or object references which overload stringification in a suitable
-manner).
-
-=cut
-
-sub partition_by(&@)
-{
- my $code = shift;
-
- my %parts;
- push @{ $parts{ $code->( local $_ = $_ ) } }, $_ for @_;
-
- return %parts;
-}
-
-=head2 %counts = count_by { KEYFUNC } @vals
-
-Returns a key/value list of integers, giving the number of times the key
-function block returned the key, for each value in the list.
-
- my %count_of_balls = count_by { $_->colour } @balls;
-
-Because the values returned by the key function are used as hash keys, they
-ought to either be strings, or at least well-behaved as strings (such as
-numbers, or object references which overload stringification in a suitable
-manner).
-
-=cut
-
-sub count_by(&@)
-{
- my $code = shift;
-
- my %counts;
- $counts{ $code->( local $_ = $_ ) }++ for @_;
-
- return %counts;
-}
-
-=head2 @vals = zip_by { ITEMFUNC } \@arr0, \@arr1, \@arr2,...
-
-Returns a list of each of the values returned by the function block, when
-invoked with values from across each each of the given ARRAY references. Each
-value in the returned list will be the result of the function having been
-invoked with arguments at that position, from across each of the arrays given.
-
- my @transposition = zip_by { [ @_ ] } @matrix;
-
- my @names = zip_by { "$_[1], $_[0]" } \@firstnames, \@surnames;
-
- print zip_by { "$_[0] => $_[1]\n" } [ keys %hash ], [ values %hash ];
-
-If some of the arrays are shorter than others, the function will behave as if
-they had C<undef> in the trailing positions. The following two lines are
-equivalent:
-
- zip_by { f(@_) } [ 1, 2, 3 ], [ "a", "b" ]
- f( 1, "a" ), f( 2, "b" ), f( 3, undef )
-
-The item function is called by C<map>, so if it returns a list, the entire
-list is included in the result. This can be useful for example, for generating
-a hash from two separate lists of keys and values
-
- my %nums = zip_by { @_ } [qw( one two three )], [ 1, 2, 3 ];
- # %nums = ( one => 1, two => 2, three => 3 )
-
-(A function having this behaviour is sometimes called C<zipWith>, e.g. in
-Haskell, but that name would not fit the naming scheme used by this module).
-
-=cut
-
-sub zip_by(&@)
-{
- my $code = shift;
-
- @_ or return;
-
- my $len = 0;
- scalar @$_ > $len and $len = scalar @$_ for @_;
-
- return map {
- my $idx = $_;
- $code->( map { $_[$_][$idx] } 0 .. $#_ )
- } 0 .. $len-1;
-}
-
-=head2 $arr0, $arr1, $arr2, ... = unzip_by { ITEMFUNC } @vals
-
-Returns a list of ARRAY references containing the values returned by the
-function block, when invoked for each of the values given in the input list.
-Each of the returned ARRAY references will contain the values returned at that
-corresponding position by the function block. That is, the first returned
-ARRAY reference will contain all the values returned in the first position by
-the function block, the second will contain all the values from the second
-position, and so on.
-
- my ( $firstnames, $lastnames ) = unzip_by { m/^(.*?) (.*)$/ } @names;
-
-If the function returns lists of differing lengths, the result will be padded
-with C<undef> in the missing elements.
-
-This function is an inverse of C<zip_by>, if given a corresponding inverse
-function.
-
-=cut
-
-sub unzip_by(&@)
-{
- my $code = shift;
-
- my @ret;
- foreach my $idx ( 0 .. $#_ ) {
- my @slice = $code->( local $_ = $_[$idx] );
- $#slice = $#ret if @slice < @ret;
- $ret[$_][$idx] = $slice[$_] for 0 .. $#slice;
- }
-
- return @ret;
-}
-
-=head2 @vals = extract_by { SELECTFUNC } @arr
-
-Removes elements from the referenced array on which the selection function
-returns true, and returns a list containing those elements. This function is
-similar to C<grep>, except that it modifies the referenced array to remove the
-selected values from it, leaving only the unselected ones.
-
- my @red_balls = extract_by { $_->color eq "red" } @balls;
-
- # Now there are no red balls in the @balls array
-
-This function modifies a real array, unlike most of the other functions in this
-module. Because of this, it requires a real array, not just a list.
-
-This function is implemented by invoking C<splice()> on the array, not by
-constructing a new list and assigning it. One result of this is that weak
-references will not be disturbed.
-
- extract_by { !defined $_ } @refs;
-
-will leave weak references weakened in the C<@refs> array, whereas
-
- @refs = grep { defined $_ } @refs;
-
-will strengthen them all again.
-
-=cut
-
-sub extract_by(&\@)
-{
- my $code = shift;
- my ( $arrref ) = @_;
-
- my @ret;
- for( my $idx = 0; $idx < scalar @$arrref; ) {
- if( $code->( local $_ = $arrref->[$idx] ) ) {
- push @ret, splice @$arrref, $idx, 1, ();
- }
- else {
- $idx++;
- }
- }
-
- return @ret;
-}
-
-=head2 @vals = weighted_shuffle_by { WEIGHTFUNC } @vals
-
-Returns the list of values shuffled into a random order. The randomisation is
-not uniform, but weighted by the value returned by the C<WEIGHTFUNC>. The
-probabilty of each item being returned first will be distributed with the
-distribution of the weights, and so on recursively for the remaining items.
-
-=cut
-
-sub weighted_shuffle_by(&@)
-{
- my $code = shift;
- my @vals = @_;
-
- my @weights = map { $code->( local $_ = $_ ) } @vals;
-
- my @ret;
- while( @vals > 1 ) {
- my $total = 0; $total += $_ for @weights;
- my $select = int rand $total;
- my $idx = 0;
- while( $select >= $weights[$idx] ) {
- $select -= $weights[$idx++];
- }
-
- push @ret, splice @vals, $idx, 1, ();
- splice @weights, $idx, 1, ();
- }
-
- push @ret, @vals if @vals;
-
- return @ret;
-}
-
-=head2 @vals = bundle_by { BLOCKFUNC } $number, @vals
-
-Similar to a regular C<map> functional, returns a list of the values returned
-by C<BLOCKFUNC>. Values from the input list are given to the block function in
-bundles of C<$number>.
-
-If given a list of values whose length does not evenly divide by C<$number>,
-the final call will be passed fewer elements than the others.
-
-=cut
-
-sub bundle_by(&@)
-{
- my $code = shift;
- my $n = shift;
-
- my @ret;
- for( my ( $pos, $next ) = ( 0, $n ); $pos < @_; $pos = $next, $next += $n ) {
- $next = @_ if $next > @_;
- push @ret, $code->( @_[$pos .. $next-1] );
- }
- return @ret;
-}
-
-=head1 TODO
-
-=over 4
-
-=item * XS implementations
-
-These functions are currently all written in pure perl. Some at least, may
-benefit from having XS implementations to speed up their logic.
-
-=item * Merge into L<List::Util> or L<List::MoreUtils>
-
-This module shouldn't really exist. The functions should instead be part of
-one of the existing modules that already contain many list utility functions.
-Having Yet Another List Utilty Module just worsens the problem.
-
-I have attempted to contact the authors of both of the above modules, to no
-avail; therefore I decided it best to write and release this code here anyway
-so that it is at least on CPAN. Once there, we can then see how best to merge
-it into an existing module.
-
-=back
-
-=head1 AUTHOR
-
-Paul Evans <leonerd@leonerd.org.uk>
-
-=cut
-
-0x55AA;
+++ /dev/null
-use strict;
-use warnings;
-
-package PBKDF2::Tiny;
-# ABSTRACT: Minimalist PBKDF2 (RFC 2898) with HMAC-SHA1 or HMAC-SHA2
-
-our $VERSION = '0.005';
-
-use Carp ();
-use Exporter 5.57 qw/import/;
-
-our @EXPORT_OK = qw/derive derive_hex verify verify_hex hmac digest_fcn/;
-
-my ( $BACKEND, $LOAD_ERR );
-for my $mod (qw/Digest::SHA Digest::SHA::PurePerl/) {
- $BACKEND = $mod, last if eval "require $mod; 1";
- $LOAD_ERR ||= $@;
-}
-die $LOAD_ERR if !$BACKEND;
-
-#--------------------------------------------------------------------------#
-# constants and lookup tables
-#--------------------------------------------------------------------------#
-
-# function coderef placeholder, block size in bytes, digest size in bytes
-my %DIGEST_TYPES = (
- 'SHA-1' => [ undef, 64, 20 ],
- 'SHA-224' => [ undef, 64, 28 ],
- 'SHA-256' => [ undef, 64, 32 ],
- 'SHA-384' => [ undef, 128, 48 ],
- 'SHA-512' => [ undef, 128, 64 ],
-);
-
-for my $type ( keys %DIGEST_TYPES ) {
- no strict 'refs';
- ( my $name = lc $type ) =~ s{-}{};
- $DIGEST_TYPES{$type}[0] = \&{"$BACKEND\::$name"};
-}
-
-my %INT = map { $_ => pack( "N", $_ ) } 1 .. 16;
-
-#--------------------------------------------------------------------------#
-# public functions
-#--------------------------------------------------------------------------#
-
-#pod =func derive
-#pod
-#pod $dk = derive( $type, $password, $salt, $iterations, $dk_length )
-#pod
-#pod The C<derive> function outputs a binary string with the derived key.
-#pod The first argument indicates the digest function to use. It must be one
-#pod of: SHA-1, SHA-224, SHA-256, SHA-384, or SHA-512.
-#pod
-#pod If a password or salt are not provided, they default to the empty string, so
-#pod don't do that! L<RFC 2898
-#pod recommends|https://tools.ietf.org/html/rfc2898#section-4.1> a random salt of at
-#pod least 8 octets. If you need a cryptographically strong salt, consider
-#pod L<Crypt::URandom>.
-#pod
-#pod The password and salt should encoded as octet strings. If not (i.e. if
-#pod Perl's internal 'UTF8' flag is on), then an exception will be thrown.
-#pod
-#pod The number of iterations defaults to 1000 if not provided. If the derived
-#pod key length is not provided, it defaults to the output size of the digest
-#pod function.
-#pod
-#pod =cut
-
-sub derive {
- my ( $type, $passwd, $salt, $iterations, $dk_length ) = @_;
-
- my ( $digester, $block_size, $digest_length ) = digest_fcn($type);
-
- $passwd = '' unless defined $passwd;
- $salt = '' unless defined $salt;
- $iterations ||= 1000;
- $dk_length ||= $digest_length;
-
- # we insist on octet strings for password and salt
- Carp::croak("password must be an octet string, not a character string")
- if utf8::is_utf8($passwd);
- Carp::croak("salt must be an octet string, not a character string")
- if utf8::is_utf8($salt);
-
- my $key = ( length($passwd) > $block_size ) ? $digester->($passwd) : $passwd;
- my $passes = int( $dk_length / $digest_length );
- $passes++ if $dk_length % $digest_length; # need part of an extra pass
-
- my $dk = "";
- for my $i ( 1 .. $passes ) {
- $INT{$i} ||= pack( "N", $i );
- my $digest = my $result =
- "" . hmac( $salt . $INT{$i}, $key, $digester, $block_size );
- for my $iter ( 2 .. $iterations ) {
- $digest = hmac( $digest, $key, $digester, $block_size );
- $result ^= $digest;
- }
- $dk .= $result;
- }
-
- return substr( $dk, 0, $dk_length );
-}
-
-#pod =func derive_hex
-#pod
-#pod Works just like L</derive> but outputs a hex string.
-#pod
-#pod =cut
-
-sub derive_hex { unpack( "H*", &derive ) }
-
-#pod =func verify
-#pod
-#pod $bool = verify( $dk, $type, $password, $salt, $iterations, $dk_length );
-#pod
-#pod The C<verify> function checks that a given derived key (in binary form) matches
-#pod the password and other parameters provided using a constant-time comparison
-#pod function.
-#pod
-#pod The first parameter is the derived key to check. The remaining parameters
-#pod are the same as for L</derive>.
-#pod
-#pod =cut
-
-sub verify {
- my ( $dk1, @derive_args ) = @_;
-
- my $dk2 = derive(@derive_args);
-
- # shortcut if input dk is the wrong length entirely; this is not
- # constant time, but this doesn't really give much away as
- # the keys are of different types anyway
-
- return unless length($dk1) == length($dk2);
-
- # if lengths match, do constant time comparison to avoid timing attacks
- my $match = 1;
- for my $i ( 0 .. length($dk1) - 1 ) {
- $match &= ( substr( $dk1, $i, 1 ) eq substr( $dk2, $i, 1 ) ) ? 1 : 0;
- }
-
- return $match;
-}
-
-#pod =func verify_hex
-#pod
-#pod Works just like L</verify> but the derived key must be a hex string (without a
-#pod leading "0x").
-#pod
-#pod =cut
-
-sub verify_hex {
- my $dk = pack( "H*", shift );
- return verify( $dk, @_ );
-}
-
-#pod =func digest_fcn
-#pod
-#pod ($fcn, $block_size, $digest_length) = digest_fcn('SHA-1');
-#pod $digest = $fcn->($data);
-#pod
-#pod This function is used internally by PBKDF2::Tiny, but made available in case
-#pod it's useful to someone.
-#pod
-#pod Given one of the valid digest types, it returns a function reference that
-#pod digests a string of data. It also returns block size and digest length for that
-#pod digest type.
-#pod
-#pod =cut
-
-sub digest_fcn {
- my ($type) = @_;
-
- Carp::croak("Digest function '$type' not supported")
- unless exists $DIGEST_TYPES{$type};
-
- return @{ $DIGEST_TYPES{$type} };
-}
-
-#pod =func hmac
-#pod
-#pod $key = $digest_fcn->($key) if length($key) > $block_size;
-#pod $hmac = hmac( $data, $key, $digest_fcn, $block_size );
-#pod
-#pod This function is used internally by PBKDF2::Tiny, but made available in case
-#pod it's useful to someone.
-#pod
-#pod The first two arguments are the data and key inputs to the HMAC function. Both
-#pod should be encoded as octet strings, as underlying HMAC/digest functions may
-#pod croak or may give unexpected results if Perl's internal UTF-8 flag is on.
-#pod
-#pod B<Note>: if the key is longer than the digest block size, it must be
-#pod preprocessed using the digesting function.
-#pod
-#pod The third and fourth arguments must be a digesting code reference (from
-#pod L</digest_fcn>) and block size.
-#pod
-#pod =cut
-
-# hmac function adapted from Digest::HMAC by Graham Barr and Gisle Aas.
-# Compared to that implementation, this *requires* a preprocessed
-# key and block size, which makes iterative hmac slightly more efficient.
-sub hmac {
- my ( $data, $key, $digest_func, $block_size ) = @_;
-
- my $k_ipad = $key ^ ( chr(0x36) x $block_size );
- my $k_opad = $key ^ ( chr(0x5c) x $block_size );
-
- &$digest_func( $k_opad, &$digest_func( $k_ipad, $data ) );
-}
-
-1;
-
-
-# vim: ts=4 sts=4 sw=4 et:
-
-__END__
-
-=pod
-
-=encoding UTF-8
-
-=head1 NAME
-
-PBKDF2::Tiny - Minimalist PBKDF2 (RFC 2898) with HMAC-SHA1 or HMAC-SHA2
-
-=head1 VERSION
-
-version 0.005
-
-=head1 SYNOPSIS
-
- use PBKDF2::Tiny qw/derive verify/;
-
- my $dk = derive( 'SHA-1', $pass, $salt, $iters );
-
- if ( verify( $dk, 'SHA-1', $pass, $salt, $iters ) ) {
- # password is correct
- }
-
-=head1 DESCRIPTION
-
-This module provides an L<RFC 2898|https://tools.ietf.org/html/rfc2898>
-compliant PBKDF2 implementation using HMAC-SHA1 or HMAC-SHA2 in under 100 lines
-of code. If you are using Perl 5.10 or later, it uses only core Perl modules.
-If you are on an earlier version of Perl, you need L<Digest::SHA> or
-L<Digest::SHA::PurePerl>.
-
-All documented functions are optionally exported. No functions are exported by default.
-
-=head1 FUNCTIONS
-
-=head2 derive
-
- $dk = derive( $type, $password, $salt, $iterations, $dk_length )
-
-The C<derive> function outputs a binary string with the derived key.
-The first argument indicates the digest function to use. It must be one
-of: SHA-1, SHA-224, SHA-256, SHA-384, or SHA-512.
-
-If a password or salt are not provided, they default to the empty string, so
-don't do that! L<RFC 2898
-recommends|https://tools.ietf.org/html/rfc2898#section-4.1> a random salt of at
-least 8 octets. If you need a cryptographically strong salt, consider
-L<Crypt::URandom>.
-
-The password and salt should encoded as octet strings. If not (i.e. if
-Perl's internal 'UTF8' flag is on), then an exception will be thrown.
-
-The number of iterations defaults to 1000 if not provided. If the derived
-key length is not provided, it defaults to the output size of the digest
-function.
-
-=head2 derive_hex
-
-Works just like L</derive> but outputs a hex string.
-
-=head2 verify
-
- $bool = verify( $dk, $type, $password, $salt, $iterations, $dk_length );
-
-The C<verify> function checks that a given derived key (in binary form) matches
-the password and other parameters provided using a constant-time comparison
-function.
-
-The first parameter is the derived key to check. The remaining parameters
-are the same as for L</derive>.
-
-=head2 verify_hex
-
-Works just like L</verify> but the derived key must be a hex string (without a
-leading "0x").
-
-=head2 digest_fcn
-
- ($fcn, $block_size, $digest_length) = digest_fcn('SHA-1');
- $digest = $fcn->($data);
-
-This function is used internally by PBKDF2::Tiny, but made available in case
-it's useful to someone.
-
-Given one of the valid digest types, it returns a function reference that
-digests a string of data. It also returns block size and digest length for that
-digest type.
-
-=head2 hmac
-
- $key = $digest_fcn->($key) if length($key) > $block_size;
- $hmac = hmac( $data, $key, $digest_fcn, $block_size );
-
-This function is used internally by PBKDF2::Tiny, but made available in case
-it's useful to someone.
-
-The first two arguments are the data and key inputs to the HMAC function. Both
-should be encoded as octet strings, as underlying HMAC/digest functions may
-croak or may give unexpected results if Perl's internal UTF-8 flag is on.
-
-B<Note>: if the key is longer than the digest block size, it must be
-preprocessed using the digesting function.
-
-The third and fourth arguments must be a digesting code reference (from
-L</digest_fcn>) and block size.
-
-=begin Pod::Coverage
-
-
-
-
-=end Pod::Coverage
-
-=head1 SEE ALSO
-
-=over 4
-
-=item *
-
-L<Crypt::PBKDF2>
-
-=item *
-
-L<Digest::PBDKF2>
-
-=back
-
-=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
-
-=head1 SUPPORT
-
-=head2 Bugs / Feature Requests
-
-Please report any bugs or feature requests through the issue tracker
-at L<https://github.com/dagolden/PBKDF2-Tiny/issues>.
-You will be notified automatically of any progress on your issue.
-
-=head2 Source Code
-
-This is open source software. The code repository is available for
-public review and contribution under the terms of the license.
-
-L<https://github.com/dagolden/PBKDF2-Tiny>
-
- git clone https://github.com/dagolden/PBKDF2-Tiny.git
-
-=head1 AUTHOR
-
-David Golden <dagolden@cpan.org>
-
-=head1 COPYRIGHT AND LICENSE
-
-This software is Copyright (c) 2014 by David Golden.
-
-This is free software, licensed under:
-
- The Apache License, Version 2.0, January 2004
-
-=cut
+++ /dev/null
-package Regexp::IPv6;
-
-our $VERSION = '0.03';
-
-use strict;
-use warnings;
-
-require Exporter;
-our @ISA = qw(Exporter);
-our @EXPORT_OK = qw($IPv6_re);
-
-my $IPv4 = "((25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))";
-my $G = "[0-9a-fA-F]{1,4}";
-
-my @tail = ( ":",
- "(:($G)?|$IPv4)",
- ":($IPv4|$G(:$G)?|)",
- "(:$IPv4|:$G(:$IPv4|(:$G){0,2})|:)",
- "((:$G){0,2}(:$IPv4|(:$G){1,2})|:)",
- "((:$G){0,3}(:$IPv4|(:$G){1,2})|:)",
- "((:$G){0,4}(:$IPv4|(:$G){1,2})|:)" );
-
-our $IPv6_re = $G;
-$IPv6_re = "$G:($IPv6_re|$_)" for @tail;
-$IPv6_re = qq/:(:$G){0,5}((:$G){1,2}|:$IPv4)|$IPv6_re/;
-$IPv6_re =~ s/\(/(?:/g;
-$IPv6_re = qr/$IPv6_re/;
-
-1;
-__END__
-
-=head1 NAME
-
-Regexp::IPv6 - Regular expression for IPv6 addresses
-
-=head1 SYNOPSIS
-
- use Regexp::IPv6 qw($IPv6_re);
-
- $address =~ /^$IPv6_re$/ and print "IPv6 address\n";
-
-=head1 DESCRIPTION
-
-This module exports the $IPv6_re regular expression that matches any
-valid IPv6 address as described in "RFC 2373 - 2.2 Text Representation
-of Addresses" but C<::>. Any string not compliant with such RFC will
-be rejected.
-
-To match full strings use C</^$IPv6_re$/>.
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright (C) 2009, 2010 by Salvador FandiE<ntilde>o
-(sfandino@yahoo.com)
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself, either Perl version 5.10.0 or,
-at your option, any later version of Perl 5 you may have available.
-
-Additionally, you are allowed to use the regexp generated by the
-module in any way you want, without any restriction. For instance, you
-are allowed to copy it verbating in your program.
-
-=cut
-
+++ /dev/null
-package Set::Infinite;
-
-# Copyright (c) 2001, 2002, 2003, 2004 Flavio Soibelmann Glock.
-# All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-use 5.005_03;
-
-# These methods are inherited from Set::Infinite::Basic "as-is":
-# type list fixtype numeric min max integer real new span copy
-# start_set end_set universal_set empty_set minus difference
-# symmetric_difference is_empty
-
-use strict;
-use base qw(Set::Infinite::Basic Exporter);
-use Carp;
-use Set::Infinite::Arithmetic;
-
-use overload
- '<=>' => \&spaceship,
- '""' => \&as_string;
-
-use vars qw(@EXPORT_OK $VERSION
- $TRACE $DEBUG_BT $PRETTY_PRINT $inf $minus_inf $neg_inf
- %_first %_last %_backtrack
- $too_complex $backtrack_depth
- $max_backtrack_depth $max_intersection_depth
- $trace_level %level_title );
-
-@EXPORT_OK = qw(inf $inf trace_open trace_close);
-
-$inf = 100**100**100;
-$neg_inf = $minus_inf = -$inf;
-
-
-# obsolete methods - included for backward compatibility
-sub inf () { $inf }
-sub minus_inf () { $minus_inf }
-sub no_cleanup { $_[0] }
-*type = \&Set::Infinite::Basic::type;
-sub compact { @_ }
-
-
-BEGIN {
- $VERSION = "0.65";
- $TRACE = 0; # enable basic trace method execution
- $DEBUG_BT = 0; # enable backtrack tracer
- $PRETTY_PRINT = 0; # 0 = print 'Too Complex'; 1 = describe functions
- $trace_level = 0; # indentation level when debugging
-
- $too_complex = "Too complex";
- $backtrack_depth = 0;
- $max_backtrack_depth = 10; # _backtrack()
- $max_intersection_depth = 5; # first()
-}
-
-sub trace { # title=>'aaa'
- return $_[0] unless $TRACE;
- my ($self, %parm) = @_;
- my @caller = caller(1);
- # print "self $self ". ref($self). "\n";
- print "" . ( ' | ' x $trace_level ) .
- "$parm{title} ". $self->copy .
- ( exists $parm{arg} ? " -- " . $parm{arg}->copy : "" ).
- " $caller[1]:$caller[2] ]\n" if $TRACE == 1;
- return $self;
-}
-
-sub trace_open {
- return $_[0] unless $TRACE;
- my ($self, %parm) = @_;
- my @caller = caller(1);
- print "" . ( ' | ' x $trace_level ) .
- "\\ $parm{title} ". $self->copy .
- ( exists $parm{arg} ? " -- ". $parm{arg}->copy : "" ).
- " $caller[1]:$caller[2] ]\n";
- $trace_level++;
- $level_title{$trace_level} = $parm{title};
- return $self;
-}
-
-sub trace_close {
- return $_[0] unless $TRACE;
- my ($self, %parm) = @_;
- my @caller = caller(0);
- print "" . ( ' | ' x ($trace_level-1) ) .
- "\/ $level_title{$trace_level} ".
- ( exists $parm{arg} ?
- (
- defined $parm{arg} ?
- "ret ". ( UNIVERSAL::isa($parm{arg}, __PACKAGE__ ) ?
- $parm{arg}->copy :
- "<$parm{arg}>" ) :
- "undef"
- ) :
- "" # no arg
- ).
- " $caller[1]:$caller[2] ]\n";
- $trace_level--;
- return $self;
-}
-
-
-# creates a 'function' object that can be solved by _backtrack()
-sub _function {
- my ($self, $method) = (shift, shift);
- my $b = $self->empty_set();
- $b->{too_complex} = 1;
- $b->{parent} = $self;
- $b->{method} = $method;
- $b->{param} = [ @_ ];
- return $b;
-}
-
-
-# same as _function, but with 2 arguments
-sub _function2 {
- my ($self, $method, $arg) = (shift, shift, shift);
- unless ( $self->{too_complex} || $arg->{too_complex} ) {
- return $self->$method($arg, @_);
- }
- my $b = $self->empty_set();
- $b->{too_complex} = 1;
- $b->{parent} = [ $self, $arg ];
- $b->{method} = $method;
- $b->{param} = [ @_ ];
- return $b;
-}
-
-
-sub quantize {
- my $self = shift;
- $self->trace_open(title=>"quantize") if $TRACE;
- my @min = $self->min_a;
- my @max = $self->max_a;
- if (($self->{too_complex}) or
- (defined $min[0] && $min[0] == $neg_inf) or
- (defined $max[0] && $max[0] == $inf)) {
-
- return $self->_function( 'quantize', @_ );
- }
-
- my @a;
- my %rule = @_;
- my $b = $self->empty_set();
- my $parent = $self;
-
- $rule{unit} = 'one' unless $rule{unit};
- $rule{quant} = 1 unless $rule{quant};
- $rule{parent} = $parent;
- $rule{strict} = $parent unless exists $rule{strict};
- $rule{type} = $parent->{type};
-
- my ($min, $open_begin) = $parent->min_a;
-
- unless (defined $min) {
- $self->trace_close( arg => $b ) if $TRACE;
- return $b;
- }
-
- $rule{fixtype} = 1 unless exists $rule{fixtype};
- $Set::Infinite::Arithmetic::Init_quantizer{$rule{unit}}->(\%rule);
-
- $rule{sub_unit} = $Set::Infinite::Arithmetic::Offset_to_value{$rule{unit}};
- carp "Quantize unit '".$rule{unit}."' not implemented" unless ref( $rule{sub_unit} ) eq 'CODE';
-
- my ($max, $open_end) = $parent->max_a;
- $rule{offset} = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $min);
- my $last_offset = $Set::Infinite::Arithmetic::Value_to_offset{$rule{unit}}->(\%rule, $max);
- $rule{size} = $last_offset - $rule{offset} + 1;
- my ($index, $tmp, $this, $next);
- for $index (0 .. $rule{size} ) {
- # ($this, $next) = $rule{sub_unit} (\%rule, $index);
- ($this, $next) = $rule{sub_unit}->(\%rule, $index);
- unless ( $rule{fixtype} ) {
- $tmp = { a => $this , b => $next ,
- open_begin => 0, open_end => 1 };
- }
- else {
- $tmp = Set::Infinite::Basic::_simple_new($this,$next, $rule{type} );
- $tmp->{open_end} = 1;
- }
- next if ( $rule{strict} and not $rule{strict}->intersects($tmp));
- push @a, $tmp;
- }
-
- $b->{list} = \@a; # change data
- $self->trace_close( arg => $b ) if $TRACE;
- return $b;
-}
-
-
-sub _first_n {
- my $self = shift;
- my $n = shift;
- my $tail = $self->copy;
- my @result;
- my $first;
- for ( 1 .. $n )
- {
- ( $first, $tail ) = $tail->first if $tail;
- push @result, $first;
- }
- return $tail, @result;
-}
-
-sub _last_n {
- my $self = shift;
- my $n = shift;
- my $tail = $self->copy;
- my @result;
- my $last;
- for ( 1 .. $n )
- {
- ( $last, $tail ) = $tail->last if $tail;
- unshift @result, $last;
- }
- return $tail, @result;
-}
-
-
-sub select {
- my $self = shift;
- $self->trace_open(title=>"select") if $TRACE;
-
- my %param = @_;
- die "select() - parameter 'freq' is deprecated" if exists $param{freq};
-
- my $res;
- my $count;
- my @by;
- @by = @{ $param{by} } if exists $param{by};
- $count = delete $param{count} || $inf;
- # warn "select: count=$count by=[@by]";
-
- if ($count <= 0) {
- $self->trace_close( arg => $res ) if $TRACE;
- return $self->empty_set();
- }
-
- my @set;
- my $tail;
- my $first;
- my $last;
- if ( @by )
- {
- my @res;
- if ( ! $self->is_too_complex )
- {
- $res = $self->new;
- @res = @{ $self->{list} }[ @by ] ;
- }
- else
- {
- my ( @pos_by, @neg_by );
- for ( @by ) {
- ( $_ < 0 ) ? push @neg_by, $_ :
- push @pos_by, $_;
- }
- my @first;
- if ( @pos_by ) {
- @pos_by = sort { $a <=> $b } @pos_by;
- ( $tail, @set ) = $self->_first_n( 1 + $pos_by[-1] );
- @first = @set[ @pos_by ];
- }
- my @last;
- if ( @neg_by ) {
- @neg_by = sort { $a <=> $b } @neg_by;
- ( $tail, @set ) = $self->_last_n( - $neg_by[0] );
- @last = @set[ @neg_by ];
- }
- @res = map { $_->{list}[0] } ( @first , @last );
- }
-
- $res = $self->new;
- @res = sort { $a->{a} <=> $b->{a} } grep { defined } @res;
- my $last;
- my @a;
- for ( @res ) {
- push @a, $_ if ! $last || $last->{a} != $_->{a};
- $last = $_;
- }
- $res->{list} = \@a;
- }
- else
- {
- $res = $self;
- }
-
- return $res if $count == $inf;
- my $count_set = $self->empty_set();
- if ( ! $self->is_too_complex )
- {
- my @a;
- @a = grep { defined } @{ $res->{list} }[ 0 .. $count - 1 ] ;
- $count_set->{list} = \@a;
- }
- else
- {
- my $last;
- while ( $res ) {
- ( $first, $res ) = $res->first;
- last unless $first;
- last if $last && $last->{a} == $first->{list}[0]{a};
- $last = $first->{list}[0];
- push @{$count_set->{list}}, $first->{list}[0];
- $count--;
- last if $count <= 0;
- }
- }
- return $count_set;
-}
-
-BEGIN {
-
- # %_first and %_last hashes are used to backtrack the value
- # of first() and last() of an infinite set
-
- %_first = (
- 'complement' =>
- sub {
- my $self = $_[0];
- my @parent_min = $self->{parent}->first;
- unless ( defined $parent_min[0] ) {
- return (undef, 0);
- }
- my $parent_complement;
- my $first;
- my @next;
- my $parent;
- if ( $parent_min[0]->min == $neg_inf ) {
- my @parent_second = $parent_min[1]->first;
- # (-inf..min) (second..?)
- # (min..second) = complement
- $first = $self->new( $parent_min[0]->complement );
- $first->{list}[0]{b} = $parent_second[0]->{list}[0]{a};
- $first->{list}[0]{open_end} = ! $parent_second[0]->{list}[0]{open_begin};
- @{ $first->{list} } = () if
- ( $first->{list}[0]{a} == $first->{list}[0]{b}) &&
- ( $first->{list}[0]{open_begin} ||
- $first->{list}[0]{open_end} );
- @next = $parent_second[0]->max_a;
- $parent = $parent_second[1];
- }
- else {
- # (min..?)
- # (-inf..min) = complement
- $parent_complement = $parent_min[0]->complement;
- $first = $self->new( $parent_complement->{list}[0] );
- @next = $parent_min[0]->max_a;
- $parent = $parent_min[1];
- }
- my @no_tail = $self->new($neg_inf,$next[0]);
- $no_tail[0]->{list}[0]{open_end} = $next[1];
- my $tail = $parent->union($no_tail[0])->complement;
- return ($first, $tail);
- }, # end: first-complement
- 'intersection' =>
- sub {
- my $self = $_[0];
- my @parent = @{ $self->{parent} };
- # warn "$method parents @parent";
- my $retry_count = 0;
- my (@first, @min, $which, $first1, $intersection);
- SEARCH: while ($retry_count++ < $max_intersection_depth) {
- return undef unless defined $parent[0];
- return undef unless defined $parent[1];
- @{$first[0]} = $parent[0]->first;
- @{$first[1]} = $parent[1]->first;
- unless ( defined $first[0][0] ) {
- # warn "don't know first of $method";
- $self->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
- unless ( defined $first[1][0] ) {
- # warn "don't know first of $method";
- $self->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
- @{$min[0]} = $first[0][0]->min_a;
- @{$min[1]} = $first[1][0]->min_a;
- unless ( defined $min[0][0] && defined $min[1][0] ) {
- return undef;
- }
- # $which is the index to the bigger "first".
- $which = ($min[0][0] < $min[1][0]) ? 1 : 0;
- for my $which1 ( $which, 1 - $which ) {
- my $tmp_parent = $parent[$which1];
- ($first1, $parent[$which1]) = @{ $first[$which1] };
- if ( $first1->is_empty ) {
- # warn "first1 empty! count $retry_count";
- # trace_close;
- # return $first1, undef;
- $intersection = $first1;
- $which = $which1;
- last SEARCH;
- }
- $intersection = $first1->intersection( $parent[1-$which1] );
- # warn "intersection with $first1 is $intersection";
- unless ( $intersection->is_null ) {
- # $self->trace( title=>"got an intersection" );
- if ( $intersection->is_too_complex ) {
- $parent[$which1] = $tmp_parent;
- }
- else {
- $which = $which1;
- last SEARCH;
- }
- };
- }
- }
- if ( $#{ $intersection->{list} } > 0 ) {
- my $tail;
- ($intersection, $tail) = $intersection->first;
- $parent[$which] = $parent[$which]->union( $tail );
- }
- my $tmp;
- if ( defined $parent[$which] and defined $parent[1-$which] ) {
- $tmp = $parent[$which]->intersection ( $parent[1-$which] );
- }
- return ($intersection, $tmp);
- }, # end: first-intersection
- 'union' =>
- sub {
- my $self = $_[0];
- my (@first, @min);
- my @parent = @{ $self->{parent} };
- @{$first[0]} = $parent[0]->first;
- @{$first[1]} = $parent[1]->first;
- unless ( defined $first[0][0] ) {
- # looks like one set was empty
- return @{$first[1]};
- }
- @{$min[0]} = $first[0][0]->min_a;
- @{$min[1]} = $first[1][0]->min_a;
-
- # check min1/min2 for undef
- unless ( defined $min[0][0] ) {
- $self->trace_close( arg => "@{$first[1]}" ) if $TRACE;
- return @{$first[1]}
- }
- unless ( defined $min[1][0] ) {
- $self->trace_close( arg => "@{$first[0]}" ) if $TRACE;
- return @{$first[0]}
- }
-
- my $which = ($min[0][0] < $min[1][0]) ? 0 : 1;
- my $first = $first[$which][0];
-
- # find out the tail
- my $parent1 = $first[$which][1];
- # warn $self->{parent}[$which]." - $first = $parent1";
- my $parent2 = ($min[0][0] == $min[1][0]) ?
- $self->{parent}[1-$which]->complement($first) :
- $self->{parent}[1-$which];
- my $tail;
- if (( ! defined $parent1 ) || $parent1->is_null) {
- # warn "union parent1 tail is null";
- $tail = $parent2;
- }
- else {
- my $method = $self->{method};
- $tail = $parent1->$method( $parent2 );
- }
-
- if ( $first->intersects( $tail ) ) {
- my $first2;
- ( $first2, $tail ) = $tail->first;
- $first = $first->union( $first2 );
- }
-
- $self->trace_close( arg => "$first $tail" ) if $TRACE;
- return ($first, $tail);
- }, # end: first-union
- 'iterate' =>
- sub {
- my $self = $_[0];
- my $parent = $self->{parent};
- my ($first, $tail) = $parent->first;
- $first = $first->iterate( @{$self->{param}} ) if ref($first);
- $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
- my $more;
- ($first, $more) = $first->first if ref($first);
- $tail = $tail->_function2( 'union', $more ) if defined $more;
- return ($first, $tail);
- },
- 'until' =>
- sub {
- my $self = $_[0];
- my ($a1, $b1) = @{ $self->{parent} };
- $a1->trace( title=>"computing first()" );
- my @first1 = $a1->first;
- my @first2 = $b1->first;
- my ($first, $tail);
- if ( $first2[0] <= $first1[0] ) {
- # added ->first because it returns 2 spans if $a1 == $a2
- $first = $a1->empty_set()->until( $first2[0] )->first;
- $tail = $a1->_function2( "until", $first2[1] );
- }
- else {
- $first = $a1->new( $first1[0] )->until( $first2[0] );
- if ( defined $first1[1] ) {
- $tail = $first1[1]->_function2( "until", $first2[1] );
- }
- else {
- $tail = undef;
- }
- }
- return ($first, $tail);
- },
- 'offset' =>
- sub {
- my $self = $_[0];
- my ($first, $tail) = $self->{parent}->first;
- $first = $first->offset( @{$self->{param}} );
- $tail = $tail->_function( 'offset', @{$self->{param}} );
- my $more;
- ($first, $more) = $first->first;
- $tail = $tail->_function2( 'union', $more ) if defined $more;
- return ($first, $tail);
- },
- 'quantize' =>
- sub {
- my $self = $_[0];
- my @min = $self->{parent}->min_a;
- if ( $min[0] == $neg_inf || $min[0] == $inf ) {
- return ( $self->new( $min[0] ) , $self->copy );
- }
- my $first = $self->new( $min[0] )->quantize( @{$self->{param}} );
- return ( $first,
- $self->{parent}->
- _function2( 'intersection', $first->complement )->
- _function( 'quantize', @{$self->{param}} ) );
- },
- 'tolerance' =>
- sub {
- my $self = $_[0];
- my ($first, $tail) = $self->{parent}->first;
- $first = $first->tolerance( @{$self->{param}} );
- $tail = $tail->tolerance( @{$self->{param}} );
- return ($first, $tail);
- },
- ); # %_first
-
- %_last = (
- 'complement' =>
- sub {
- my $self = $_[0];
- my @parent_max = $self->{parent}->last;
- unless ( defined $parent_max[0] ) {
- return (undef, 0);
- }
- my $parent_complement;
- my $last;
- my @next;
- my $parent;
- if ( $parent_max[0]->max == $inf ) {
- # (inf..min) (second..?) = parent
- # (min..second) = complement
- my @parent_second = $parent_max[1]->last;
- $last = $self->new( $parent_max[0]->complement );
- $last->{list}[0]{a} = $parent_second[0]->{list}[0]{b};
- $last->{list}[0]{open_begin} = ! $parent_second[0]->{list}[0]{open_end};
- @{ $last->{list} } = () if
- ( $last->{list}[0]{a} == $last->{list}[0]{b}) &&
- ( $last->{list}[0]{open_end} ||
- $last->{list}[0]{open_begin} );
- @next = $parent_second[0]->min_a;
- $parent = $parent_second[1];
- }
- else {
- # (min..?)
- # (-inf..min) = complement
- $parent_complement = $parent_max[0]->complement;
- $last = $self->new( $parent_complement->{list}[-1] );
- @next = $parent_max[0]->min_a;
- $parent = $parent_max[1];
- }
- my @no_tail = $self->new($next[0], $inf);
- $no_tail[0]->{list}[-1]{open_begin} = $next[1];
- my $tail = $parent->union($no_tail[-1])->complement;
- return ($last, $tail);
- },
- 'intersection' =>
- sub {
- my $self = $_[0];
- my @parent = @{ $self->{parent} };
- # TODO: check max1/max2 for undef
-
- my $retry_count = 0;
- my (@last, @max, $which, $last1, $intersection);
-
- SEARCH: while ($retry_count++ < $max_intersection_depth) {
- return undef unless defined $parent[0];
- return undef unless defined $parent[1];
-
- @{$last[0]} = $parent[0]->last;
- @{$last[1]} = $parent[1]->last;
- unless ( defined $last[0][0] ) {
- $self->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
- unless ( defined $last[1][0] ) {
- $self->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
- @{$max[0]} = $last[0][0]->max_a;
- @{$max[1]} = $last[1][0]->max_a;
- unless ( defined $max[0][0] && defined $max[1][0] ) {
- $self->trace( title=>"can't find max()" ) if $TRACE;
- $self->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
-
- # $which is the index to the smaller "last".
- $which = ($max[0][0] > $max[1][0]) ? 1 : 0;
-
- for my $which1 ( $which, 1 - $which ) {
- my $tmp_parent = $parent[$which1];
- ($last1, $parent[$which1]) = @{ $last[$which1] };
- if ( $last1->is_null ) {
- $which = $which1;
- $intersection = $last1;
- last SEARCH;
- }
- $intersection = $last1->intersection( $parent[1-$which1] );
-
- unless ( $intersection->is_null ) {
- # $self->trace( title=>"got an intersection" );
- if ( $intersection->is_too_complex ) {
- $self->trace( title=>"got a too_complex intersection" ) if $TRACE;
- # warn "too complex intersection";
- $parent[$which1] = $tmp_parent;
- }
- else {
- $self->trace( title=>"got an intersection" ) if $TRACE;
- $which = $which1;
- last SEARCH;
- }
- };
- }
- }
- $self->trace( title=>"exit loop" ) if $TRACE;
- if ( $#{ $intersection->{list} } > 0 ) {
- my $tail;
- ($intersection, $tail) = $intersection->last;
- $parent[$which] = $parent[$which]->union( $tail );
- }
- my $tmp;
- if ( defined $parent[$which] and defined $parent[1-$which] ) {
- $tmp = $parent[$which]->intersection ( $parent[1-$which] );
- }
- return ($intersection, $tmp);
- },
- 'union' =>
- sub {
- my $self = $_[0];
- my (@last, @max);
- my @parent = @{ $self->{parent} };
- @{$last[0]} = $parent[0]->last;
- @{$last[1]} = $parent[1]->last;
- @{$max[0]} = $last[0][0]->max_a;
- @{$max[1]} = $last[1][0]->max_a;
- unless ( defined $max[0][0] ) {
- return @{$last[1]}
- }
- unless ( defined $max[1][0] ) {
- return @{$last[0]}
- }
-
- my $which = ($max[0][0] > $max[1][0]) ? 0 : 1;
- my $last = $last[$which][0];
- # find out the tail
- my $parent1 = $last[$which][1];
- # warn $self->{parent}[$which]." - $last = $parent1";
- my $parent2 = ($max[0][0] == $max[1][0]) ?
- $self->{parent}[1-$which]->complement($last) :
- $self->{parent}[1-$which];
- my $tail;
- if (( ! defined $parent1 ) || $parent1->is_null) {
- $tail = $parent2;
- }
- else {
- my $method = $self->{method};
- $tail = $parent1->$method( $parent2 );
- }
-
- if ( $last->intersects( $tail ) ) {
- my $last2;
- ( $last2, $tail ) = $tail->last;
- $last = $last->union( $last2 );
- }
-
- return ($last, $tail);
- },
- 'until' =>
- sub {
- my $self = $_[0];
- my ($a1, $b1) = @{ $self->{parent} };
- $a1->trace( title=>"computing last()" );
- my @last1 = $a1->last;
- my @last2 = $b1->last;
- my ($last, $tail);
- if ( $last2[0] <= $last1[0] ) {
- # added ->last because it returns 2 spans if $a1 == $a2
- $last = $last2[0]->until( $a1 )->last;
- $tail = $a1->_function2( "until", $last2[1] );
- }
- else {
- $last = $a1->new( $last1[0] )->until( $last2[0] );
- if ( defined $last1[1] ) {
- $tail = $last1[1]->_function2( "until", $last2[1] );
- }
- else {
- $tail = undef;
- }
- }
- return ($last, $tail);
- },
- 'iterate' =>
- sub {
- my $self = $_[0];
- my $parent = $self->{parent};
- my ($last, $tail) = $parent->last;
- $last = $last->iterate( @{$self->{param}} ) if ref($last);
- $tail = $tail->_function( 'iterate', @{$self->{param}} ) if ref($tail);
- my $more;
- ($last, $more) = $last->last if ref($last);
- $tail = $tail->_function2( 'union', $more ) if defined $more;
- return ($last, $tail);
- },
- 'offset' =>
- sub {
- my $self = $_[0];
- my ($last, $tail) = $self->{parent}->last;
- $last = $last->offset( @{$self->{param}} );
- $tail = $tail->_function( 'offset', @{$self->{param}} );
- my $more;
- ($last, $more) = $last->last;
- $tail = $tail->_function2( 'union', $more ) if defined $more;
- return ($last, $tail);
- },
- 'quantize' =>
- sub {
- my $self = $_[0];
- my @max = $self->{parent}->max_a;
- if (( $max[0] == $neg_inf ) || ( $max[0] == $inf )) {
- return ( $self->new( $max[0] ) , $self->copy );
- }
- my $last = $self->new( $max[0] )->quantize( @{$self->{param}} );
- if ($max[1]) { # open_end
- if ( $last->min <= $max[0] ) {
- $last = $self->new( $last->min - 1e-9 )->quantize( @{$self->{param}} );
- }
- }
- return ( $last, $self->{parent}->
- _function2( 'intersection', $last->complement )->
- _function( 'quantize', @{$self->{param}} ) );
- },
- 'tolerance' =>
- sub {
- my $self = $_[0];
- my ($last, $tail) = $self->{parent}->last;
- $last = $last->tolerance( @{$self->{param}} );
- $tail = $tail->tolerance( @{$self->{param}} );
- return ($last, $tail);
- },
- ); # %_last
-} # BEGIN
-
-sub first {
- my $self = $_[0];
- unless ( exists $self->{first} ) {
- $self->trace_open(title=>"first") if $TRACE;
- if ( $self->{too_complex} ) {
- my $method = $self->{method};
- # warn "method $method ". ( exists $_first{$method} ? "exists" : "does not exist" );
- if ( exists $_first{$method} ) {
- @{$self->{first}} = $_first{$method}->($self);
- }
- else {
- my $redo = $self->{parent}->$method ( @{ $self->{param} } );
- @{$self->{first}} = $redo->first;
- }
- }
- else {
- return $self->SUPER::first;
- }
- }
- return wantarray ? @{$self->{first}} : $self->{first}[0];
-}
-
-
-sub last {
- my $self = $_[0];
- unless ( exists $self->{last} ) {
- $self->trace(title=>"last") if $TRACE;
- if ( $self->{too_complex} ) {
- my $method = $self->{method};
- if ( exists $_last{$method} ) {
- @{$self->{last}} = $_last{$method}->($self);
- }
- else {
- my $redo = $self->{parent}->$method ( @{ $self->{param} } );
- @{$self->{last}} = $redo->last;
- }
- }
- else {
- return $self->SUPER::last;
- }
- }
- return wantarray ? @{$self->{last}} : $self->{last}[0];
-}
-
-
-# offset: offsets subsets
-sub offset {
- my $self = shift;
- if ($self->{too_complex}) {
- return $self->_function( 'offset', @_ );
- }
- $self->trace_open(title=>"offset") if $TRACE;
-
- my @a;
- my %param = @_;
- my $b1 = $self->empty_set();
- my ($interval, $ia, $i);
- $param{mode} = 'offset' unless $param{mode};
-
- unless (ref($param{value}) eq 'ARRAY') {
- $param{value} = [0 + $param{value}, 0 + $param{value}];
- }
- $param{unit} = 'one' unless $param{unit};
- my $parts = ($#{$param{value}}) / 2;
- my $sub_unit = $Set::Infinite::Arithmetic::subs_offset2{$param{unit}};
- my $sub_mode = $Set::Infinite::Arithmetic::_MODE{$param{mode}};
-
- carp "unknown unit $param{unit} for offset()" unless defined $sub_unit;
- carp "unknown mode $param{mode} for offset()" unless defined $sub_mode;
-
- my ($j);
- my ($cmp, $this, $next, $ib, $part, $open_begin, $open_end, $tmp);
-
- my @value;
- foreach $j (0 .. $parts) {
- push @value, [ $param{value}[$j+$j], $param{value}[$j+$j + 1] ];
- }
-
- foreach $interval ( @{ $self->{list} } ) {
- $ia = $interval->{a};
- $ib = $interval->{b};
- $open_begin = $interval->{open_begin};
- $open_end = $interval->{open_end};
- foreach $j (0 .. $parts) {
- # print " [ofs($ia,$ib)] ";
- ($this, $next) = $sub_mode->( $sub_unit, $ia, $ib, @{$value[$j]} );
- next if ($this > $next); # skip if a > b
- if ($this == $next) {
- # TODO: fix this
- $open_end = $open_begin;
- }
- push @a, { a => $this , b => $next ,
- open_begin => $open_begin , open_end => $open_end };
- } # parts
- } # self
- @a = sort { $a->{a} <=> $b->{a} } @a;
- $b1->{list} = \@a; # change data
- $self->trace_close( arg => $b1 ) if $TRACE;
- $b1 = $b1->fixtype if $self->{fixtype};
- return $b1;
-}
-
-
-sub is_null {
- $_[0]->{too_complex} ? 0 : $_[0]->SUPER::is_null;
-}
-
-
-sub is_too_complex {
- $_[0]->{too_complex} ? 1 : 0;
-}
-
-
-# shows how a 'compacted' set looks like after quantize
-sub _quantize_span {
- my $self = shift;
- my %param = @_;
- $self->trace_open(title=>"_quantize_span") if $TRACE;
- my $res;
- if ($self->{too_complex}) {
- $res = $self->{parent};
- if ($self->{method} ne 'quantize') {
- $self->trace( title => "parent is a ". $self->{method} );
- if ( $self->{method} eq 'union' ) {
- my $arg0 = $self->{parent}[0]->_quantize_span(%param);
- my $arg1 = $self->{parent}[1]->_quantize_span(%param);
- $res = $arg0->union( $arg1 );
- }
- elsif ( $self->{method} eq 'intersection' ) {
- my $arg0 = $self->{parent}[0]->_quantize_span(%param);
- my $arg1 = $self->{parent}[1]->_quantize_span(%param);
- $res = $arg0->intersection( $arg1 );
- }
-
- # TODO: other methods
- else {
- $res = $self; # ->_function( "_quantize_span", %param );
- }
- $self->trace_close( arg => $res ) if $TRACE;
- return $res;
- }
-
- # $res = $self->{parent};
- if ($res->{too_complex}) {
- $res->trace( title => "parent is complex" );
- $res = $res->_quantize_span( %param );
- $res = $res->quantize( @{$self->{param}} )->_quantize_span( %param );
- }
- else {
- $res = $res->iterate (
- sub {
- $_[0]->quantize( @{$self->{param}} )->span;
- }
- );
- }
- }
- else {
- $res = $self->iterate ( sub { $_[0] } );
- }
- $self->trace_close( arg => $res ) if $TRACE;
- return $res;
-}
-
-
-
-BEGIN {
-
- %_backtrack = (
-
- until => sub {
- my ($self, $arg) = @_;
- my $before = $self->{parent}[0]->intersection( $neg_inf, $arg->min )->max;
- $before = $arg->min unless $before;
- my $after = $self->{parent}[1]->intersection( $arg->max, $inf )->min;
- $after = $arg->max unless $after;
- return $arg->new( $before, $after );
- },
-
- iterate => sub {
- my ($self, $arg) = @_;
-
- if ( defined $self->{backtrack_callback} )
- {
- return $arg = $self->new( $self->{backtrack_callback}->( $arg ) );
- }
-
- my $before = $self->{parent}->intersection( $neg_inf, $arg->min )->max;
- $before = $arg->min unless $before;
- my $after = $self->{parent}->intersection( $arg->max, $inf )->min;
- $after = $arg->max unless $after;
-
- return $arg->new( $before, $after );
- },
-
- quantize => sub {
- my ($self, $arg) = @_;
- if ($arg->{too_complex}) {
- return $arg;
- }
- else {
- return $arg->quantize( @{$self->{param}} )->_quantize_span;
- }
- },
-
- offset => sub {
- my ($self, $arg) = @_;
- # offset - apply offset with negative values
- my %tmp = @{$self->{param}};
- my @values = sort @{$tmp{value}};
-
- my $backtrack_arg2 = $arg->offset(
- unit => $tmp{unit},
- mode => $tmp{mode},
- value => [ - $values[-1], - $values[0] ] );
- return $arg->union( $backtrack_arg2 ); # fixes some problems with 'begin' mode
- },
-
- );
-}
-
-
-sub _backtrack {
- my ($self, $method, $arg) = @_;
- return $self->$method ($arg) unless $self->{too_complex};
-
- $self->trace_open( title => 'backtrack '.$self->{method} ) if $TRACE;
-
- $backtrack_depth++;
- if ( $backtrack_depth > $max_backtrack_depth ) {
- carp ( __PACKAGE__ . ": Backtrack too deep " .
- "(more than $max_backtrack_depth levels)" );
- }
-
- if (exists $_backtrack{ $self->{method} } ) {
- $arg = $_backtrack{ $self->{method} }->( $self, $arg );
- }
-
- my $result;
- if ( ref($self->{parent}) eq 'ARRAY' ) {
- # has 2 parents (intersection, union, until)
-
- my ( $result1, $result2 ) = @{$self->{parent}};
- $result1 = $result1->_backtrack( $method, $arg )
- if $result1->{too_complex};
- $result2 = $result2->_backtrack( $method, $arg )
- if $result2->{too_complex};
-
- $method = $self->{method};
- if ( $result1->{too_complex} || $result2->{too_complex} ) {
- $result = $result1->_function2( $method, $result2 );
- }
- else {
- $result = $result1->$method ($result2);
- }
- }
- else {
- # has 1 parent and parameters (offset, select, quantize, iterate)
-
- $result = $self->{parent}->_backtrack( $method, $arg );
- $method = $self->{method};
- $result = $result->$method ( @{$self->{param}} );
- }
-
- $backtrack_depth--;
- $self->trace_close( arg => $result ) if $TRACE;
- return $result;
-}
-
-
-sub intersects {
- my $a1 = shift;
- my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
-
- $a1->trace(title=>"intersects");
- if ($a1->{too_complex}) {
- $a1 = $a1->_backtrack('intersection', $b1 );
- } # don't put 'else' here
- if ($b1->{too_complex}) {
- $b1 = $b1->_backtrack('intersection', $a1);
- }
- if (($a1->{too_complex}) or ($b1->{too_complex})) {
- return undef; # we don't know the answer!
- }
- return $a1->SUPER::intersects( $b1 );
-}
-
-
-sub iterate {
- my $self = shift;
- my $callback = shift;
- die "First argument to iterate() must be a subroutine reference"
- unless ref( $callback ) eq 'CODE';
- my $backtrack_callback;
- if ( @_ && $_[0] eq 'backtrack_callback' )
- {
- ( undef, $backtrack_callback ) = ( shift, shift );
- }
- my $set;
- if ($self->{too_complex}) {
- $self->trace(title=>"iterate:backtrack") if $TRACE;
- $set = $self->_function( 'iterate', $callback, @_ );
- }
- else
- {
- $self->trace(title=>"iterate") if $TRACE;
- $set = $self->SUPER::iterate( $callback, @_ );
- }
- $set->{backtrack_callback} = $backtrack_callback;
- # warn "set backtrack_callback" if defined $backtrack_callback;
- return $set;
-}
-
-
-sub intersection {
- my $a1 = shift;
- my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
-
- $a1->trace_open(title=>"intersection", arg => $b1) if $TRACE;
- if (($a1->{too_complex}) or ($b1->{too_complex})) {
- my $arg0 = $a1->_quantize_span;
- my $arg1 = $b1->_quantize_span;
- unless (($arg0->{too_complex}) or ($arg1->{too_complex})) {
- my $res = $arg0->intersection( $arg1 );
- $a1->trace_close( arg => $res ) if $TRACE;
- return $res;
- }
- }
- if ($a1->{too_complex}) {
- $a1 = $a1->_backtrack('intersection', $b1) unless $b1->{too_complex};
- } # don't put 'else' here
- if ($b1->{too_complex}) {
- $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
- }
- if ( $a1->{too_complex} || $b1->{too_complex} ) {
- $a1->trace_close( ) if $TRACE;
- return $a1->_function2( 'intersection', $b1 );
- }
- return $a1->SUPER::intersection( $b1 );
-}
-
-
-sub intersected_spans {
- my $a1 = shift;
- my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
-
- if ($a1->{too_complex}) {
- $a1 = $a1->_backtrack('intersection', $b1 ) unless $b1->{too_complex};
- } # don't put 'else' here
- if ($b1->{too_complex}) {
- $b1 = $b1->_backtrack('intersection', $a1) unless $a1->{too_complex};
- }
-
- if ( ! $b1->{too_complex} && ! $a1->{too_complex} )
- {
- return $a1->SUPER::intersected_spans ( $b1 );
- }
-
- return $b1->iterate(
- sub {
- my $tmp = $a1->intersection( $_[0] );
- return $tmp unless defined $tmp->max;
-
- my $before = $a1->intersection( $neg_inf, $tmp->min )->last;
- my $after = $a1->intersection( $tmp->max, $inf )->first;
-
- $before = $tmp->union( $before )->first;
- $after = $tmp->union( $after )->last;
-
- $tmp = $tmp->union( $before )
- if defined $before && $tmp->intersects( $before );
- $tmp = $tmp->union( $after )
- if defined $after && $tmp->intersects( $after );
- return $tmp;
- }
- );
-
-}
-
-
-sub complement {
- my $a1 = shift;
- # do we have a parameter?
- if (@_) {
- my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
-
- $a1->trace_open(title=>"complement", arg => $b1) if $TRACE;
- $b1 = $b1->complement;
- my $tmp =$a1->intersection($b1);
- $a1->trace_close( arg => $tmp ) if $TRACE;
- return $tmp;
- }
- $a1->trace_open(title=>"complement") if $TRACE;
- if ($a1->{too_complex}) {
- $a1->trace_close( ) if $TRACE;
- return $a1->_function( 'complement', @_ );
- }
- return $a1->SUPER::complement;
-}
-
-
-sub until {
- my $a1 = shift;
- my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
-
- if (($a1->{too_complex}) or ($b1->{too_complex})) {
- return $a1->_function2( 'until', $b1 );
- }
- return $a1->SUPER::until( $b1 );
-}
-
-
-sub union {
- my $a1 = shift;
- my $b1 = (ref ($_[0]) eq ref($a1) ) ? shift : $a1->new(@_);
-
- $a1->trace_open(title=>"union", arg => $b1) if $TRACE;
- if (($a1->{too_complex}) or ($b1->{too_complex})) {
- $a1->trace_close( ) if $TRACE;
- return $a1 if $b1->is_null;
- return $b1 if $a1->is_null;
- return $a1->_function2( 'union', $b1);
- }
- return $a1->SUPER::union( $b1 );
-}
-
-
-# there are some ways to process 'contains':
-# A CONTAINS B IF A == ( A UNION B )
-# - faster
-# A CONTAINS B IF B == ( A INTERSECTION B )
-# - can backtrack = works for unbounded sets
-sub contains {
- my $a1 = shift;
- $a1->trace_open(title=>"contains") if $TRACE;
- if ( $a1->{too_complex} ) {
- # we use intersection because it is better for backtracking
- my $b0 = (ref $_[0] eq ref $a1) ? shift : $a1->new(@_);
- my $b1 = $a1->intersection($b0);
- if ( $b1->{too_complex} ) {
- $b1->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
- $a1->trace_close( arg => ($b1 == $b0 ? 1 : 0) ) if $TRACE;
- return ($b1 == $b0) ? 1 : 0;
- }
- my $b1 = $a1->union(@_);
- if ( $b1->{too_complex} ) {
- $b1->trace_close( arg => 'undef' ) if $TRACE;
- return undef;
- }
- $a1->trace_close( arg => ($b1 == $a1 ? 1 : 0) ) if $TRACE;
- return ($b1 == $a1) ? 1 : 0;
-}
-
-
-sub min_a {
- my $self = $_[0];
- return @{$self->{min}} if exists $self->{min};
- if ($self->{too_complex}) {
- my @first = $self->first;
- return @{$self->{min}} = $first[0]->min_a if defined $first[0];
- return @{$self->{min}} = (undef, 0);
- }
- return $self->SUPER::min_a;
-};
-
-
-sub max_a {
- my $self = $_[0];
- return @{$self->{max}} if exists $self->{max};
- if ($self->{too_complex}) {
- my @last = $self->last;
- return @{$self->{max}} = $last[0]->max_a if defined $last[0];
- return @{$self->{max}} = (undef, 0);
- }
- return $self->SUPER::max_a;
-};
-
-
-sub count {
- my $self = $_[0];
- # NOTE: subclasses may return "undef" if necessary
- return $inf if $self->{too_complex};
- return $self->SUPER::count;
-}
-
-
-sub size {
- my $self = $_[0];
- if ($self->{too_complex}) {
- my @min = $self->min_a;
- my @max = $self->max_a;
- return undef unless defined $max[0] && defined $min[0];
- return $max[0] - $min[0];
- }
- return $self->SUPER::size;
-};
-
-
-sub spaceship {
- my ($tmp1, $tmp2, $inverted) = @_;
- carp "Can't compare unbounded sets"
- if $tmp1->{too_complex} or $tmp2->{too_complex};
- return $tmp1->SUPER::spaceship( $tmp2, $inverted );
-}
-
-
-sub _cleanup { @_ } # this subroutine is obsolete
-
-
-sub tolerance {
- my $self = shift;
- my $tmp = pop;
- if (ref($self)) {
- # local
- return $self->{tolerance} unless defined $tmp;
- if ($self->{too_complex}) {
- my $b1 = $self->_function( 'tolerance', $tmp );
- $b1->{tolerance} = $tmp; # for max/min processing
- return $b1;
- }
- return $self->SUPER::tolerance( $tmp );
- }
- # class method
- __PACKAGE__->SUPER::tolerance( $tmp ) if defined($tmp);
- return __PACKAGE__->SUPER::tolerance;
-}
-
-
-sub _pretty_print {
- my $self = shift;
- return "$self" unless $self->{too_complex};
- return $self->{method} . "( " .
- ( ref($self->{parent}) eq 'ARRAY' ?
- $self->{parent}[0] . ' ; ' . $self->{parent}[1] :
- $self->{parent} ) .
- " )";
-}
-
-
-sub as_string {
- my $self = shift;
- return ( $PRETTY_PRINT ? $self->_pretty_print : $too_complex )
- if $self->{too_complex};
- return $self->SUPER::as_string;
-}
-
-
-sub DESTROY {}
-
-1;
-
-__END__
-
-
-=head1 NAME
-
-Set::Infinite - Sets of intervals
-
-
-=head1 SYNOPSIS
-
- use Set::Infinite;
-
- $set = Set::Infinite->new(1,2); # [1..2]
- print $set->union(5,6); # [1..2],[5..6]
-
-
-=head1 DESCRIPTION
-
-Set::Infinite is a Set Theory module for infinite sets.
-
-A set is a collection of objects.
-The objects that belong to a set are called its members, or "elements".
-
-As objects we allow (almost) anything: reals, integers, and objects (such as dates).
-
-We allow sets to be infinite.
-
-There is no account for the order of elements. For example, {1,2} = {2,1}.
-
-There is no account for repetition of elements. For example, {1,2,2} = {1,1,1,2} = {1,2}.
-
-=head1 CONSTRUCTOR
-
-=head2 new
-
-Creates a new set object:
-
- $set = Set::Infinite->new; # empty set
- $set = Set::Infinite->new( 10 ); # single element
- $set = Set::Infinite->new( 10, 20 ); # single range
- $set = Set::Infinite->new(
- [ 10, 20 ], [ 50, 70 ] ); # two ranges
-
-=over 4
-
-=item empty set
-
- $set = Set::Infinite->new;
-
-=item set with a single element
-
- $set = Set::Infinite->new( 10 );
-
- $set = Set::Infinite->new( [ 10 ] );
-
-=item set with a single span
-
- $set = Set::Infinite->new( 10, 20 );
-
- $set = Set::Infinite->new( [ 10, 20 ] );
- # 10 <= x <= 20
-
-=item set with a single, open span
-
- $set = Set::Infinite->new(
- {
- a => 10, open_begin => 0,
- b => 20, open_end => 1,
- }
- );
- # 10 <= x < 20
-
-=item set with multiple spans
-
- $set = Set::Infinite->new( 10, 20, 100, 200 );
-
- $set = Set::Infinite->new( [ 10, 20 ], [ 100, 200 ] );
-
- $set = Set::Infinite->new(
- {
- a => 10, open_begin => 0,
- b => 20, open_end => 0,
- },
- {
- a => 100, open_begin => 0,
- b => 200, open_end => 0,
- }
- );
-
-=back
-
-The C<new()> method expects I<ordered> parameters.
-
-If you have unordered ranges, you can build the set using C<union>:
-
- @ranges = ( [ 10, 20 ], [ -10, 1 ] );
- $set = Set::Infinite->new;
- $set = $set->union( @$_ ) for @ranges;
-
-The data structures passed to C<new> must be I<immutable>.
-So this is not good practice:
-
- $set = Set::Infinite->new( $object_a, $object_b );
- $object_a->set_value( 10 );
-
-This is the recommended way to do it:
-
- $set = Set::Infinite->new( $object_a->clone, $object_b->clone );
- $object_a->set_value( 10 );
-
-
-=head2 clone / copy
-
-Creates a new object, and copy the object data.
-
-=head2 empty_set
-
-Creates an empty set.
-
-If called from an existing set, the empty set inherits
-the "type" and "density" characteristics.
-
-=head2 universal_set
-
-Creates a set containing "all" possible elements.
-
-If called from an existing set, the universal set inherits
-the "type" and "density" characteristics.
-
-=head1 SET FUNCTIONS
-
-=head2 union
-
- $set = $set->union($b);
-
-Returns the set of all elements from both sets.
-
-This function behaves like an "OR" operation.
-
- $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
- $set2 = new Set::Infinite( [ 7, 20 ] );
- print $set1->union( $set2 );
- # output: [1..4],[7..20]
-
-=head2 intersection
-
- $set = $set->intersection($b);
-
-Returns the set of elements common to both sets.
-
-This function behaves like an "AND" operation.
-
- $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
- $set2 = new Set::Infinite( [ 7, 20 ] );
- print $set1->intersection( $set2 );
- # output: [8..12]
-
-=head2 complement
-
-=head2 minus
-
-=head2 difference
-
- $set = $set->complement;
-
-Returns the set of all elements that don't belong to the set.
-
- $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
- print $set1->complement;
- # output: (-inf..1),(4..8),(12..inf)
-
-The complement function might take a parameter:
-
- $set = $set->minus($b);
-
-Returns the set-difference, that is, the elements that don't
-belong to the given set.
-
- $set1 = new Set::Infinite( [ 1, 4 ], [ 8, 12 ] );
- $set2 = new Set::Infinite( [ 7, 20 ] );
- print $set1->minus( $set2 );
- # output: [1..4]
-
-=head2 symmetric_difference
-
-Returns a set containing elements that are in either set,
-but not in both. This is the "set" version of "XOR".
-
-=head1 DENSITY METHODS
-
-=head2 real
-
- $set1 = $set->real;
-
-Returns a set with density "0".
-
-=head2 integer
-
- $set1 = $set->integer;
-
-Returns a set with density "1".
-
-=head1 LOGIC FUNCTIONS
-
-=head2 intersects
-
- $logic = $set->intersects($b);
-
-=head2 contains
-
- $logic = $set->contains($b);
-
-=head2 is_empty
-
-=head2 is_null
-
- $logic = $set->is_null;
-
-=head2 is_nonempty
-
-This set that has at least 1 element.
-
-=head2 is_span
-
-This set that has a single span or interval.
-
-=head2 is_singleton
-
-This set that has a single element.
-
-=head2 is_subset( $set )
-
-Every element of this set is a member of the given set.
-
-=head2 is_proper_subset( $set )
-
-Every element of this set is a member of the given set.
-Some members of the given set are not elements of this set.
-
-=head2 is_disjoint( $set )
-
-The given set has no elements in common with this set.
-
-=head2 is_too_complex
-
-Sometimes a set might be too complex to enumerate or print.
-
-This happens with sets that represent infinite recurrences, such as
-when you ask for a quantization on a
-set bounded by -inf or inf.
-
-See also: C<count> method.
-
-=head1 SCALAR FUNCTIONS
-
-=head2 min
-
- $i = $set->min;
-
-=head2 max
-
- $i = $set->max;
-
-=head2 size
-
- $i = $set->size;
-
-=head2 count
-
- $i = $set->count;
-
-=head1 OVERLOADED OPERATORS
-
-=head2 stringification
-
- print $set;
-
- $str = "$set";
-
-See also: C<as_string>.
-
-=head2 comparison
-
- sort
-
- > < == >= <= <=>
-
-See also: C<spaceship> method.
-
-=head1 CLASS METHODS
-
- Set::Infinite->separators(@i)
-
- chooses the interval separators for stringification.
-
- default are [ ] ( ) '..' ','.
-
- inf
-
- returns an 'Infinity' number.
-
- minus_inf
-
- returns '-Infinity' number.
-
-=head2 type
-
- type( "My::Class::Name" )
-
-Chooses a default object data type.
-
-Default is none (a normal Perl SCALAR).
-
-
-=head1 SPECIAL SET FUNCTIONS
-
-=head2 span
-
- $set1 = $set->span;
-
-Returns the set span.
-
-=head2 until
-
-Extends a set until another:
-
- 0,5,7 -> until 2,6,10
-
-gives
-
- [0..2), [5..6), [7..10)
-
-=head2 start_set
-
-=head2 end_set
-
-These methods do the inverse of the "until" method.
-
-Given:
-
- [0..2), [5..6), [7..10)
-
-start_set is:
-
- 0,5,7
-
-end_set is:
-
- 2,6,10
-
-=head2 intersected_spans
-
- $set = $set1->intersected_spans( $set2 );
-
-The method returns a new set,
-containing all spans that are intersected by the given set.
-
-Unlike the C<intersection> method, the spans are not modified.
-See diagram below:
-
- set1 [....] [....] [....] [....]
- set2 [................]
-
- intersection [.] [....] [.]
-
- intersected_spans [....] [....] [....]
-
-
-=head2 quantize
-
- quantize( parameters )
-
- Makes equal-sized subsets.
-
- Returns an ordered set of equal-sized subsets.
-
- Example:
-
- $set = Set::Infinite->new([1,3]);
- print join (" ", $set->quantize( quant => 1 ) );
-
- Gives:
-
- [1..2) [2..3) [3..4)
-
-=head2 select
-
- select( parameters )
-
-Selects set spans based on their ordered positions
-
-C<select> has a behaviour similar to an array C<slice>.
-
- by - default=All
- count - default=Infinity
-
- 0 1 2 3 4 5 6 7 8 # original set
- 0 1 2 # count => 3
- 1 6 # by => [ -2, 1 ]
-
-=head2 offset
-
- offset ( parameters )
-
-Offsets the subsets. Parameters:
-
- value - default=[0,0]
- mode - default='offset'. Possible values are: 'offset', 'begin', 'end'.
- unit - type of value. Can be 'days', 'weeks', 'hours', 'minutes', 'seconds'.
-
-=head2 iterate
-
- iterate ( sub { } , @args )
-
-Iterates on the set spans, over a callback subroutine.
-Returns the union of all partial results.
-
-The callback argument C<$_[0]> is a span. If there are additional arguments they are passed to the callback.
-
-The callback can return a span, a hashref (see C<Set::Infinite::Basic>), a scalar, an object, or C<undef>.
-
-[EXPERIMENTAL]
-C<iterate> accepts an optional C<backtrack_callback> argument.
-The purpose of the C<backtrack_callback> is to I<reverse> the
-iterate() function, overcoming the limitations of the internal
-backtracking algorithm.
-The syntax is:
-
- iterate ( sub { } , backtrack_callback => sub { }, @args )
-
-The C<backtrack_callback> can return a span, a hashref, a scalar,
-an object, or C<undef>.
-
-For example, the following snippet adds a constant to each
-element of an unbounded set:
-
- $set1 = $set->iterate(
- sub { $_[0]->min + 54, $_[0]->max + 54 },
- backtrack_callback =>
- sub { $_[0]->min - 54, $_[0]->max - 54 },
- );
-
-=head2 first / last
-
- first / last
-
-In scalar context returns the first or last interval of a set.
-
-In list context returns the first or last interval of a set,
-and the remaining set (the 'tail').
-
-See also: C<min>, C<max>, C<min_a>, C<max_a> methods.
-
-=head2 type
-
- type( "My::Class::Name" )
-
-Chooses a default object data type.
-
-default is none (a normal perl SCALAR).
-
-
-=head1 INTERNAL FUNCTIONS
-
-=head2 _backtrack
-
- $set->_backtrack( 'intersection', $b );
-
-Internal function to evaluate recurrences.
-
-=head2 numeric
-
- $set->numeric;
-
-Internal function to ignore the set "type".
-It is used in some internal optimizations, when it is
-possible to use scalar values instead of objects.
-
-=head2 fixtype
-
- $set->fixtype;
-
-Internal function to fix the result of operations
-that use the numeric() function.
-
-=head2 tolerance
-
- $set = $set->tolerance(0) # defaults to real sets (default)
- $set = $set->tolerance(1) # defaults to integer sets
-
-Internal function for changing the set "density".
-
-=head2 min_a
-
- ($min, $min_is_open) = $set->min_a;
-
-=head2 max_a
-
- ($max, $max_is_open) = $set->max_a;
-
-
-=head2 as_string
-
-Implements the "stringification" operator.
-
-Stringification of unbounded recurrences is not implemented.
-
-Unbounded recurrences are stringified as "function descriptions",
-if the class variable $PRETTY_PRINT is set.
-
-=head2 spaceship
-
-Implements the "comparison" operator.
-
-Comparison of unbounded recurrences is not implemented.
-
-
-=head1 CAVEATS
-
-=over 4
-
-=item * constructor "span" notation
-
- $set = Set::Infinite->new(10,1);
-
-Will be interpreted as [1..10]
-
-=item * constructor "multiple-span" notation
-
- $set = Set::Infinite->new(1,2,3,4);
-
-Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
-You probably want ->new([1],[2],[3],[4]) instead,
-or maybe ->new(1,4)
-
-=item * "range operator"
-
- $set = Set::Infinite->new(1..3);
-
-Will be interpreted as [1..2],3 instead of [1,2,3].
-You probably want ->new(1,3) instead.
-
-=back
-
-=head1 INTERNALS
-
-The base I<set> object, without recurrences, is a C<Set::Infinite::Basic>.
-
-A I<recurrence-set> is represented by a I<method name>,
-one or two I<parent objects>, and extra arguments.
-The C<list> key is set to an empty array, and the
-C<too_complex> key is set to C<1>.
-
-This is a structure that holds the union of two "complex sets":
-
- {
- too_complex => 1, # "this is a recurrence"
- list => [ ], # not used
- method => 'union', # function name
- parent => [ $set1, $set2 ], # "leaves" in the syntax-tree
- param => [ ] # optional arguments for the function
- }
-
-This is a structure that holds the complement of a "complex set":
-
- {
- too_complex => 1, # "this is a recurrence"
- list => [ ], # not used
- method => 'complement', # function name
- parent => $set, # "leaf" in the syntax-tree
- param => [ ] # optional arguments for the function
- }
-
-
-=head1 SEE ALSO
-
-See modules DateTime::Set, DateTime::Event::Recurrence,
-DateTime::Event::ICal, DateTime::Event::Cron
-for up-to-date information on date-sets.
-
-The perl-date-time project <http://datetime.perl.org>
-
-
-=head1 AUTHOR
-
-Flavio S. Glock <fglock@gmail.com>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-The full text of the license can be found in the LICENSE file included
-with this module.
-
-=cut
-
+++ /dev/null
-package Set::Infinite::Arithmetic;
-# Copyright (c) 2001 Flavio Soibelmann Glock. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-use strict;
-# use warnings;
-require Exporter;
-use Carp;
-use Time::Local;
-use POSIX qw(floor);
-
-use vars qw( @EXPORT @EXPORT_OK $inf );
-
-@EXPORT = qw();
-@EXPORT_OK = qw();
-# @EXPORT_OK = qw( %subs_offset2 %Offset_to_value %Value_to_offset %Init_quantizer );
-
-$inf = 100**100**100; # $Set::Infinite::inf; doesn't work! (why?)
-
-=head2 NAME
-
-Set::Infinite::Arithmetic - Scalar operations used by quantize() and offset()
-
-=head2 AUTHOR
-
-Flavio Soibelmann Glock - fglock@pucrs.br
-
-=cut
-
-use vars qw( $day_size $hour_size $minute_size $second_size );
-$day_size = timegm(0,0,0,2,3,2001) - timegm(0,0,0,1,3,2001);
-$hour_size = $day_size / 24;
-$minute_size = $hour_size / 60;
-$second_size = $minute_size / 60;
-
-use vars qw( %_MODE %subs_offset2 %Offset_to_value @week_start %Init_quantizer %Value_to_offset %Offset_to_value );
-
-=head2 %_MODE hash of subs
-
- $a->offset ( value => [1,2], mode => 'offset', unit => 'days' );
-
- $a->offset ( value => [1,2, -5,-4], mode => 'offset', unit => 'days' );
-
-note: if mode = circle, then "-5" counts from end (like a Perl negative array index).
-
- $a->offset ( value => [1,2], mode => 'offset', unit => 'days', strict => $a );
-
-option 'strict' will return intersection($a,offset). Default: none.
-
-=cut
-
-# return value = ($this, $next, $cmp)
-%_MODE = (
- circle => sub {
- if ($_[3] >= 0) {
- &{ $_[0] } ($_[1], $_[3], $_[4] )
- }
- else {
- &{ $_[0] } ($_[2], $_[3], $_[4] )
- }
- },
- begin => sub { &{ $_[0] } ($_[1], $_[3], $_[4] ) },
- end => sub { &{ $_[0] } ($_[2], $_[3], $_[4] ) },
- offset => sub {
- my ($this, undef) = &{ $_[0] } ($_[1], $_[3], $_[4] );
- my (undef, $next) = &{ $_[0] } ($_[2], $_[3], $_[4] );
- ($this, $next);
- }
-);
-
-
-=head2 %subs_offset2($object, $offset1, $offset2)
-
- &{ $subs_offset2{$unit} } ($object, $offset1, $offset2);
-
-A hash of functions that return:
-
- ($object+$offset1, $object+$offset2)
-
-in $unit context.
-
-Returned $object+$offset1, $object+$offset2 may be scalars or objects.
-
-=cut
-
-%subs_offset2 = (
- weekdays => sub {
- # offsets to week-day specified
- # 0 = first sunday from today (or today if today is sunday)
- # 1 = first monday from today (or today if today is monday)
- # 6 = first friday from today (or today if today is friday)
- # 13 = second friday from today
- # -1 = last saturday from today (not today, even if today were saturday)
- # -2 = last friday
- my ($self, $index1, $index2) = @_;
- return ($self, $self) if $self == $inf;
- # my $class = ref($self);
- my @date = gmtime( $self );
- my $wday = $date[6];
- my ($tmp1, $tmp2);
-
- $tmp1 = $index1 - $wday;
- if ($index1 >= 0) {
- $tmp1 += 7 if $tmp1 < 0; # it will only happen next week
- }
- else {
- $tmp1 += 7 if $tmp1 < -7; # if will happen this week
- }
-
- $tmp2 = $index2 - $wday;
- if ($index2 >= 0) {
- $tmp2 += 7 if $tmp2 < 0; # it will only happen next week
- }
- else {
- $tmp2 += 7 if $tmp2 < -7; # if will happen this week
- }
-
- # print " [ OFS:weekday $self $tmp1 $tmp2 ] \n";
- # $date[3] += $tmp1;
- $tmp1 = $self + $tmp1 * $day_size;
- # $date[3] += $tmp2 - $tmp1;
- $tmp2 = $self + $tmp2 * $day_size;
-
- ($tmp1, $tmp2);
- },
- years => sub {
- my ($self, $index, $index2) = @_;
- return ($self, $self) if $self == $inf;
- # my $class = ref($self);
- # print " [ofs:year:$self -- $index]\n";
- my @date = gmtime( $self );
- $date[5] += 1900 + $index;
- my $tmp = timegm(@date);
-
- $date[5] += $index2 - $index;
- my $tmp2 = timegm(@date);
-
- ($tmp, $tmp2);
- },
- months => sub {
- my ($self, $index, $index2) = @_;
- # carp " [ofs:month:$self -- $index -- $inf]";
- return ($self, $self) if $self == $inf;
- # my $class = ref($self);
- my @date = gmtime( $self );
-
- my $mon = $date[4] + $index;
- my $year = $date[5] + 1900;
- # print " [OFS: month: from $year$mon ]\n";
- if (($mon > 11) or ($mon < 0)) {
- my $addyear = floor($mon / 12);
- $mon = $mon - 12 * $addyear;
- $year += $addyear;
- }
-
- my $mon2 = $date[4] + $index2;
- my $year2 = $date[5] + 1900;
- if (($mon2 > 11) or ($mon2 < 0)) {
- my $addyear2 = floor($mon2 / 12);
- $mon2 = $mon2 - 12 * $addyear2;
- $year2 += $addyear2;
- }
-
- # print " [OFS: month: to $year $mon ]\n";
-
- $date[4] = $mon;
- $date[5] = $year;
- my $tmp = timegm(@date);
-
- $date[4] = $mon2;
- $date[5] = $year2;
- my $tmp2 = timegm(@date);
-
- ($tmp, $tmp2);
- },
- days => sub {
- ( $_[0] + $_[1] * $day_size,
- $_[0] + $_[2] * $day_size,
- )
- },
- weeks => sub {
- ( $_[0] + $_[1] * (7 * $day_size),
- $_[0] + $_[2] * (7 * $day_size),
- )
- },
- hours => sub {
- # carp " [ $_[0]+$_[1] hour = ".( $_[0] + $_[1] * $hour_size )." mode=".($_[0]->{mode})." ]";
- ( $_[0] + $_[1] * $hour_size,
- $_[0] + $_[2] * $hour_size,
- )
- },
- minutes => sub {
- ( $_[0] + $_[1] * $minute_size,
- $_[0] + $_[2] * $minute_size,
- )
- },
- seconds => sub {
- ( $_[0] + $_[1] * $second_size,
- $_[0] + $_[2] * $second_size,
- )
- },
- one => sub {
- ( $_[0] + $_[1],
- $_[0] + $_[2],
- )
- },
-);
-
-
-@week_start = ( 0, -1, -2, -3, 3, 2, 1, 0, -1, -2, -3, 3, 2, 1, 0 );
-
-=head2 %Offset_to_value($object, $offset)
-
-=head2 %Init_quantizer($object)
-
- $Offset_to_value{$unit} ($object, $offset);
-
- $Init_quantizer{$unit} ($object);
-
-Maps an 'offset value' to a 'value'
-
-A hash of functions that return ( int($object) + $offset ) in $unit context.
-
-Init_quantizer subroutines must be called before using subs_offset1 functions.
-
-int(object)+offset is a scalar.
-
-Offset_to_value is optimized for calling it multiple times on the same object,
-with different offsets. That's why there is a separate initialization
-subroutine.
-
-$self->{offset} is created on initialization. It is an index used
-by the memoization cache.
-
-=cut
-
-%Offset_to_value = (
- weekyears => sub {
- my ($self, $index) = @_;
- my $epoch = timegm( 0,0,0,
- 1,0,$self->{offset} + $self->{quant} * $index);
- my @time = gmtime($epoch);
- # print " [QT_D:weekyears:$self->{offset} + $self->{quant} * $index]\n";
- # year modulo week
- # print " [QT:weekyears: time = ",join(";", @time )," ]\n";
- $epoch += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
- # print " [QT:weekyears: week=",join(";", gmtime($epoch) )," wkst=$self->{wkst} tbl[",$time[6] + 7 - $self->{wkst},"]=",$week_start[$time[6] + 7 - $self->{wkst}]," ]\n\n";
-
- my $epoch2 = timegm( 0,0,0,
- 1,0,$self->{offset} + $self->{quant} * (1 + $index) );
- @time = gmtime($epoch2);
- $epoch2 += ( $week_start[$time[6] + 7 - $self->{wkst}] ) * $day_size;
- ( $epoch, $epoch2 );
- },
- years => sub {
- my $index = $_[0]->{offset} + $_[0]->{quant} * $_[1];
- ( timegm( 0,0,0, 1, 0, $index),
- timegm( 0,0,0, 1, 0, $index + $_[0]->{quant}) )
- },
- months => sub {
- my $mon = $_[0]->{offset} + $_[0]->{quant} * $_[1];
- my $year = int($mon / 12);
- $mon -= $year * 12;
- my $tmp = timegm( 0,0,0, 1, $mon, $year);
-
- $mon += $year * 12 + $_[0]->{quant};
- $year = int($mon / 12);
- $mon -= $year * 12;
- ( $tmp, timegm( 0,0,0, 1, $mon, $year) );
- },
- weeks => sub {
- my $tmp = 3 * $day_size + $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
- ($tmp, $tmp + $_[0]->{quant})
- },
- days => sub {
- my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
- ($tmp, $tmp + $_[0]->{quant})
- },
- hours => sub {
- my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
- ($tmp, $tmp + $_[0]->{quant})
- },
- minutes => sub {
- my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
- ($tmp, $tmp + $_[0]->{quant})
- },
- seconds => sub {
- my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
- ($tmp, $tmp + $_[0]->{quant})
- },
- one => sub {
- my $tmp = $_[0]->{quant} * ($_[0]->{offset} + $_[1]);
- ($tmp, $tmp + $_[0]->{quant})
- },
-);
-
-
-# Maps an 'offset value' to a 'value'
-
-%Value_to_offset = (
- one => sub { floor( $_[1] / $_[0]{quant} ) },
- seconds => sub { floor( $_[1] / $_[0]{quant} ) },
- minutes => sub { floor( $_[1] / $_[0]{quant} ) },
- hours => sub { floor( $_[1] / $_[0]{quant} ) },
- days => sub { floor( $_[1] / $_[0]{quant} ) },
- weeks => sub { floor( ($_[1] - 3 * $day_size) / $_[0]{quant} ) },
- months => sub {
- my @date = gmtime( 0 + $_[1] );
- my $tmp = $date[4] + 12 * (1900 + $date[5]);
- floor( $tmp / $_[0]{quant} );
- },
- years => sub {
- my @date = gmtime( 0 + $_[1] );
- my $tmp = $date[5] + 1900;
- floor( $tmp / $_[0]{quant} );
- },
- weekyears => sub {
-
- my ($self, $value) = @_;
- my @date;
-
- # find out YEAR number
- @date = gmtime( 0 + $value );
- my $year = floor( $date[5] + 1900 / $self->{quant} );
-
- # what is the EPOCH for this week-year's begin ?
- my $begin_epoch = timegm( 0,0,0, 1,0,$year);
- @date = gmtime($begin_epoch);
- $begin_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
-
- # what is the EPOCH for this week-year's end ?
- my $end_epoch = timegm( 0,0,0, 1,0,$year+1);
- @date = gmtime($end_epoch);
- $end_epoch += ( $week_start[$date[6] + 7 - $self->{wkst}] ) * $day_size;
-
- $year-- if $value < $begin_epoch;
- $year++ if $value >= $end_epoch;
-
- # carp " value=$value offset=$year this_epoch=".$begin_epoch;
- # carp " next_epoch=".$end_epoch;
-
- $year;
- },
-);
-
-# Initialize quantizer
-
-%Init_quantizer = (
- one => sub {},
- seconds => sub { $_[0]->{quant} *= $second_size },
- minutes => sub { $_[0]->{quant} *= $minute_size },
- hours => sub { $_[0]->{quant} *= $hour_size },
- days => sub { $_[0]->{quant} *= $day_size },
- weeks => sub { $_[0]->{quant} *= 7 * $day_size },
- months => sub {},
- years => sub {},
- weekyears => sub {
- $_[0]->{wkst} = 1 unless defined $_[0]->{wkst};
- # select which 'cache' to use
- # $_[0]->{memo} .= $_[0]->{wkst};
- },
-);
-
-
-1;
-
+++ /dev/null
-package Set::Infinite::Basic;
-
-# Copyright (c) 2001, 2002, 2003 Flavio Soibelmann Glock. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-require 5.005_03;
-use strict;
-
-require Exporter;
-use Carp;
-use Data::Dumper;
-use vars qw( @ISA @EXPORT_OK @EXPORT );
-use vars qw( $Type $tolerance $fixtype $inf $minus_inf @Separators $neg_inf );
-
-@ISA = qw(Exporter);
-@EXPORT_OK = qw( INFINITY NEG_INFINITY );
-@EXPORT = qw();
-
-use constant INFINITY => 100**100**100;
-use constant NEG_INFINITY => - INFINITY;
-
-$inf = INFINITY;
-$minus_inf = $neg_inf = NEG_INFINITY;
-
-use overload
- '<=>' => \&spaceship,
- qw("" as_string),
-;
-
-
-# TODO: make this an object _and_ class method
-# TODO: POD
-sub separators {
- shift;
- return $Separators[ $_[0] ] if $#_ == 0;
- @Separators = @_ if @_;
- return @Separators;
-}
-
-BEGIN {
- __PACKAGE__->separators (
- '[', ']', # a closed interval
- '(', ')', # an open interval
- '..', # number separator
- ',', # list separator
- '', '', # set delimiter '{' '}'
- );
- # global defaults for object private vars
- $Type = undef;
- $tolerance = 0;
- $fixtype = 1;
-}
-
-# _simple_* set of internal methods: basic processing of "spans"
-
-sub _simple_intersects {
- my $tmp1 = $_[0];
- my $tmp2 = $_[1];
- my ($i_beg, $i_end, $open_beg, $open_end);
- my $cmp = $tmp1->{a} <=> $tmp2->{a};
- if ($cmp < 0) {
- $i_beg = $tmp2->{a};
- $open_beg = $tmp2->{open_begin};
- }
- elsif ($cmp > 0) {
- $i_beg = $tmp1->{a};
- $open_beg = $tmp1->{open_begin};
- }
- else {
- $i_beg = $tmp1->{a};
- $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
- }
- $cmp = $tmp1->{b} <=> $tmp2->{b};
- if ($cmp > 0) {
- $i_end = $tmp2->{b};
- $open_end = $tmp2->{open_end};
- }
- elsif ($cmp < 0) {
- $i_end = $tmp1->{b};
- $open_end = $tmp1->{open_end};
- }
- else {
- $i_end = $tmp1->{b};
- $open_end = ($tmp1->{open_end} || $tmp2->{open_end});
- }
- $cmp = $i_beg <=> $i_end;
- return 0 if
- ( $cmp > 0 ) ||
- ( ($cmp == 0) && ($open_beg || $open_end) ) ;
- return 1;
-}
-
-
-sub _simple_complement {
- my $self = $_[0];
- if ($self->{b} == $inf) {
- return if $self->{a} == $neg_inf;
- return { a => $neg_inf,
- b => $self->{a},
- open_begin => 1,
- open_end => ! $self->{open_begin} };
- }
- if ($self->{a} == $neg_inf) {
- return { a => $self->{b},
- b => $inf,
- open_begin => ! $self->{open_end},
- open_end => 1 };
- }
- ( { a => $neg_inf,
- b => $self->{a},
- open_begin => 1,
- open_end => ! $self->{open_begin}
- },
- { a => $self->{b},
- b => $inf,
- open_begin => ! $self->{open_end},
- open_end => 1
- }
- );
-}
-
-sub _simple_union {
- my ($tmp2, $tmp1, $tolerance) = @_;
- my $cmp;
- if ($tolerance) {
- # "integer"
- my $a1_open = $tmp1->{open_begin} ? -$tolerance : $tolerance ;
- my $b1_open = $tmp1->{open_end} ? -$tolerance : $tolerance ;
- my $a2_open = $tmp2->{open_begin} ? -$tolerance : $tolerance ;
- my $b2_open = $tmp2->{open_end} ? -$tolerance : $tolerance ;
- # open_end touching?
- if ((($tmp1->{b}+$tmp1->{b}) + $b1_open ) <
- (($tmp2->{a}+$tmp2->{a}) - $a2_open)) {
- # self disjuncts b
- return ( $tmp1, $tmp2 );
- }
- if ((($tmp1->{a}+$tmp1->{a}) - $a1_open ) >
- (($tmp2->{b}+$tmp2->{b}) + $b2_open)) {
- # self disjuncts b
- return ( $tmp2, $tmp1 );
- }
- }
- else {
- # "real"
- $cmp = $tmp1->{b} <=> $tmp2->{a};
- if ( $cmp < 0 ||
- ( $cmp == 0 && $tmp1->{open_end} && $tmp2->{open_begin} ) ) {
- return ( $tmp1, $tmp2 );
- }
- $cmp = $tmp1->{a} <=> $tmp2->{b};
- if ( $cmp > 0 ||
- ( $cmp == 0 && $tmp2->{open_end} && $tmp1->{open_begin} ) ) {
- return ( $tmp2, $tmp1 );
- }
- }
-
- my $tmp;
- $cmp = $tmp1->{a} <=> $tmp2->{a};
- if ($cmp > 0) {
- $tmp->{a} = $tmp2->{a};
- $tmp->{open_begin} = $tmp2->{open_begin};
- }
- elsif ($cmp == 0) {
- $tmp->{a} = $tmp1->{a};
- $tmp->{open_begin} = $tmp1->{open_begin} ? $tmp2->{open_begin} : 0;
- }
- else {
- $tmp->{a} = $tmp1->{a};
- $tmp->{open_begin} = $tmp1->{open_begin};
- }
-
- $cmp = $tmp1->{b} <=> $tmp2->{b};
- if ($cmp < 0) {
- $tmp->{b} = $tmp2->{b};
- $tmp->{open_end} = $tmp2->{open_end};
- }
- elsif ($cmp == 0) {
- $tmp->{b} = $tmp1->{b};
- $tmp->{open_end} = $tmp1->{open_end} ? $tmp2->{open_end} : 0;
- }
- else {
- $tmp->{b} = $tmp1->{b};
- $tmp->{open_end} = $tmp1->{open_end};
- }
- return $tmp;
-}
-
-
-sub _simple_spaceship {
- my ($tmp1, $tmp2, $inverted) = @_;
- my $cmp;
- if ($inverted) {
- $cmp = $tmp2->{a} <=> $tmp1->{a};
- return $cmp if $cmp;
- $cmp = $tmp1->{open_begin} <=> $tmp2->{open_begin};
- return $cmp if $cmp;
- $cmp = $tmp2->{b} <=> $tmp1->{b};
- return $cmp if $cmp;
- return $tmp1->{open_end} <=> $tmp2->{open_end};
- }
- $cmp = $tmp1->{a} <=> $tmp2->{a};
- return $cmp if $cmp;
- $cmp = $tmp2->{open_begin} <=> $tmp1->{open_begin};
- return $cmp if $cmp;
- $cmp = $tmp1->{b} <=> $tmp2->{b};
- return $cmp if $cmp;
- return $tmp2->{open_end} <=> $tmp1->{open_end};
-}
-
-
-sub _simple_new {
- my ($tmp, $tmp2, $type) = @_;
- if ($type) {
- if ( ref($tmp) ne $type ) {
- $tmp = new $type $tmp;
- }
- if ( ref($tmp2) ne $type ) {
- $tmp2 = new $type $tmp2;
- }
- }
- if ($tmp > $tmp2) {
- carp "Invalid interval specification: start value is after end";
- # ($tmp, $tmp2) = ($tmp2, $tmp);
- }
- return { a => $tmp , b => $tmp2 , open_begin => 0 , open_end => 0 };
-}
-
-
-sub _simple_as_string {
- my $set = shift;
- my $self = $_[0];
- my $s;
- return "" unless defined $self;
- $self->{open_begin} = 1 if ($self->{a} == -$inf );
- $self->{open_end} = 1 if ($self->{b} == $inf );
- my $tmp1 = $self->{a};
- $tmp1 = $tmp1->datetime if UNIVERSAL::can( $tmp1, 'datetime' );
- $tmp1 = "$tmp1";
- my $tmp2 = $self->{b};
- $tmp2 = $tmp2->datetime if UNIVERSAL::can( $tmp2, 'datetime' );
- $tmp2 = "$tmp2";
- return $tmp1 if $tmp1 eq $tmp2;
- $s = $self->{open_begin} ? $set->separators(2) : $set->separators(0);
- $s .= $tmp1 . $set->separators(4) . $tmp2;
- $s .= $self->{open_end} ? $set->separators(3) : $set->separators(1);
- return $s;
-}
-
-# end of "_simple_" methods
-
-
-sub type {
- my $self = shift;
- unless (@_) {
- return ref($self) ? $self->{type} : $Type;
- }
- my $tmp_type = shift;
- eval "use " . $tmp_type;
- carp "Warning: can't start $tmp_type : $@" if $@;
- if (ref($self)) {
- $self->{type} = $tmp_type;
- return $self;
- }
- else {
- $Type = $tmp_type;
- return $Type;
- }
-}
-
-sub list {
- my $self = shift;
- my @b = ();
- foreach (@{$self->{list}}) {
- push @b, $self->new($_);
- }
- return @b;
-}
-
-sub fixtype {
- my $self = shift;
- $self = $self->copy;
- $self->{fixtype} = 1;
- my $type = $self->type;
- return $self unless $type;
- foreach (@{$self->{list}}) {
- $_->{a} = $type->new($_->{a}) unless ref($_->{a}) eq $type;
- $_->{b} = $type->new($_->{b}) unless ref($_->{b}) eq $type;
- }
- return $self;
-}
-
-sub numeric {
- my $self = shift;
- return $self unless $self->{fixtype};
- $self = $self->copy;
- $self->{fixtype} = 0;
- foreach (@{$self->{list}}) {
- $_->{a} = 0 + $_->{a};
- $_->{b} = 0 + $_->{b};
- }
- return $self;
-}
-
-sub _no_cleanup { $_[0] } # obsolete
-
-sub first {
- my $self = $_[0];
- if (exists $self->{first} ) {
- return wantarray ? @{$self->{first}} : $self->{first}[0];
- }
- unless ( @{$self->{list}} ) {
- return wantarray ? (undef, 0) : undef;
- }
- my $first = $self->new( $self->{list}[0] );
- return $first unless wantarray;
- my $res = $self->new;
- push @{$res->{list}}, @{$self->{list}}[1 .. $#{$self->{list}}];
- return @{$self->{first}} = ($first) if $res->is_null;
- return @{$self->{first}} = ($first, $res);
-}
-
-sub last {
- my $self = $_[0];
- if (exists $self->{last} ) {
- return wantarray ? @{$self->{last}} : $self->{last}[0];
- }
- unless ( @{$self->{list}} ) {
- return wantarray ? (undef, 0) : undef;
- }
- my $last = $self->new( $self->{list}[-1] );
- return $last unless wantarray;
- my $res = $self->new;
- push @{$res->{list}}, @{$self->{list}}[0 .. $#{$self->{list}}-1];
- return @{$self->{last}} = ($last) if $res->is_null;
- return @{$self->{last}} = ($last, $res);
-}
-
-sub is_null {
- @{$_[0]->{list}} ? 0 : 1;
-}
-
-sub is_empty {
- $_[0]->is_null;
-}
-
-sub is_nonempty {
- ! $_[0]->is_null;
-}
-
-sub is_span {
- ( $#{$_[0]->{list}} == 0 ) ? 1 : 0;
-}
-
-sub is_singleton {
- ( $#{$_[0]->{list}} == 0 &&
- $_[0]->{list}[0]{a} == $_[0]->{list}[0]{b} ) ? 1 : 0;
-}
-
-sub is_subset {
- my $a1 = shift;
- my $b1;
- if (ref ($_[0]) eq ref($a1) ) {
- $b1 = shift;
- }
- else {
- $b1 = $a1->new(@_);
- }
- return $b1->contains( $a1 );
-}
-
-sub is_proper_subset {
- my $a1 = shift;
- my $b1;
- if (ref ($_[0]) eq ref($a1) ) {
- $b1 = shift;
- }
- else {
- $b1 = $a1->new(@_);
- }
-
- my $contains = $b1->contains( $a1 );
- return $contains unless $contains;
-
- my $equal = ( $a1 == $b1 );
- return $equal if !defined $equal || $equal;
-
- return 1;
-}
-
-sub is_disjoint {
- my $intersects = shift->intersects( @_ );
- return ! $intersects if defined $intersects;
- return $intersects;
-}
-
-sub iterate {
- # TODO: options 'no-sort', 'no-merge', 'keep-null' ...
- my $a1 = shift;
- my $iterate = $a1->empty_set();
- my (@tmp, $ia);
- my $subroutine = shift;
- foreach $ia (0 .. $#{$a1->{list}}) {
- @tmp = $subroutine->( $a1->new($a1->{list}[$ia]), @_ );
- $iterate = $iterate->union(@tmp) if @tmp;
- }
- return $iterate;
-}
-
-
-sub intersection {
- my $a1 = shift;
- my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
- return _intersection ( 'intersection', $a1, $b1 );
-}
-
-sub intersects {
- my $a1 = shift;
- my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
- return _intersection ( 'intersects', $a1, $b1 );
-}
-
-sub intersected_spans {
- my $a1 = shift;
- my $b1 = ref ($_[0]) eq ref($a1) ? $_[0] : $a1->new(@_);
- return _intersection ( 'intersected_spans', $a1, $b1 );
-}
-
-
-sub _intersection {
- my ( $op, $a1, $b1 ) = @_;
-
- my $ia;
- my ( $a0, $na ) = ( 0, $#{$a1->{list}} );
- my ( $tmp1, $tmp1a, $tmp2a, $tmp1b, $tmp2b, $i_beg, $i_end, $open_beg, $open_end );
- my ( $cmp1, $cmp2 );
- my @a;
-
- # for-loop optimization (makes little difference)
- # This was kept for backward compatibility with Date::Set tests
- my $self = $a1;
- if ($na < $#{ $b1->{list} })
- {
- $na = $#{ $b1->{list} };
- ($a1, $b1) = ($b1, $a1);
- }
- # ---
-
- B: foreach my $tmp2 ( @{ $b1->{list} } ) {
- $tmp2a = $tmp2->{a};
- $tmp2b = $tmp2->{b};
- A: foreach $ia ($a0 .. $na) {
- $tmp1 = $a1->{list}[$ia];
- $tmp1b = $tmp1->{b};
-
- if ($tmp1b < $tmp2a) {
- $a0++;
- next A;
- }
- $tmp1a = $tmp1->{a};
- if ($tmp1a > $tmp2b) {
- next B;
- }
-
- $cmp1 = $tmp1a <=> $tmp2a;
- if ( $cmp1 < 0 ) {
- $tmp1a = $tmp2a;
- $open_beg = $tmp2->{open_begin};
- }
- elsif ( $cmp1 ) {
- $open_beg = $tmp1->{open_begin};
- }
- else {
- $open_beg = $tmp1->{open_begin} || $tmp2->{open_begin};
- }
-
- $cmp2 = $tmp1b <=> $tmp2b;
- if ( $cmp2 > 0 ) {
- $tmp1b = $tmp2b;
- $open_end = $tmp2->{open_end};
- }
- elsif ( $cmp2 ) {
- $open_end = $tmp1->{open_end};
- }
- else {
- $open_end = $tmp1->{open_end} || $tmp2->{open_end};
- }
-
- if ( ( $tmp1a <= $tmp1b ) &&
- ( ($tmp1a != $tmp1b) ||
- (!$open_beg and !$open_end) ||
- ($tmp1a == $inf) || # XXX
- ($tmp1a == $neg_inf)
- )
- )
- {
- if ( $op eq 'intersection' )
- {
- push @a, {
- a => $tmp1a, b => $tmp1b,
- open_begin => $open_beg, open_end => $open_end } ;
- }
- if ( $op eq 'intersects' )
- {
- return 1;
- }
- if ( $op eq 'intersected_spans' )
- {
- push @a, $tmp1;
- $a0++;
- next A;
- }
- }
- }
- }
-
- return 0 if $op eq 'intersects';
-
- my $intersection = $self->new();
- $intersection->{list} = \@a;
- return $intersection;
-}
-
-
-sub complement {
- my $self = shift;
- if (@_) {
- my $a1;
- if (ref ($_[0]) eq ref($self) ) {
- $a1 = shift;
- }
- else {
- $a1 = $self->new(@_);
- }
- return $self->intersection( $a1->complement );
- }
-
- unless ( @{$self->{list}} ) {
- return $self->universal_set;
- }
- my $complement = $self->empty_set();
- @{$complement->{list}} = _simple_complement($self->{list}[0]);
-
- my $tmp = $self->empty_set();
- foreach my $ia (1 .. $#{$self->{list}}) {
- @{$tmp->{list}} = _simple_complement($self->{list}[$ia]);
- $complement = $complement->intersection($tmp);
- }
- return $complement;
-}
-
-
-sub until {
- my $a1 = shift;
- my $b1;
- if (ref ($_[0]) eq ref($a1) ) {
- $b1 = shift;
- }
- else {
- $b1 = $a1->new(@_);
- }
- my @b1_min = $b1->min_a;
- my @a1_max = $a1->max_a;
-
- unless (defined $b1_min[0]) {
- return $a1->until($inf);
- }
- unless (defined $a1_max[0]) {
- return $a1->new(-$inf)->until($b1);
- }
-
- my ($ia, $ib, $begin, $end);
- $ia = 0;
- $ib = 0;
-
- my $u = $a1->new;
- my $last = -$inf;
- while ( ($ia <= $#{$a1->{list}}) && ($ib <= $#{$b1->{list}})) {
- $begin = $a1->{list}[$ia]{a};
- $end = $b1->{list}[$ib]{b};
- if ( $end <= $begin ) {
- push @{$u->{list}}, {
- a => $last ,
- b => $end ,
- open_begin => 0 ,
- open_end => 1 };
- $ib++;
- $last = $end;
- next;
- }
- push @{$u->{list}}, {
- a => $begin ,
- b => $end ,
- open_begin => 0 ,
- open_end => 1 };
- $ib++;
- $ia++;
- $last = $end;
- }
- if ($ia <= $#{$a1->{list}} &&
- $a1->{list}[$ia]{a} >= $last )
- {
- push @{$u->{list}}, {
- a => $a1->{list}[$ia]{a} ,
- b => $inf ,
- open_begin => 0 ,
- open_end => 1 };
- }
- return $u;
-}
-
-sub start_set {
- return $_[0]->iterate(
- sub { $_[0]->min }
- );
-}
-
-
-sub end_set {
- return $_[0]->iterate(
- sub { $_[0]->max }
- );
-}
-
-sub union {
- my $a1 = shift;
- my $b1;
- if (ref ($_[0]) eq ref($a1) ) {
- $b1 = shift;
- }
- else {
- $b1 = $a1->new(@_);
- }
- # test for union with empty set
- if ( $#{ $a1->{list} } < 0 ) {
- return $b1;
- }
- if ( $#{ $b1->{list} } < 0 ) {
- return $a1;
- }
- my @b1_min = $b1->min_a;
- my @a1_max = $a1->max_a;
- unless (defined $b1_min[0]) {
- return $a1;
- }
- unless (defined $a1_max[0]) {
- return $b1;
- }
- my ($ia, $ib);
- $ia = 0;
- $ib = 0;
-
- # size+order matters on speed
- $a1 = $a1->new($a1); # don't modify ourselves
- my $b_list = $b1->{list};
- # -- frequent case - $b1 is after $a1
- if ($b1_min[0] > $a1_max[0]) {
- push @{$a1->{list}}, @$b_list;
- return $a1;
- }
-
- my @tmp;
- my $is_real = !$a1->tolerance && !$b1->tolerance;
- B: foreach $ib ($ib .. $#{$b_list}) {
- foreach $ia ($ia .. $#{$a1->{list}}) {
- @tmp = _simple_union($a1->{list}[$ia], $b_list->[$ib], $a1->{tolerance});
- if ($#tmp == 0) {
- $a1->{list}[$ia] = $tmp[0];
-
- while (1) {
- last if $ia >= $#{$a1->{list}};
- last unless _simple_intersects ( $a1->{list}[$ia], $a1->{list}[$ia + 1] )
- || $is_real
- && $a1->{list}[$ia]{b} == $a1->{list}[$ia + 1]{a};
- @tmp = _simple_union($a1->{list}[$ia], $a1->{list}[$ia + 1], $a1->{tolerance});
- last unless @tmp == 1;
- $a1->{list}[$ia] = $tmp[0];
- splice( @{$a1->{list}}, $ia + 1, 1 );
- }
-
- next B;
- }
- if ($a1->{list}[$ia]{a} >= $b_list->[$ib]{a}) {
- splice (@{$a1->{list}}, $ia, 0, $b_list->[$ib]);
- next B;
- }
- }
- push @{$a1->{list}}, $b_list->[$ib];
- }
- return $a1;
-}
-
-
-# there are some ways to process 'contains':
-# A CONTAINS B IF A == ( A UNION B )
-# - faster
-# A CONTAINS B IF B == ( A INTERSECTION B )
-# - can backtrack = works for unbounded sets
-sub contains {
- my $a1 = shift;
- my $b1 = $a1->union(@_);
- return ($b1 == $a1) ? 1 : 0;
-}
-
-
-sub copy {
- my $self = shift;
- my $copy = $self->empty_set();
- ## return $copy unless ref($self); # constructor!
- foreach my $key (keys %{$self}) {
- if ( ref( $self->{$key} ) eq 'ARRAY' ) {
- @{ $copy->{$key} } = @{ $self->{$key} };
- }
- else {
- $copy->{$key} = $self->{$key};
- }
- }
- return $copy;
-}
-
-*clone = \©
-
-
-sub new {
- my $class = shift;
- my $self;
- if ( ref $class ) {
- $self = bless {
- list => [],
- tolerance => $class->{tolerance},
- type => $class->{type},
- fixtype => $class->{fixtype},
- }, ref($class);
- }
- else {
- $self = bless {
- list => [],
- tolerance => $tolerance ? $tolerance : 0,
- type => $class->type,
- fixtype => $fixtype ? $fixtype : 0,
- }, $class;
- }
- my ($tmp, $tmp2, $ref);
- while (@_) {
- $tmp = shift;
- $ref = ref($tmp);
- if ($ref) {
- if ($ref eq 'ARRAY') {
- # allows arrays of arrays
- $tmp = $class->new(@$tmp); # call new() recursively
- push @{ $self->{list} }, @{$tmp->{list}};
- next;
- }
- if ($ref eq 'HASH') {
- push @{ $self->{list} }, $tmp;
- next;
- }
- if ($tmp->isa(__PACKAGE__)) {
- push @{ $self->{list} }, @{$tmp->{list}};
- next;
- }
- }
- if ( @_ ) {
- $tmp2 = shift
- }
- else {
- $tmp2 = $tmp
- }
- push @{ $self->{list} }, _simple_new($tmp,$tmp2, $self->{type} )
- }
- $self;
-}
-
-sub empty_set {
- $_[0]->new;
-}
-
-sub universal_set {
- $_[0]->new( NEG_INFINITY, INFINITY );
-}
-
-*minus = \∁
-
-*difference = \∁
-
-sub symmetric_difference {
- my $a1 = shift;
- my $b1;
- if (ref ($_[0]) eq ref($a1) ) {
- $b1 = shift;
- }
- else {
- $b1 = $a1->new(@_);
- }
-
- return $a1->complement( $b1 )->union(
- $b1->complement( $a1 ) );
-}
-
-*simmetric_difference = \&symmetric_difference; # bugfix
-
-sub min {
- ($_[0]->min_a)[0];
-}
-
-sub min_a {
- my $self = $_[0];
- return @{$self->{min}} if exists $self->{min};
- return @{$self->{min}} = (undef, 0) unless @{$self->{list}};
- my $tmp = $self->{list}[0]{a};
- my $tmp2 = $self->{list}[0]{open_begin} || 0;
- if ($tmp2 && $self->{tolerance}) {
- $tmp2 = 0;
- $tmp += $self->{tolerance};
- }
- return @{$self->{min}} = ($tmp, $tmp2);
-};
-
-sub max {
- ($_[0]->max_a)[0];
-}
-
-sub max_a {
- my $self = $_[0];
- return @{$self->{max}} if exists $self->{max};
- return @{$self->{max}} = (undef, 0) unless @{$self->{list}};
- my $tmp = $self->{list}[-1]{b};
- my $tmp2 = $self->{list}[-1]{open_end} || 0;
- if ($tmp2 && $self->{tolerance}) {
- $tmp2 = 0;
- $tmp -= $self->{tolerance};
- }
- return @{$self->{max}} = ($tmp, $tmp2);
-};
-
-sub count {
- 1 + $#{$_[0]->{list}};
-}
-
-sub size {
- my $self = $_[0];
- my $size;
- foreach( @{$self->{list}} ) {
- if ( $size ) {
- $size += $_->{b} - $_->{a};
- }
- else {
- $size = $_->{b} - $_->{a};
- }
- if ( $self->{tolerance} ) {
- $size += $self->{tolerance} unless $_->{open_end};
- $size -= $self->{tolerance} if $_->{open_begin};
- $size -= $self->{tolerance} if $_->{open_end};
- }
- }
- return $size;
-};
-
-sub span {
- my $self = $_[0];
- my @max = $self->max_a;
- my @min = $self->min_a;
- return undef unless defined $min[0] && defined $max[0];
- my $a1 = $self->new($min[0], $max[0]);
- $a1->{list}[0]{open_end} = $max[1];
- $a1->{list}[0]{open_begin} = $min[1];
- return $a1;
-};
-
-sub spaceship {
- my ($tmp1, $tmp2, $inverted) = @_;
- if ($inverted) {
- ($tmp2, $tmp1) = ($tmp1, $tmp2);
- }
- foreach(0 .. $#{$tmp1->{list}}) {
- my $this = $tmp1->{list}[$_];
- if ($_ > $#{ $tmp2->{list} } ) {
- return 1;
- }
- my $other = $tmp2->{list}[$_];
- my $cmp = _simple_spaceship($this, $other);
- return $cmp if $cmp; # this != $other;
- }
- return $#{ $tmp1->{list} } == $#{ $tmp2->{list} } ? 0 : -1;
-}
-
-sub tolerance {
- my $self = shift;
- my $tmp = pop;
- if (ref($self)) {
- # local
- return $self->{tolerance} unless defined $tmp;
- $self = $self->copy;
- $self->{tolerance} = $tmp;
- delete $self->{max}; # tolerance may change "max"
-
- $_ = 1;
- my @tmp;
- while ( $_ <= $#{$self->{list}} ) {
- @tmp = Set::Infinite::Basic::_simple_union($self->{list}->[$_],
- $self->{list}->[$_ - 1],
- $self->{tolerance});
- if ($#tmp == 0) {
- $self->{list}->[$_ - 1] = $tmp[0];
- splice (@{$self->{list}}, $_, 1);
- }
- else {
- $_ ++;
- }
- }
-
- return $self;
- }
- # global
- $tolerance = $tmp if defined($tmp);
- return $tolerance;
-}
-
-sub integer {
- $_[0]->tolerance (1);
-}
-
-sub real {
- $_[0]->tolerance (0);
-}
-
-sub as_string {
- my $self = shift;
- return $self->separators(6) .
- join( $self->separators(5),
- map { $self->_simple_as_string($_) } @{$self->{list}} ) .
- $self->separators(7),;
-}
-
-
-sub DESTROY {}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Set::Infinite::Basic - Sets of intervals
-6
-=head1 SYNOPSIS
-
- use Set::Infinite::Basic;
-
- $set = Set::Infinite::Basic->new(1,2); # [1..2]
- print $set->union(5,6); # [1..2],[5..6]
-
-=head1 DESCRIPTION
-
-Set::Infinite::Basic is a Set Theory module for infinite sets.
-
-It works on reals, integers, and objects.
-
-This module does not support recurrences. Recurrences are implemented in Set::Infinite.
-
-=head1 METHODS
-
-=head2 empty_set
-
-Creates an empty_set.
-
-If called from an existing set, the empty set inherits
-the "type" and "density" characteristics.
-
-=head2 universal_set
-
-Creates a set containing "all" possible elements.
-
-If called from an existing set, the universal set inherits
-the "type" and "density" characteristics.
-
-=head2 until
-
-Extends a set until another:
-
- 0,5,7 -> until 2,6,10
-
-gives
-
- [0..2), [5..6), [7..10)
-
-Note: this function is still experimental.
-
-=head2 copy
-
-=head2 clone
-
-Makes a new object from the object's data.
-
-=head2 Mode functions:
-
- $set = $set->real;
-
- $set = $set->integer;
-
-=head2 Logic functions:
-
- $logic = $set->intersects($b);
-
- $logic = $set->contains($b);
-
- $logic = $set->is_null; # also called "is_empty"
-
-=head2 Set functions:
-
- $set = $set->union($b);
-
- $set = $set->intersection($b);
-
- $set = $set->complement;
- $set = $set->complement($b); # can also be called "minus" or "difference"
-
- $set = $set->symmetric_difference( $b );
-
- $set = $set->span;
-
- result is (min .. max)
-
-=head2 Scalar functions:
-
- $i = $set->min;
-
- $i = $set->max;
-
- $i = $set->size;
-
- $i = $set->count; # number of spans
-
-=head2 Overloaded Perl functions:
-
- print
-
- sort, <=>
-
-=head2 Global functions:
-
- separators(@i)
-
- chooses the interval separators.
-
- default are [ ] ( ) '..' ','.
-
- INFINITY
-
- returns an 'Infinity' number.
-
- NEG_INFINITY
-
- returns a '-Infinity' number.
-
- iterate ( sub { } )
-
- Iterates over a subroutine.
- Returns the union of partial results.
-
- first
-
- In scalar context returns the first interval of a set.
-
- In list context returns the first interval of a set, and the
- 'tail'.
-
- Works in unbounded sets
-
- type($i)
-
- chooses an object data type.
-
- default is none (a normal perl SCALAR).
-
- examples:
-
- type('Math::BigFloat');
- type('Math::BigInt');
- type('Set::Infinite::Date');
- See notes on Set::Infinite::Date below.
-
- tolerance(0) defaults to real sets (default)
- tolerance(1) defaults to integer sets
-
- real defaults to real sets (default)
-
- integer defaults to integer sets
-
-=head2 Internal functions:
-
- $set->fixtype;
-
- $set->numeric;
-
-=head1 CAVEATS
-
- $set = Set::Infinite->new(10,1);
- Will be interpreted as [1..10]
-
- $set = Set::Infinite->new(1,2,3,4);
- Will be interpreted as [1..2],[3..4] instead of [1,2,3,4].
- You probably want ->new([1],[2],[3],[4]) instead,
- or maybe ->new(1,4)
-
- $set = Set::Infinite->new(1..3);
- Will be interpreted as [1..2],3 instead of [1,2,3].
- You probably want ->new(1,3) instead.
-
-=head1 INTERNALS
-
-The internal representation of a I<span> is a hash:
-
- { a => start of span,
- b => end of span,
- open_begin => '0' the span starts in 'a'
- '1' the span starts after 'a'
- open_end => '0' the span ends in 'b'
- '1' the span ends before 'b'
- }
-
-For example, this set:
-
- [100..200),300,(400..infinity)
-
-is represented by the array of hashes:
-
- list => [
- { a => 100, b => 200, open_begin => 0, open_end => 1 },
- { a => 300, b => 300, open_begin => 0, open_end => 0 },
- { a => 400, b => infinity, open_begin => 0, open_end => 1 },
- ]
-
-The I<density> of a set is stored in the C<tolerance> variable:
-
- tolerance => 0; # the set is made of real numbers.
-
- tolerance => 1; # the set is made of integers.
-
-The C<type> variable stores the I<class> of objects that will be stored in the set.
-
- type => 'DateTime'; # this is a set of DateTime objects
-
-The I<infinity> value is generated by Perl, when it finds a numerical overflow:
-
- $inf = 100**100**100;
-
-=head1 SEE ALSO
-
- Set::Infinite
-
-=head1 AUTHOR
-
- Flavio S. Glock <fglock@gmail.com>
-
-=cut
-
+++ /dev/null
-# Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
-# This program is free software; you can redistribute it and/or
-# modify it under the same terms as Perl itself.
-
-package Set::Infinite::_recurrence;
-
-use strict;
-
-use constant INFINITY => 100 ** 100 ** 100 ;
-use constant NEG_INFINITY => -1 * (100 ** 100 ** 100);
-
-use vars qw( @ISA $PRETTY_PRINT $max_iterate );
-
-@ISA = qw( Set::Infinite );
-use Set::Infinite 0.5502;
-
-BEGIN {
- $PRETTY_PRINT = 1; # enable Set::Infinite debug
- $max_iterate = 20;
-
- # TODO: inherit %Set::Infinite::_first / _last
- # in a more "object oriented" way
-
- $Set::Infinite::_first{_recurrence} =
- sub {
- my $self = $_[0];
- my ($callback_next, $callback_previous) = @{ $self->{param} };
- my ($min, $min_open) = $self->{parent}->min_a;
-
- my ( $min1, $min2 );
- $min1 = $callback_next->( $min );
- if ( ! $min_open )
- {
- $min2 = $callback_previous->( $min1 );
- $min1 = $min2 if defined $min2 && $min == $min2;
- }
-
- my $start = $callback_next->( $min1 );
- my $end = $self->{parent}->max;
-
- #print STDERR "set ";
- #print STDERR $start->datetime
- # unless $start == INFINITY;
- #print STDERR " - " ;
- #print STDERR $end->datetime
- # unless $end == INFINITY;
- #print STDERR "\n";
-
- return ( $self->new( $min1 ), undef )
- if $start > $end;
-
- return ( $self->new( $min1 ),
- $self->new( $start, $end )->
- _function( '_recurrence', @{ $self->{param} } ) );
- };
- $Set::Infinite::_last{_recurrence} =
- sub {
- my $self = $_[0];
- my ($callback_next, $callback_previous) = @{ $self->{param} };
- my ($max, $max_open) = $self->{parent}->max_a;
-
- my ( $max1, $max2 );
- $max1 = $callback_previous->( $max );
- if ( ! $max_open )
- {
- $max2 = $callback_next->( $max1 );
- $max1 = $max2 if $max == $max2;
- }
-
- return ( $self->new( $max1 ),
- $self->new( $self->{parent}->min,
- $callback_previous->( $max1 ) )->
- _function( '_recurrence', @{ $self->{param} } ) );
- };
-}
-
-# $si->_recurrence(
-# \&callback_next, \&callback_previous )
-#
-# Generates "recurrences" from a callback.
-# These recurrences are simple lists of dates.
-#
-# The recurrence generation is based on an idea from Dave Rolsky.
-#
-
-# use Data::Dumper;
-# use Carp qw(cluck);
-
-sub _recurrence {
- my $set = shift;
- my ( $callback_next, $callback_previous, $delta ) = @_;
-
- $delta->{count} = 0 unless defined $delta->{delta};
-
- # warn "reusing delta: ". $delta->{count} if defined $delta->{delta};
- # warn Dumper( $delta );
-
- if ( $#{ $set->{list} } != 0 || $set->is_too_complex )
- {
- return $set->iterate(
- sub {
- $_[0]->_recurrence(
- $callback_next, $callback_previous, $delta )
- } );
- }
- # $set is a span
- my $result;
- if ($set->min != NEG_INFINITY && $set->max != INFINITY)
- {
- # print STDERR " finite set\n";
- my ($min, $min_open) = $set->min_a;
- my ($max, $max_open) = $set->max_a;
-
- my ( $min1, $min2 );
- $min1 = $callback_next->( $min );
- if ( ! $min_open )
- {
- $min2 = $callback_previous->( $min1 );
- $min1 = $min2 if defined $min2 && $min == $min2;
- }
-
- $result = $set->new();
-
- # get "delta" - abort if this will take too much time.
-
- unless ( defined $delta->{max_delta} )
- {
- for ( $delta->{count} .. 10 )
- {
- if ( $max_open )
- {
- return $result if $min1 >= $max;
- }
- else
- {
- return $result if $min1 > $max;
- }
- push @{ $result->{list} },
- { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
- $min2 = $callback_next->( $min1 );
-
- if ( $delta->{delta} )
- {
- $delta->{delta} += $min2 - $min1;
- }
- else
- {
- $delta->{delta} = $min2 - $min1;
- }
- $delta->{count}++;
- $min1 = $min2;
- }
-
- $delta->{max_delta} = $delta->{delta} * 40;
- }
-
- if ( $max < $min + $delta->{max_delta} )
- {
- for ( 1 .. 200 )
- {
- if ( $max_open )
- {
- return $result if $min1 >= $max;
- }
- else
- {
- return $result if $min1 > $max;
- }
- push @{ $result->{list} },
- { a => $min1, b => $min1, open_begin => 0, open_end => 0 };
- $min1 = $callback_next->( $min1 );
- }
- }
-
- # cluck "give up";
- }
-
- # return a "_function", such that we can backtrack later.
- my $func = $set->_function( '_recurrence', $callback_next, $callback_previous, $delta );
-
- # removed - returning $result doesn't help on speed
- ## return $func->_function2( 'union', $result ) if $result;
-
- return $func;
-}
-
-sub is_forever
-{
- $#{ $_[0]->{list} } == 0 &&
- $_[0]->max == INFINITY &&
- $_[0]->min == NEG_INFINITY
-}
-
-sub _is_recurrence
-{
- exists $_[0]->{method} &&
- $_[0]->{method} eq '_recurrence' &&
- $_[0]->{parent}->is_forever
-}
-
-sub intersection
-{
- my ($s1, $s2) = (shift,shift);
-
- if ( exists $s1->{method} && $s1->{method} eq '_recurrence' )
- {
- # optimize: recurrence && span
- return $s1->{parent}->
- intersection( $s2, @_ )->
- _recurrence( @{ $s1->{param} } )
- unless ref($s2) && exists $s2->{method};
-
- # optimize: recurrence && recurrence
- if ( $s1->{parent}->is_forever &&
- ref($s2) && _is_recurrence( $s2 ) )
- {
- my ( $next1, $previous1 ) = @{ $s1->{param} };
- my ( $next2, $previous2 ) = @{ $s2->{param} };
- return $s1->{parent}->_function( '_recurrence',
- sub {
- # intersection of parent 'next' callbacks
- my ($n1, $n2);
- my $iterate = 0;
- $n2 = $next2->( $_[0] );
- while(1) {
- $n1 = $next1->( $previous1->( $n2 ) );
- return $n1 if $n1 == $n2;
- $n2 = $next2->( $previous2->( $n1 ) );
- return if $iterate++ == $max_iterate;
- }
- },
- sub {
- # intersection of parent 'previous' callbacks
- my ($p1, $p2);
- my $iterate = 0;
- $p2 = $previous2->( $_[0] );
- while(1) {
- $p1 = $previous1->( $next1->( $p2 ) );
- return $p1 if $p1 == $p2;
- $p2 = $previous2->( $next2->( $p1 ) );
- return if $iterate++ == $max_iterate;
- }
- },
- );
- }
- }
- return $s1->SUPER::intersection( $s2, @_ );
-}
-
-sub union
-{
- my ($s1, $s2) = (shift,shift);
- if ( $s1->_is_recurrence &&
- ref($s2) && _is_recurrence( $s2 ) )
- {
- # optimize: recurrence || recurrence
- my ( $next1, $previous1 ) = @{ $s1->{param} };
- my ( $next2, $previous2 ) = @{ $s2->{param} };
- return $s1->{parent}->_function( '_recurrence',
- sub { # next
- my $n1 = $next1->( $_[0] );
- my $n2 = $next2->( $_[0] );
- return $n1 < $n2 ? $n1 : $n2;
- },
- sub { # previous
- my $p1 = $previous1->( $_[0] );
- my $p2 = $previous2->( $_[0] );
- return $p1 > $p2 ? $p1 : $p2;
- },
- );
- }
- return $s1->SUPER::union( $s2, @_ );
-}
-
-=head1 NAME
-
-Set::Infinite::_recurrence - Extends Set::Infinite with recurrence functions
-
-=head1 SYNOPSIS
-
- $recurrence = $base_set->_recurrence ( \&next, \&previous );
-
-=head1 DESCRIPTION
-
-This is an internal class used by the DateTime::Set module.
-The API is subject to change.
-
-It provides all functionality provided by Set::Infinite, plus the ability
-to define recurrences with arbitrary objects, such as dates.
-
-=head1 METHODS
-
-=over 4
-
-=item * _recurrence ( \&next, \&previous )
-
-Creates a recurrence set. The set is defined inside a 'base set'.
-
- $recurrence = $base_set->_recurrence ( \&next, \&previous );
-
-The recurrence functions take one argument, and return the 'next' or
-the 'previous' occurence.
-
-Example: defines the set of all 'integer numbers':
-
- use strict;
-
- use Set::Infinite::_recurrence;
- use POSIX qw(floor);
-
- # define the recurrence span
- my $forever = Set::Infinite::_recurrence->new(
- Set::Infinite::_recurrence::NEG_INFINITY,
- Set::Infinite::_recurrence::INFINITY
- );
-
- my $recurrence = $forever->_recurrence(
- sub { # next
- floor( $_[0] + 1 )
- },
- sub { # previous
- my $tmp = floor( $_[0] );
- $tmp < $_[0] ? $tmp : $_[0] - 1
- },
- );
-
- print "sample recurrence ",
- $recurrence->intersection( -5, 5 ), "\n";
- # sample recurrence -5,-4,-3,-2,-1,0,1,2,3,4,5
-
- {
- my $x = 234.567;
- print "next occurence after $x = ",
- $recurrence->{param}[0]->( $x ), "\n"; # 235
- print "previous occurence before $x = ",
- $recurrence->{param}[2]->( $x ), "\n"; # 234
- }
-
- {
- my $x = 234;
- print "next occurence after $x = ",
- $recurrence->{param}[0]->( $x ), "\n"; # 235
- print "previous occurence before $x = ",
- $recurrence->{param}[2]->( $x ), "\n"; # 233
- }
-
-=item * is_forever
-
-Returns true if the set is a single span,
-ranging from -Infinity to Infinity.
-
-=item * _is_recurrence
-
-Returns true if the set is an unbounded recurrence,
-ranging from -Infinity to Infinity.
-
-=back
-
-=head1 CONSTANTS
-
-=over 4
-
-=item * INFINITY
-
-The C<Infinity> value.
-
-=item * NEG_INFINITY
-
-The C<-Infinity> value.
-
-=back
-
-=head1 SUPPORT
-
-Support is offered through the C<datetime@perl.org> mailing list.
-
-Please report bugs using rt.cpan.org
-
-=head1 AUTHOR
-
-Flavio Soibelmann Glock <fglock@pucrs.br>
-
-The recurrence generation algorithm is based on an idea from Dave Rolsky.
-
-=head1 COPYRIGHT
-
-Copyright (c) 2003 Flavio Soibelmann Glock. All rights reserved.
-This program is free software; you can distribute it and/or
-modify it under the same terms as Perl itself.
-
-The full text of the license can be found in the LICENSE file
-included with this module.
-
-=head1 SEE ALSO
-
-Set::Infinite
-
-DateTime::Set
-
-For details on the Perl DateTime Suite project please see
-L<http://datetime.perl.org>.
-
-=cut
-
+++ /dev/null
-# $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $
-#
-# Copyright (c) 1997 Roderick Schertler. All rights reserved. This
-# program is free software; you can redistribute it and/or modify it
-# under the same terms as Perl itself.
-
-=head1 NAME
-
-String::ShellQuote - quote strings for passing through the shell
-
-=head1 SYNOPSIS
-
- $string = shell_quote @list;
- $string = shell_quote_best_effort @list;
- $string = shell_comment_quote $string;
-
-=head1 DESCRIPTION
-
-This module contains some functions which are useful for quoting strings
-which are going to pass through the shell or a shell-like object.
-
-=over
-
-=cut
-
-package String::ShellQuote;
-
-use strict;
-use vars qw($VERSION @ISA @EXPORT);
-
-require Exporter;
-
-$VERSION = '1.04';
-@ISA = qw(Exporter);
-@EXPORT = qw(shell_quote shell_quote_best_effort shell_comment_quote);
-
-sub croak {
- require Carp;
- goto &Carp::croak;
-}
-
-sub _shell_quote_backend {
- my @in = @_;
- my @err = ();
-
- if (0) {
- require RS::Handy;
- print RS::Handy::data_dump(\@in);
- }
-
- return \@err, '' unless @in;
-
- my $ret = '';
- my $saw_non_equal = 0;
- foreach (@in) {
- if (!defined $_ or $_ eq '') {
- $_ = "''";
- next;
- }
-
- if (s/\x00//g) {
- push @err, "No way to quote string containing null (\\000) bytes";
- }
-
- my $escape = 0;
-
- # = needs quoting when it's the first element (or part of a
- # series of such elements), as in command position it's a
- # program-local environment setting
-
- if (/=/) {
- if (!$saw_non_equal) {
- $escape = 1;
- }
- }
- else {
- $saw_non_equal = 1;
- }
-
- if (m|[^\w!%+,\-./:=@^]|) {
- $escape = 1;
- }
-
- if ($escape
- || (!$saw_non_equal && /=/)) {
-
- # ' -> '\''
- s/'/'\\''/g;
-
- # make multiple ' in a row look simpler
- # '\'''\'''\'' -> '"'''"'
- s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;
-
- $_ = "'$_'";
- s/^''//;
- s/''$//;
- }
- }
- continue {
- $ret .= "$_ ";
- }
-
- chop $ret;
- return \@err, $ret;
-}
-
-=item B<shell_quote> [I<string>]...
-
-B<shell_quote> quotes strings so they can be passed through the shell.
-Each I<string> is quoted so that the shell will pass it along as a
-single argument and without further interpretation. If no I<string>s
-are given an empty string is returned.
-
-If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
-
-=cut
-
-sub shell_quote {
- my ($rerr, $s) = _shell_quote_backend @_;
-
- if (@$rerr) {
- my %seen;
- @$rerr = grep { !$seen{$_}++ } @$rerr;
- my $s = join '', map { "shell_quote(): $_\n" } @$rerr;
- chomp $s;
- croak $s;
- }
- return $s;
-}
-
-=item B<shell_quote_best_effort> [I<string>]...
-
-This is like B<shell_quote>, excpet if the string can't be safely quoted
-it does the best it can and returns the result, instead of dying.
-
-=cut
-
-sub shell_quote_best_effort {
- my ($rerr, $s) = _shell_quote_backend @_;
-
- return $s;
-}
-
-=item B<shell_comment_quote> [I<string>]
-
-B<shell_comment_quote> quotes the I<string> so that it can safely be
-included in a shell-style comment (the current algorithm is that a sharp
-character is placed after any newlines in the string).
-
-This routine might be changed to accept multiple I<string> arguments
-in the future. I haven't done this yet because I'm not sure if the
-I<string>s should be joined with blanks ($") or nothing ($,). Cast
-your vote today! Be sure to justify your answer.
-
-=cut
-
-sub shell_comment_quote {
- return '' unless @_;
- unless (@_ == 1) {
- croak "Too many arguments to shell_comment_quote "
- . "(got " . @_ . " expected 1)";
- }
- local $_ = shift;
- s/\n/\n#/g;
- return $_;
-}
-
-1;
-
-__END__
-
-=back
-
-=head1 EXAMPLES
-
- $cmd = 'fuser 2>/dev/null ' . shell_quote @files;
- @pids = split ' ', `$cmd`;
-
- print CFG "# Configured by: ",
- shell_comment_quote($ENV{LOGNAME}), "\n";
-
-=head1 BUGS
-
-Only Bourne shell quoting is supported. I'd like to add other shells
-(particularly cmd.exe), but I'm not familiar with them. It would be a
-big help if somebody supplied the details.
-
-=head1 AUTHOR
-
-Roderick Schertler <F<roderick@argon.org>>
-
-=head1 SEE ALSO
-
-perl(1).
-
-=cut
-
+++ /dev/null
-package parent;
-use strict;
-use vars qw($VERSION);
-$VERSION = '0.221';
-
-sub import {
- my $class = shift;
-
- my $inheritor = caller(0);
-
- if ( @_ and $_[0] eq '-norequire' ) {
- shift @_;
- } else {
- for ( my @filename = @_ ) {
- if ( $_ eq $inheritor ) {
- warn "Class '$inheritor' tried to inherit from itself\n";
- };
-
- s{::|'}{/}g;
- require "$_.pm"; # dies if the file is not found
- }
- }
-
- {
- no strict 'refs';
- # This is more efficient than push for the new MRO
- # at least until the new MRO is fixed
- @{"$inheritor\::ISA"} = (@{"$inheritor\::ISA"} , @_);
- };
-};
-
-"All your base are belong to us"
-
-__END__
-
-=head1 NAME
-
-parent - Establish an ISA relationship with base classes at compile time
-
-=head1 SYNOPSIS
-
- package Baz;
- use parent qw(Foo Bar);
-
-=head1 DESCRIPTION
-
-Allows you to both load one or more modules, while setting up inheritance from
-those modules at the same time. Mostly similar in effect to
-
- package Baz;
- BEGIN {
- require Foo;
- require Bar;
- push @ISA, qw(Foo Bar);
- }
-
-By default, every base class needs to live in a file of its own.
-If you want to have a subclass and its parent class in the same file, you
-can tell C<parent> not to load any modules by using the C<-norequire> switch:
-
- package Foo;
- sub exclaim { "I CAN HAS PERL" }
-
- package DoesNotLoadFooBar;
- use parent -norequire, 'Foo', 'Bar';
- # will not go looking for Foo.pm or Bar.pm
-
-This is equivalent to the following code:
-
- package Foo;
- sub exclaim { "I CAN HAS PERL" }
-
- package DoesNotLoadFooBar;
- push @DoesNotLoadFooBar::ISA, 'Foo';
-
-This is also helpful for the case where a package lives within
-a differently named file:
-
- package MyHash;
- use Tie::Hash;
- use parent -norequire, 'Tie::StdHash';
-
-This is equivalent to the following code:
-
- package MyHash;
- require Tie::Hash;
- push @ISA, 'Tie::StdHash';
-
-If you want to load a subclass from a file that C<require> would
-not consider an eligible filename (that is, it does not end in
-either C<.pm> or C<.pmc>), use the following code:
-
- package MySecondPlugin;
- require './plugins/custom.plugin'; # contains Plugin::Custom
- use parent -norequire, 'Plugin::Custom';
-
-=head1 DIAGNOSTICS
-
-=over 4
-
-=item Class 'Foo' tried to inherit from itself
-
-Attempting to inherit from yourself generates a warning.
-
- use Foo;
- use parent 'Foo';
-
-=back
-
-=head1 HISTORY
-
-This module was forked from L<base> to remove the cruft
-that had accumulated in it.
-
-=head1 CAVEATS
-
-=head1 SEE ALSO
-
-L<base>
-
-=head1 AUTHORS AND CONTRIBUTORS
-
-Rafaël Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern
-
-=head1 MAINTAINER
-
-Max Maischein C< corion@cpan.org >
-
-Copyright (c) 2007 Max Maischein C<< <corion@cpan.org> >>
-Based on the idea of C<base.pm>, which was introduced with Perl 5.004_04.
-
-=head1 LICENSE
-
-This module is released under the same terms as Perl itself.
-
-=cut
projects / kivitendo-erp.git / commitdiff