From: Sven Schöling Date: Tue, 6 Feb 2018 10:10:34 +0000 (+0100) Subject: modules/fallback: Module entfernt. X-Git-Tag: release-3.5.4~479 X-Git-Url: http://wagnertech.de/git?a=commitdiff_plain;h=3720cd5e3b013e1b1af311179b383e9f61832baa;p=kivitendo-erp.git modules/fallback: Module entfernt. In modules/fallback sollten nur module stehen die: a) für installationcheck gebraucht werden oder b) nicht per apt installierbar sind Das gilt für die folgenden Module schon lange nicht mehr: * DateTime::Set * Email::Address * List::MoreUtils * List::UtilsBy * PBKDF2::Tiny * Regexp::IPv6 * Set::Infinite * String::ShellQuote * parent Dabei waren DateTime::Set und Set::Infinite als Anhängigkeiten von DateTime::Event::Cron reingekommen, das gibt es aber zusammen mit Set::Crontab immernoch nicht in apt, also ist das weiter im fallback. List::MoreUtils und List::UtilsBy sind meine ich für Debian 5 reingekommen, die Pakete sind aber seit Ewigkeiten in apt verfügbar. parent ist seit 5.10.1 ein coremodul. Die anderen wurden anscheinend einfach so reingeworfen, und hätten da nie drin sein sollen. --- diff --git a/SL/InstallationCheck.pm b/SL/InstallationCheck.pm index 2b9b68eb2..ec2b719dc 100644 --- a/SL/InstallationCheck.pm +++ b/SL/InstallationCheck.pm @@ -17,36 +17,44 @@ BEGIN { # 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 diff --git a/modules/fallback/DateTime/Set.pm b/modules/fallback/DateTime/Set.pm deleted file mode 100644 index 05fac96e9..000000000 --- a/modules/fallback/DateTime/Set.pm +++ /dev/null @@ -1,1149 +0,0 @@ - -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, which handles a continuous -range as opposed to individual datetime points. There is also a module -C 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, or from a -C class. - -C 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 parameter is optional. It must be a C object. - -The span can also be specified using C / C and C -/ C parameters, as in the C constructor. In this -case, if there is a C 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, or from -one of the C classes. The parameter can also -be a C or a C -object. - -The recurrence must return the I 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. - -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 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 and -C objects, in order to define I. 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 parameters. See above. - -See also C and the other -C 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 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 method. - - $meetings_2004 = $meetings_2003->clone->add( years => 1 ); - -=item * subtract_duration( $duration_object ) - -When given a C object, this method simply calls -C on that object and passes that new duration to the -C method. - -=item * subtract( DateTime::Duration->new parameters ) - -Like C, this is syntactic sugar for the C -method. - -=item * set_time_zone( $tz ) - -This method will attempt to apply the C method to every -datetime in the set. - -=item * set( locale => .. ) - -This method can be used to change the C of a datetime set. - -=item * min - -=item * max - -The first and last C in the set. These methods may return -C if the set is empty. It is also possible that these methods -may return a C or -C object. - -These methods return just a I 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 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 -parameter. This should be a C 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 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 or C method will return C when there -are no more datetimes in the iterator. - -=item * as_list - -Returns the set elements as a list of C objects. Just as -with the C method, the C method can be limited -by a span. - - my @dt = $set->as_list( span => $span ); - -Applying C to a large recurrence set is a very expensive -operation, both in CPU time and in the memory used. If you I -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 sets, C will return C. 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 objects in the set. Just as with the -C method, the C 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 to a large recurrence set is a very expensive -operation, both in CPU time and in the memory used. If you I -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 sets, C will return C. 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 list, a -C, a C, or a C -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 of a C with a C or a -C object returns a C object. - -If C is called without any arguments, then the result is a -C object representing the spans between each of the -set's elements. If complement is given an argument, then the return -value is a C object representing the I -between the sets. - -All other operations will always return a C. - -=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 list, a C, a -C, or a C 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 method returns C<$dt> if $dt is an event, otherwise -it returns the previous event. - -The C 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 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 inside the subroutine may happen later than you -expect. - -The callback return value is expected to be within the span of the -C and the C element in the original set. This is a -limitation of the backtracking algorithm used in the C -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 inside the subroutine may happen later than you -expect. - -=item * iterate ( sub { ... } ) - -I - -=back - -=head1 SUPPORT - -Support is offered through the C mailing list. - -Please report bugs using rt.cpan.org - -=head1 AUTHOR - -Flavio Soibelmann Glock - -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. - -=cut - diff --git a/modules/fallback/DateTime/Span.pm b/modules/fallback/DateTime/Span.pm deleted file mode 100644 index 5917a8a19..000000000 --- a/modules/fallback/DateTime/Span.pm +++ /dev/null @@ -1,501 +0,0 @@ -# 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 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, which is made of individual -datetime points as opposed to a range. There is also a module -C 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 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 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 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 time is adjusted in order -to leave the local time untouched. - -=item * duration - -The total size of the set, as a C object, or as a -scalar containing infinity. - -Also available as C. - -=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 or a Cxs object. - -If the set ends C 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 -objects, but also with C and C -objects. These set operations always return a C -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, C, -C, or C object as an argument. - -=back - -=head1 SUPPORT - -Support is offered through the C mailing list. - -Please report bugs using rt.cpan.org - -=head1 AUTHOR - -Flavio Soibelmann Glock - -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. - -=cut - diff --git a/modules/fallback/DateTime/SpanSet.pm b/modules/fallback/DateTime/SpanSet.pm deleted file mode 100644 index 8a258f1fb..000000000 --- a/modules/fallback/DateTime/SpanSet.pm +++ /dev/null @@ -1,945 +0,0 @@ -# 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 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, 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 objects. - - $spanset = DateTime::SpanSet->from_spans( spans => [ $dt_span ] ); - -=item * from_set_and_duration - -Creates a new span set from one or more C objects and a -duration. - -The duration can be a C object, or the parameters -to create a new C 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 objects. - -One set defines the I, and the other defines the I. - - $spanset = - DateTime::SpanSet->from_sets - ( start_set => $dt_set1, end_set => $dt_set2 ); - -The spans have the starting date C, and the end date C, -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 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 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 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 object. - -The duration may be infinite. - -Also available as C. - -=item * span - -The total span of the set, as a C 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, or C 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, or C 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, or C 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 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, or C 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 objects. - - my @dt_span = $set->as_list( span => $span ); - -Just as with the C method, the C method can be -limited by a span. - -Applying C to a large recurring spanset is a very expensive -operation, both in CPU time and in the memory used. - -For this reason, when C operates on large recurrence sets, -it will return at most approximately 200 spans. For larger sets, and -for I sets, C will return C. - -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 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 -objects, but also with C, C and -C objects. These set operations always return a -C 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 list, a C, a -C, or a C object as an argument. - - $set = $set1->intersected_spans( $set2 ); - -The method always returns a C object, containing -all spans that are intersected by the given set. - -Unlike the C 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, C, -C, or C 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 -parameter. This should be a C 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 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 or C methods will return C when there -are no more spans in the iterator. - -=item * start_set - -=item * end_set - -These methods do the inverse of the C method: - -C retrieves a DateTime::Set with the start datetime of each -span. - -C 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 inside the subroutine -may happen later than you expect. - -The callback return value is expected to be within the span of the -C and the C 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 inside the subroutine -may happen later than you expect. - -=item * iterate - -I - -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 object. - -If the callback returns C, 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 and the C 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 inside the subroutine -may happen later than you expect. - -=back - -=head1 SUPPORT - -Support is offered through the C mailing list. - -Please report bugs using rt.cpan.org - -=head1 AUTHOR - -Flavio Soibelmann Glock - -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. - -=cut - diff --git a/modules/fallback/Email/Address.pm b/modules/fallback/Email/Address.pm deleted file mode 100644 index 5fb84e815..000000000 --- a/modules/fallback/Email/Address.pm +++ /dev/null @@ -1,564 +0,0 @@ -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 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. - -=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 , "Casey" (West)] - ); - -This method returns a list of C 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 object. Takes four -positional arguments: phrase, email, and comment, and original string. - -The original string should only really be set using C. - -=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. - -=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 is checked. If that doesn't work out the C -is looked into. If that still doesn't work out, the C portion of -the C
is returned. - -This method does B 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 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. 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" - -=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 - -=head1 SEE ALSO - -L, L. - -=head1 AUTHOR - -Originally by Casey West, >. - -Maintained, 2006-2007, Ricardo SIGNES >. - -=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 - diff --git a/modules/fallback/List/MoreUtils.pm b/modules/fallback/List/MoreUtils.pm deleted file mode 100644 index 1251b532d..000000000 --- a/modules/fallback/List/MoreUtils.pm +++ /dev/null @@ -1,847 +0,0 @@ -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 provides some trivial but commonly needed functionality on -lists which is not going to go into L. - -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. 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. 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 is an alias for C. - -=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 is an alias for C. - -=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 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 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 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 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 if no such element -has been found. - -C is an alias for C. - -=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 if no such element has been -found. - -C is an alias for C. - -=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', 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 is an alias for C. - -=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 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 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 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'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 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 - -=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 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 -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 to pass-through the regular L -functions to end users only need to C 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 - -=head1 AUTHOR - -Tassilo von Parseval Etassilo.von.parseval@rwth-aachen.deE - -=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 diff --git a/modules/fallback/List/UtilsBy.pm b/modules/fallback/List/UtilsBy.pm deleted file mode 100644 index d4244f9ee..000000000 --- a/modules/fallback/List/UtilsBy.pm +++ /dev/null @@ -1,529 +0,0 @@ -# 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 - 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 functions of similar names, but which use the block -to control their behaviour. For example, the core Perl function C takes -a list of values and returns them, sorted into order by their string value. -The C 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 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 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 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 and C 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 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 function, this is also provided under the -name C 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 but returns values which give the numerically smallest -result from the key function. Also provided as C - -=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 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, 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, 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 in the missing elements. - -This function is an inverse of C, 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, 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 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. 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 functional, returns a list of the values returned -by C. 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 or L - -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 - -=cut - -0x55AA; diff --git a/modules/fallback/PBKDF2/Tiny.pm b/modules/fallback/PBKDF2/Tiny.pm deleted file mode 100644 index 7172fe1fe..000000000 --- a/modules/fallback/PBKDF2/Tiny.pm +++ /dev/null @@ -1,376 +0,0 @@ -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 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 a random salt of at -#pod least 8 octets. If you need a cryptographically strong salt, consider -#pod L. -#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 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 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. -#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 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: 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) 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 -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 or -L. - -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 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 a random salt of at -least 8 octets. If you need a cryptographically strong salt, consider -L. - -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 but outputs a hex string. - -=head2 verify - - $bool = verify( $dk, $type, $password, $salt, $iterations, $dk_length ); - -The C 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. - -=head2 verify_hex - -Works just like L 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: 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) and block size. - -=begin Pod::Coverage - - - - -=end Pod::Coverage - -=head1 SEE ALSO - -=over 4 - -=item * - -L - -=item * - -L - -=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. -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 - - git clone https://github.com/dagolden/PBKDF2-Tiny.git - -=head1 AUTHOR - -David Golden - -=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 diff --git a/modules/fallback/Regexp/IPv6.pm b/modules/fallback/Regexp/IPv6.pm deleted file mode 100644 index 24ecf5dfa..000000000 --- a/modules/fallback/Regexp/IPv6.pm +++ /dev/null @@ -1,65 +0,0 @@ -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. - -=head1 COPYRIGHT AND LICENSE - -Copyright (C) 2009, 2010 by Salvador FandiEo -(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 - diff --git a/modules/fallback/Set/Infinite.pm b/modules/fallback/Set/Infinite.pm deleted file mode 100644 index 72bda52a8..000000000 --- a/modules/fallback/Set/Infinite.pm +++ /dev/null @@ -1,1921 +0,0 @@ -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 method expects I parameters. - -If you have unordered ranges, you can build the set using C: - - @ranges = ( [ 10, 20 ], [ -10, 1 ] ); - $set = Set::Infinite->new; - $set = $set->union( @$_ ) for @ranges; - -The data structures passed to C must be I. -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 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. - -=head2 comparison - - sort - - > < == >= <= <=> - -See also: C 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 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