From ad15959e5e841c8f9c06c3dcd20120f969dc9857 Mon Sep 17 00:00:00 2001 From: Packit Service Date: Dec 10 2020 01:41:53 +0000 Subject: Changes after running %prep ignore: true --- diff --git a/MANIFEST b/MANIFEST index c269dc9..acecce8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1,28 +1,4 @@ bin/instmodsh -bundled/CPAN-Meta-Requirements/CPAN/Meta/Requirements.pm -bundled/CPAN-Meta-YAML/CPAN/Meta/YAML.pm -bundled/CPAN-Meta/CPAN/Meta.pm -bundled/CPAN-Meta/CPAN/Meta/Converter.pm -bundled/CPAN-Meta/CPAN/Meta/Feature.pm -bundled/CPAN-Meta/CPAN/Meta/History.pm -bundled/CPAN-Meta/CPAN/Meta/Merge.pm -bundled/CPAN-Meta/CPAN/Meta/Prereqs.pm -bundled/CPAN-Meta/CPAN/Meta/Spec.pm -bundled/CPAN-Meta/CPAN/Meta/Validator.pm -bundled/ExtUtils-Install/ExtUtils/Install.pm -bundled/ExtUtils-Install/ExtUtils/Installed.pm -bundled/ExtUtils-Install/ExtUtils/Packlist.pm -bundled/ExtUtils-Manifest/ExtUtils/Manifest.pm -bundled/ExtUtils-Manifest/ExtUtils/MANIFEST.SKIP -bundled/File-Temp/File/Temp.pm -bundled/JSON-PP/JSON/PP.pm -bundled/JSON-PP/JSON/PP/Boolean.pm -bundled/Parse-CPAN-Meta/Parse/CPAN/Meta.pm -bundled/README -bundled/Scalar-List-Utils/List/Util.pm -bundled/Scalar-List-Utils/List/Util/PP.pm -bundled/Scalar-List-Utils/Scalar/Util.pm -bundled/Scalar-List-Utils/Scalar/Util/PP.pm Changes CONTRIBUTING INSTALL @@ -33,11 +9,7 @@ lib/ExtUtils/Liblist/Kid.pm lib/ExtUtils/MakeMaker.pm lib/ExtUtils/MakeMaker/Config.pm lib/ExtUtils/MakeMaker/FAQ.pod -lib/ExtUtils/MakeMaker/Locale.pm lib/ExtUtils/MakeMaker/Tutorial.pod -lib/ExtUtils/MakeMaker/version.pm -lib/ExtUtils/MakeMaker/version/regex.pm -lib/ExtUtils/MakeMaker/version/vpp.pm lib/ExtUtils/Mkbootstrap.pm lib/ExtUtils/Mksymlists.pm lib/ExtUtils/MM.pm @@ -93,11 +65,6 @@ t/lib/MakeMaker/Test/NoXS.pm t/lib/MakeMaker/Test/Setup/BFD.pm t/lib/MakeMaker/Test/Setup/XS.pm t/lib/MakeMaker/Test/Utils.pm -t/lib/Test/Builder.pm -t/lib/Test/Builder/IO/Scalar.pm -t/lib/Test/Builder/Module.pm -t/lib/Test/More.pm -t/lib/Test/Simple.pm t/lib/TieIn.pm t/lib/TieOut.pm t/Liblist.t diff --git a/bundled/CPAN-Meta-Requirements/CPAN/Meta/Requirements.pm b/bundled/CPAN-Meta-Requirements/CPAN/Meta/Requirements.pm deleted file mode 100644 index cd5f24f..0000000 --- a/bundled/CPAN-Meta-Requirements/CPAN/Meta/Requirements.pm +++ /dev/null @@ -1,1101 +0,0 @@ -use strict; -use warnings; -package CPAN::Meta::Requirements; -# ABSTRACT: a set of version requirements for a CPAN dist - -our $VERSION = '2.131'; - -#pod =head1 SYNOPSIS -#pod -#pod use CPAN::Meta::Requirements; -#pod -#pod my $build_requires = CPAN::Meta::Requirements->new; -#pod -#pod $build_requires->add_minimum('Library::Foo' => 1.208); -#pod -#pod $build_requires->add_minimum('Library::Foo' => 2.602); -#pod -#pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); -#pod -#pod $METAyml->{build_requires} = $build_requires->as_string_hash; -#pod -#pod =head1 DESCRIPTION -#pod -#pod A CPAN::Meta::Requirements object models a set of version constraints like -#pod those specified in the F or F files in CPAN distributions, -#pod and as defined by L; -#pod It can be built up by adding more and more constraints, and it will reduce them -#pod to the simplest representation. -#pod -#pod Logically impossible constraints will be identified immediately by thrown -#pod exceptions. -#pod -#pod =cut - -use Carp (); - -# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls -# before 5.10, we fall back to the EUMM bundled compatibility version module if -# that's the only thing available. This shouldn't ever happen in a normal CPAN -# install of CPAN::Meta::Requirements, as version.pm will be picked up from -# prereqs and be available at runtime. - -BEGIN { - eval "use version ()"; ## no critic - if ( my $err = $@ ) { - eval "require ExtUtils::MakeMaker::version" or die $err; ## no critic - } -} - -# Perl 5.10.0 didn't have "is_qv" in version.pm -*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; - -# construct once, reuse many times -my $V0 = version->new(0); - -#pod =method new -#pod -#pod my $req = CPAN::Meta::Requirements->new; -#pod -#pod This returns a new CPAN::Meta::Requirements object. It takes an optional -#pod hash reference argument. Currently, only one key is supported: -#pod -#pod =for :list -#pod * C -- if provided, when a version cannot be parsed into -#pod a version object, this code reference will be called with the invalid -#pod version string as first argument, and the module name as second -#pod argument. It must return a valid version object. -#pod -#pod All other keys are ignored. -#pod -#pod =cut - -my @valid_options = qw( bad_version_hook ); - -sub new { - my ($class, $options) = @_; - $options ||= {}; - Carp::croak "Argument to $class\->new() must be a hash reference" - unless ref $options eq 'HASH'; - my %self = map {; $_ => $options->{$_}} @valid_options; - - return bless \%self => $class; -} - -# from version::vpp -sub _find_magic_vstring { - my $value = shift; - my $tvalue = ''; - require B; - my $sv = B::svref_2object(\$value); - my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; - while ( $magic ) { - if ( $magic->TYPE eq 'V' ) { - $tvalue = $magic->PTR; - $tvalue =~ s/^v?(.+)$/v$1/; - last; - } - else { - $magic = $magic->MOREMAGIC; - } - } - return $tvalue; -} - -# safe if given an unblessed reference -sub _isa_version { - UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version') -} - -sub _version_object { - my ($self, $module, $version) = @_; - - my $vobj; - - # hack around version::vpp not handling <3 character vstring literals - if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) { - my $magic = _find_magic_vstring( $version ); - $version = $magic if length $magic; - } - - eval { - if (not defined $version or $version eq '0') { - $vobj = $V0; - } - elsif ( ref($version) eq 'version' || _isa_version($version) ) { - $vobj = $version; - } - else { - local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" }; - $vobj = version->new($version); - } - }; - - if ( my $err = $@ ) { - my $hook = $self->{bad_version_hook}; - $vobj = eval { $hook->($version, $module) } - if ref $hook eq 'CODE'; - unless (eval { $vobj->isa("version") }) { - $err =~ s{ at .* line \d+.*$}{}; - die "Can't convert '$version': $err"; - } - } - - # ensure no leading '.' - if ( $vobj =~ m{\A\.} ) { - $vobj = version->new("0$vobj"); - } - - # ensure normal v-string form - if ( _is_qv($vobj) ) { - $vobj = version->new($vobj->normal); - } - - return $vobj; -} - -#pod =method add_minimum -#pod -#pod $req->add_minimum( $module => $version ); -#pod -#pod This adds a new minimum version requirement. If the new requirement is -#pod redundant to the existing specification, this has no effect. -#pod -#pod Minimum requirements are inclusive. C<$version> is required, along with any -#pod greater version number. -#pod -#pod This method returns the requirements object. -#pod -#pod =method add_maximum -#pod -#pod $req->add_maximum( $module => $version ); -#pod -#pod This adds a new maximum version requirement. If the new requirement is -#pod redundant to the existing specification, this has no effect. -#pod -#pod Maximum requirements are inclusive. No version strictly greater than the given -#pod version is allowed. -#pod -#pod This method returns the requirements object. -#pod -#pod =method add_exclusion -#pod -#pod $req->add_exclusion( $module => $version ); -#pod -#pod This adds a new excluded version. For example, you might use these three -#pod method calls: -#pod -#pod $req->add_minimum( $module => '1.00' ); -#pod $req->add_maximum( $module => '1.82' ); -#pod -#pod $req->add_exclusion( $module => '1.75' ); -#pod -#pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for -#pod 1.75. -#pod -#pod This method returns the requirements object. -#pod -#pod =method exact_version -#pod -#pod $req->exact_version( $module => $version ); -#pod -#pod This sets the version required for the given module to I the given -#pod version. No other version would be considered acceptable. -#pod -#pod This method returns the requirements object. -#pod -#pod =cut - -BEGIN { - for my $type (qw(maximum exclusion exact_version)) { - my $method = "with_$type"; - my $to_add = $type eq 'exact_version' ? $type : "add_$type"; - - my $code = sub { - my ($self, $name, $version) = @_; - - $version = $self->_version_object( $name, $version ); - - $self->__modify_entry_for($name, $method, $version); - - return $self; - }; - - no strict 'refs'; - *$to_add = $code; - } -} - -sub add_minimum { - my ($self, $name, $version) = @_; - - if (not defined $version or $version eq '0') { - return $self if $self->__entry_for($name); - Carp::confess("can't add new requirements to finalized requirements") - if $self->is_finalized; - - $self->{requirements}{ $name } = - CPAN::Meta::Requirements::_Range::Range->with_minimum($V0); - } - else { - $version = $self->_version_object( $name, $version ); - - $self->__modify_entry_for($name, 'with_minimum', $version); - } - return $self; -} - -#pod =method add_requirements -#pod -#pod $req->add_requirements( $another_req_object ); -#pod -#pod This method adds all the requirements in the given CPAN::Meta::Requirements object -#pod to the requirements object on which it was called. If there are any conflicts, -#pod an exception is thrown. -#pod -#pod This method returns the requirements object. -#pod -#pod =cut - -sub add_requirements { - my ($self, $req) = @_; - - for my $module ($req->required_modules) { - my $modifiers = $req->__entry_for($module)->as_modifiers; - for my $modifier (@$modifiers) { - my ($method, @args) = @$modifier; - $self->$method($module => @args); - }; - } - - return $self; -} - -#pod =method accepts_module -#pod -#pod my $bool = $req->accepts_module($module => $version); -#pod -#pod Given an module and version, this method returns true if the version -#pod specification for the module accepts the provided version. In other words, -#pod given: -#pod -#pod Module => '>= 1.00, < 2.00' -#pod -#pod We will accept 1.00 and 1.75 but not 0.50 or 2.00. -#pod -#pod For modules that do not appear in the requirements, this method will return -#pod true. -#pod -#pod =cut - -sub accepts_module { - my ($self, $module, $version) = @_; - - $version = $self->_version_object( $module, $version ); - - return 1 unless my $range = $self->__entry_for($module); - return $range->_accepts($version); -} - -#pod =method clear_requirement -#pod -#pod $req->clear_requirement( $module ); -#pod -#pod This removes the requirement for a given module from the object. -#pod -#pod This method returns the requirements object. -#pod -#pod =cut - -sub clear_requirement { - my ($self, $module) = @_; - - return $self unless $self->__entry_for($module); - - Carp::confess("can't clear requirements on finalized requirements") - if $self->is_finalized; - - delete $self->{requirements}{ $module }; - - return $self; -} - -#pod =method requirements_for_module -#pod -#pod $req->requirements_for_module( $module ); -#pod -#pod This returns a string containing the version requirements for a given module in -#pod the format described in L or undef if the given module has no -#pod requirements. This should only be used for informational purposes such as error -#pod messages and should not be interpreted or used for comparison (see -#pod L instead.) -#pod -#pod =cut - -sub requirements_for_module { - my ($self, $module) = @_; - my $entry = $self->__entry_for($module); - return unless $entry; - return $entry->as_string; -} - -#pod =method required_modules -#pod -#pod This method returns a list of all the modules for which requirements have been -#pod specified. -#pod -#pod =cut - -sub required_modules { keys %{ $_[0]{requirements} } } - -#pod =method clone -#pod -#pod $req->clone; -#pod -#pod This method returns a clone of the invocant. The clone and the original object -#pod can then be changed independent of one another. -#pod -#pod =cut - -sub clone { - my ($self) = @_; - my $new = (ref $self)->new; - - return $new->add_requirements($self); -} - -sub __entry_for { $_[0]{requirements}{ $_[1] } } - -sub __modify_entry_for { - my ($self, $name, $method, $version) = @_; - - my $fin = $self->is_finalized; - my $old = $self->__entry_for($name); - - Carp::confess("can't add new requirements to finalized requirements") - if $fin and not $old; - - my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range') - ->$method($version); - - Carp::confess("can't modify finalized requirements") - if $fin and $old->as_string ne $new->as_string; - - $self->{requirements}{ $name } = $new; -} - -#pod =method is_simple -#pod -#pod This method returns true if and only if all requirements are inclusive minimums -#pod -- that is, if their string expression is just the version number. -#pod -#pod =cut - -sub is_simple { - my ($self) = @_; - for my $module ($self->required_modules) { - # XXX: This is a complete hack, but also entirely correct. - return if $self->__entry_for($module)->as_string =~ /\s/; - } - - return 1; -} - -#pod =method is_finalized -#pod -#pod This method returns true if the requirements have been finalized by having the -#pod C method called on them. -#pod -#pod =cut - -sub is_finalized { $_[0]{finalized} } - -#pod =method finalize -#pod -#pod This method marks the requirements finalized. Subsequent attempts to change -#pod the requirements will be fatal, I they would result in a change. If they -#pod would not alter the requirements, they have no effect. -#pod -#pod If a finalized set of requirements is cloned, the cloned requirements are not -#pod also finalized. -#pod -#pod =cut - -sub finalize { $_[0]{finalized} = 1 } - -#pod =method as_string_hash -#pod -#pod This returns a reference to a hash describing the requirements using the -#pod strings in the L specification. -#pod -#pod For example after the following program: -#pod -#pod my $req = CPAN::Meta::Requirements->new; -#pod -#pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102); -#pod -#pod $req->add_minimum('Library::Foo' => 1.208); -#pod -#pod $req->add_maximum('Library::Foo' => 2.602); -#pod -#pod $req->add_minimum('Module::Bar' => 'v1.2.3'); -#pod -#pod $req->add_exclusion('Module::Bar' => 'v1.2.8'); -#pod -#pod $req->exact_version('Xyzzy' => '6.01'); -#pod -#pod my $hashref = $req->as_string_hash; -#pod -#pod C<$hashref> would contain: -#pod -#pod { -#pod 'CPAN::Meta::Requirements' => '0.102', -#pod 'Library::Foo' => '>= 1.208, <= 2.206', -#pod 'Module::Bar' => '>= v1.2.3, != v1.2.8', -#pod 'Xyzzy' => '== 6.01', -#pod } -#pod -#pod =cut - -sub as_string_hash { - my ($self) = @_; - - my %hash = map {; $_ => $self->{requirements}{$_}->as_string } - $self->required_modules; - - return \%hash; -} - -#pod =method add_string_requirement -#pod -#pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); -#pod $req->add_string_requirement('Library::Foo' => v1.208); -#pod -#pod This method parses the passed in string and adds the appropriate requirement -#pod for the given module. A version can be a Perl "v-string". It understands -#pod version ranges as described in the L. For -#pod example: -#pod -#pod =over 4 -#pod -#pod =item 1.3 -#pod -#pod =item >= 1.3 -#pod -#pod =item <= 1.3 -#pod -#pod =item == 1.3 -#pod -#pod =item != 1.3 -#pod -#pod =item > 1.3 -#pod -#pod =item < 1.3 -#pod -#pod =item >= 1.3, != 1.5, <= 2.0 -#pod -#pod A version number without an operator is equivalent to specifying a minimum -#pod (C=>). Extra whitespace is allowed. -#pod -#pod =back -#pod -#pod =cut - -my %methods_for_op = ( - '==' => [ qw(exact_version) ], - '!=' => [ qw(add_exclusion) ], - '>=' => [ qw(add_minimum) ], - '<=' => [ qw(add_maximum) ], - '>' => [ qw(add_minimum add_exclusion) ], - '<' => [ qw(add_maximum add_exclusion) ], -); - -sub add_string_requirement { - my ($self, $module, $req) = @_; - - unless ( defined $req && length $req ) { - $req = 0; - $self->_blank_carp($module); - } - - my $magic = _find_magic_vstring( $req ); - if (length $magic) { - $self->add_minimum($module => $magic); - return; - } - - my @parts = split qr{\s*,\s*}, $req; - - for my $part (@parts) { - my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z}; - - if (! defined $op) { - $self->add_minimum($module => $part); - } else { - Carp::confess("illegal requirement string: $req") - unless my $methods = $methods_for_op{ $op }; - - $self->$_($module => $ver) for @$methods; - } - } -} - -#pod =method from_string_hash -#pod -#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); -#pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); -#pod -#pod This is an alternate constructor for a CPAN::Meta::Requirements -#pod object. It takes a hash of module names and version requirement -#pod strings and returns a new CPAN::Meta::Requirements object. As with -#pod add_string_requirement, a version can be a Perl "v-string". Optionally, -#pod you can supply a hash-reference of options, exactly as with the L -#pod method. -#pod -#pod =cut - -sub _blank_carp { - my ($self, $module) = @_; - Carp::carp("Undefined requirement for $module treated as '0'"); -} - -sub from_string_hash { - my ($class, $hash, $options) = @_; - - my $self = $class->new($options); - - for my $module (keys %$hash) { - my $req = $hash->{$module}; - unless ( defined $req && length $req ) { - $req = 0; - $class->_blank_carp($module); - } - $self->add_string_requirement($module, $req); - } - - return $self; -} - -############################################################## - -{ - package - CPAN::Meta::Requirements::_Range::Exact; - sub _new { bless { version => $_[1] } => $_[0] } - - sub _accepts { return $_[0]{version} == $_[1] } - - sub as_string { return "== $_[0]{version}" } - - sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] } - - sub _clone { - (ref $_[0])->_new( version->new( $_[0]{version} ) ) - } - - sub with_exact_version { - my ($self, $version) = @_; - - return $self->_clone if $self->_accepts($version); - - Carp::confess("illegal requirements: unequal exact version specified"); - } - - sub with_minimum { - my ($self, $minimum) = @_; - return $self->_clone if $self->{version} >= $minimum; - Carp::confess("illegal requirements: minimum above exact specification"); - } - - sub with_maximum { - my ($self, $maximum) = @_; - return $self->_clone if $self->{version} <= $maximum; - Carp::confess("illegal requirements: maximum below exact specification"); - } - - sub with_exclusion { - my ($self, $exclusion) = @_; - return $self->_clone unless $exclusion == $self->{version}; - Carp::confess("illegal requirements: excluded exact specification"); - } -} - -############################################################## - -{ - package - CPAN::Meta::Requirements::_Range::Range; - - sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) } - - sub _clone { - return (bless { } => $_[0]) unless ref $_[0]; - - my ($s) = @_; - my %guts = ( - (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()), - (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()), - - (exists $s->{exclusions} - ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ]) - : ()), - ); - - bless \%guts => ref($s); - } - - sub as_modifiers { - my ($self) = @_; - my @mods; - push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum}; - push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum}; - push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []}; - return \@mods; - } - - sub as_string { - my ($self) = @_; - - return 0 if ! keys %$self; - - return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum}; - - my @exclusions = @{ $self->{exclusions} || [] }; - - my @parts; - - for my $pair ( - [ qw( >= > minimum ) ], - [ qw( <= < maximum ) ], - ) { - my ($op, $e_op, $k) = @$pair; - if (exists $self->{$k}) { - my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions; - if (@new_exclusions == @exclusions) { - push @parts, "$op $self->{ $k }"; - } else { - push @parts, "$e_op $self->{ $k }"; - @exclusions = @new_exclusions; - } - } - } - - push @parts, map {; "!= $_" } @exclusions; - - return join q{, }, @parts; - } - - sub with_exact_version { - my ($self, $version) = @_; - $self = $self->_clone; - - Carp::confess("illegal requirements: exact specification outside of range") - unless $self->_accepts($version); - - return CPAN::Meta::Requirements::_Range::Exact->_new($version); - } - - sub _simplify { - my ($self) = @_; - - if (defined $self->{minimum} and defined $self->{maximum}) { - if ($self->{minimum} == $self->{maximum}) { - Carp::confess("illegal requirements: excluded all values") - if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }; - - return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum}) - } - - Carp::confess("illegal requirements: minimum exceeds maximum") - if $self->{minimum} > $self->{maximum}; - } - - # eliminate irrelevant exclusions - if ($self->{exclusions}) { - my %seen; - @{ $self->{exclusions} } = grep { - (! defined $self->{minimum} or $_ >= $self->{minimum}) - and - (! defined $self->{maximum} or $_ <= $self->{maximum}) - and - ! $seen{$_}++ - } @{ $self->{exclusions} }; - } - - return $self; - } - - sub with_minimum { - my ($self, $minimum) = @_; - $self = $self->_clone; - - if (defined (my $old_min = $self->{minimum})) { - $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0]; - } else { - $self->{minimum} = $minimum; - } - - return $self->_simplify; - } - - sub with_maximum { - my ($self, $maximum) = @_; - $self = $self->_clone; - - if (defined (my $old_max = $self->{maximum})) { - $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0]; - } else { - $self->{maximum} = $maximum; - } - - return $self->_simplify; - } - - sub with_exclusion { - my ($self, $exclusion) = @_; - $self = $self->_clone; - - push @{ $self->{exclusions} ||= [] }, $exclusion; - - return $self->_simplify; - } - - sub _accepts { - my ($self, $version) = @_; - - return if defined $self->{minimum} and $version < $self->{minimum}; - return if defined $self->{maximum} and $version > $self->{maximum}; - return if defined $self->{exclusions} - and grep { $version == $_ } @{ $self->{exclusions} }; - - return 1; - } -} - -1; -# vim: ts=2 sts=2 sw=2 et: - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Requirements - a set of version requirements for a CPAN dist - -=head1 VERSION - -version 2.131 - -=head1 SYNOPSIS - - use CPAN::Meta::Requirements; - - my $build_requires = CPAN::Meta::Requirements->new; - - $build_requires->add_minimum('Library::Foo' => 1.208); - - $build_requires->add_minimum('Library::Foo' => 2.602); - - $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); - - $METAyml->{build_requires} = $build_requires->as_string_hash; - -=head1 DESCRIPTION - -A CPAN::Meta::Requirements object models a set of version constraints like -those specified in the F or F files in CPAN distributions, -and as defined by L; -It can be built up by adding more and more constraints, and it will reduce them -to the simplest representation. - -Logically impossible constraints will be identified immediately by thrown -exceptions. - -=head1 METHODS - -=head2 new - - my $req = CPAN::Meta::Requirements->new; - -This returns a new CPAN::Meta::Requirements object. It takes an optional -hash reference argument. Currently, only one key is supported: - -=over 4 - -=item * - -C -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object. - -=back - -All other keys are ignored. - -=head2 add_minimum - - $req->add_minimum( $module => $version ); - -This adds a new minimum version requirement. If the new requirement is -redundant to the existing specification, this has no effect. - -Minimum requirements are inclusive. C<$version> is required, along with any -greater version number. - -This method returns the requirements object. - -=head2 add_maximum - - $req->add_maximum( $module => $version ); - -This adds a new maximum version requirement. If the new requirement is -redundant to the existing specification, this has no effect. - -Maximum requirements are inclusive. No version strictly greater than the given -version is allowed. - -This method returns the requirements object. - -=head2 add_exclusion - - $req->add_exclusion( $module => $version ); - -This adds a new excluded version. For example, you might use these three -method calls: - - $req->add_minimum( $module => '1.00' ); - $req->add_maximum( $module => '1.82' ); - - $req->add_exclusion( $module => '1.75' ); - -Any version between 1.00 and 1.82 inclusive would be acceptable, except for -1.75. - -This method returns the requirements object. - -=head2 exact_version - - $req->exact_version( $module => $version ); - -This sets the version required for the given module to I the given -version. No other version would be considered acceptable. - -This method returns the requirements object. - -=head2 add_requirements - - $req->add_requirements( $another_req_object ); - -This method adds all the requirements in the given CPAN::Meta::Requirements object -to the requirements object on which it was called. If there are any conflicts, -an exception is thrown. - -This method returns the requirements object. - -=head2 accepts_module - - my $bool = $req->accepts_module($module => $version); - -Given an module and version, this method returns true if the version -specification for the module accepts the provided version. In other words, -given: - - Module => '>= 1.00, < 2.00' - -We will accept 1.00 and 1.75 but not 0.50 or 2.00. - -For modules that do not appear in the requirements, this method will return -true. - -=head2 clear_requirement - - $req->clear_requirement( $module ); - -This removes the requirement for a given module from the object. - -This method returns the requirements object. - -=head2 requirements_for_module - - $req->requirements_for_module( $module ); - -This returns a string containing the version requirements for a given module in -the format described in L or undef if the given module has no -requirements. This should only be used for informational purposes such as error -messages and should not be interpreted or used for comparison (see -L instead.) - -=head2 required_modules - -This method returns a list of all the modules for which requirements have been -specified. - -=head2 clone - - $req->clone; - -This method returns a clone of the invocant. The clone and the original object -can then be changed independent of one another. - -=head2 is_simple - -This method returns true if and only if all requirements are inclusive minimums --- that is, if their string expression is just the version number. - -=head2 is_finalized - -This method returns true if the requirements have been finalized by having the -C method called on them. - -=head2 finalize - -This method marks the requirements finalized. Subsequent attempts to change -the requirements will be fatal, I they would result in a change. If they -would not alter the requirements, they have no effect. - -If a finalized set of requirements is cloned, the cloned requirements are not -also finalized. - -=head2 as_string_hash - -This returns a reference to a hash describing the requirements using the -strings in the L specification. - -For example after the following program: - - my $req = CPAN::Meta::Requirements->new; - - $req->add_minimum('CPAN::Meta::Requirements' => 0.102); - - $req->add_minimum('Library::Foo' => 1.208); - - $req->add_maximum('Library::Foo' => 2.602); - - $req->add_minimum('Module::Bar' => 'v1.2.3'); - - $req->add_exclusion('Module::Bar' => 'v1.2.8'); - - $req->exact_version('Xyzzy' => '6.01'); - - my $hashref = $req->as_string_hash; - -C<$hashref> would contain: - - { - 'CPAN::Meta::Requirements' => '0.102', - 'Library::Foo' => '>= 1.208, <= 2.206', - 'Module::Bar' => '>= v1.2.3, != v1.2.8', - 'Xyzzy' => '== 6.01', - } - -=head2 add_string_requirement - - $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); - $req->add_string_requirement('Library::Foo' => v1.208); - -This method parses the passed in string and adds the appropriate requirement -for the given module. A version can be a Perl "v-string". It understands -version ranges as described in the L. For -example: - -=over 4 - -=item 1.3 - -=item >= 1.3 - -=item <= 1.3 - -=item == 1.3 - -=item != 1.3 - -=item > 1.3 - -=item < 1.3 - -=item >= 1.3, != 1.5, <= 2.0 - -A version number without an operator is equivalent to specifying a minimum -(C=>). Extra whitespace is allowed. - -=back - -=head2 from_string_hash - - my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); - my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); - -This is an alternate constructor for a CPAN::Meta::Requirements -object. It takes a hash of module names and version requirement -strings and returns a new CPAN::Meta::Requirements object. As with -add_string_requirement, a version can be a Perl "v-string". Optionally, -you can supply a hash-reference of options, exactly as with the L -method. - -=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/CPAN-Meta-Requirements.git - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 CONTRIBUTORS - -=for stopwords Ed J Karen Etheridge Leon Timmermans robario - -=over 4 - -=item * - -Ed J - -=item * - -Karen Etheridge - -=item * - -Leon Timmermans - -=item * - -robario - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta-YAML/CPAN/Meta/YAML.pm b/bundled/CPAN-Meta-YAML/CPAN/Meta/YAML.pm deleted file mode 100644 index b751f95..0000000 --- a/bundled/CPAN-Meta-YAML/CPAN/Meta/YAML.pm +++ /dev/null @@ -1,973 +0,0 @@ -use 5.008001; # sane UTF-8 support -use strict; -use warnings; -package CPAN::Meta::YAML; -$CPAN::Meta::YAML::VERSION = '0.011'; -BEGIN { - $CPAN::Meta::YAML::AUTHORITY = 'cpan:ADAMK'; -} -# git description: v1.59-TRIAL-1-g33d9cd2 -; # original $VERSION removed by Doppelgaenger -# XXX-INGY is 5.8.1 too old/broken for utf8? -# XXX-XDG Lancaster consensus was that it was sufficient until -# proven otherwise - - -##################################################################### -# The CPAN::Meta::YAML API. -# -# These are the currently documented API functions/methods and -# exports: - -use Exporter; -our @ISA = qw{ Exporter }; -our @EXPORT = qw{ Load Dump }; -our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; - -### -# Functional/Export API: - -sub Dump { - return CPAN::Meta::YAML->new(@_)->_dump_string; -} - -# XXX-INGY Returning last document seems a bad behavior. -# XXX-XDG I think first would seem more natural, but I don't know -# that it's worth changing now -sub Load { - my $self = CPAN::Meta::YAML->_load_string(@_); - if ( wantarray ) { - return @$self; - } else { - # To match YAML.pm, return the last document - return $self->[-1]; - } -} - -# XXX-INGY Do we really need freeze and thaw? -# XXX-XDG I don't think so. I'd support deprecating them. -BEGIN { - *freeze = \&Dump; - *thaw = \&Load; -} - -sub DumpFile { - my $file = shift; - return CPAN::Meta::YAML->new(@_)->_dump_file($file); -} - -sub LoadFile { - my $file = shift; - my $self = CPAN::Meta::YAML->_load_file($file); - if ( wantarray ) { - return @$self; - } else { - # Return only the last document to match YAML.pm, - return $self->[-1]; - } -} - - -### -# Object Oriented API: - -# Create an empty CPAN::Meta::YAML object -# XXX-INGY Why do we use ARRAY object? -# NOTE: I get it now, but I think it's confusing and not needed. -# Will change it on a branch later, for review. -# -# XXX-XDG I don't support changing it yet. It's a very well-documented -# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested -# we not change it until YAML.pm's own OO API is established so that -# users only have one API change to digest, not two -sub new { - my $class = shift; - bless [ @_ ], $class; -} - -# XXX-INGY It probably doesn't matter, and it's probably too late to -# change, but 'read/write' are the wrong names. Read and Write -# are actions that take data from storage to memory -# characters/strings. These take the data to/from storage to native -# Perl objects, which the terms dump and load are meant. As long as -# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not -# to add new {read,write}_* methods to this API. - -sub read_string { - my $self = shift; - $self->_load_string(@_); -} - -sub write_string { - my $self = shift; - $self->_dump_string(@_); -} - -sub read { - my $self = shift; - $self->_load_file(@_); -} - -sub write { - my $self = shift; - $self->_dump_file(@_); -} - - - - -##################################################################### -# Constants - -# Printed form of the unprintable characters in the lowest range -# of ASCII characters, listed by ASCII ordinal position. -my @UNPRINTABLE = qw( - 0 x01 x02 x03 x04 x05 x06 a - b t n v f r x0E x0F - x10 x11 x12 x13 x14 x15 x16 x17 - x18 x19 x1A e x1C x1D x1E x1F -); - -# Printable characters for escapes -my %UNESCAPES = ( - 0 => "\x00", z => "\x00", N => "\x85", - a => "\x07", b => "\x08", t => "\x09", - n => "\x0a", v => "\x0b", f => "\x0c", - r => "\x0d", e => "\x1b", '\\' => '\\', -); - -# XXX-INGY -# I(ngy) need to decide if these values should be quoted in -# CPAN::Meta::YAML or not. Probably yes. - -# These 3 values have special meaning when unquoted and using the -# default YAML schema. They need quotes if they are strings. -my %QUOTE = map { $_ => 1 } qw{ - null true false -}; - -# The commented out form is simpler, but overloaded the Perl regex -# engine due to recursion and backtracking problems on strings -# larger than 32,000ish characters. Keep it for reference purposes. -# qr/\"((?:\\.|[^\"])*)\"/ -my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/; -my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/; -# unquoted re gets trailing space that needs to be stripped -my $re_capture_unquoted_key = qr/([^:]+(?::+\S[^:]*)*)(?=\s*\:(?:\s+|$))/; -my $re_trailing_comment = qr/(?:\s+\#.*)?/; -my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/; - - - - - -##################################################################### -# CPAN::Meta::YAML Implementation. -# -# These are the private methods that do all the work. They may change -# at any time. - - -### -# Loader functions: - -# Create an object from a file -sub _load_file { - my $class = ref $_[0] ? ref shift : shift; - - # Check the file - my $file = shift or $class->_error( 'You did not specify a file name' ); - $class->_error( "File '$file' does not exist" ) - unless -e $file; - $class->_error( "'$file' is a directory, not a file" ) - unless -f _; - $class->_error( "Insufficient permissions to read '$file'" ) - unless -r _; - - # Open unbuffered with strict UTF-8 decoding and no translation layers - open( my $fh, "<:unix:encoding(UTF-8)", $file ); - unless ( $fh ) { - $class->_error("Failed to open file '$file': $!"); - } - - # flock if available (or warn if not possible for OS-specific reasons) - if ( _can_flock() ) { - flock( $fh, Fcntl::LOCK_SH() ) - or warn "Couldn't lock '$file' for reading: $!"; - } - - # slurp the contents - my $contents = eval { - use warnings FATAL => 'utf8'; - local $/; - <$fh> - }; - if ( my $err = $@ ) { - $class->_error("Error reading from file '$file': $err"); - } - - # close the file (release the lock) - unless ( close $fh ) { - $class->_error("Failed to close file '$file': $!"); - } - - $class->_load_string( $contents ); -} - -# Create an object from a string -sub _load_string { - my $class = ref $_[0] ? ref shift : shift; - my $self = bless [], $class; - my $string = $_[0]; - eval { - unless ( defined $string ) { - die \"Did not provide a string to load"; - } - - # Check if Perl has it marked as characters, but it's internally - # inconsistent. E.g. maybe latin1 got read on a :utf8 layer - if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { - die \<<'...'; -Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). -Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? -... - } - - # Ensure Unicode character semantics, even for 0x80-0xff - utf8::upgrade($string); - - # Check for and strip any leading UTF-8 BOM - $string =~ s/^\x{FEFF}//; - - # Check for some special cases - return $self unless length $string; - - # Split the file into lines - my @lines = grep { ! /^\s*(?:\#.*)?\z/ } - split /(?:\015{1,2}\012|\015|\012)/, $string; - - # Strip the initial YAML header - @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; - - # A nibbling parser - my $in_document = 0; - while ( @lines ) { - # Do we have a document header? - if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { - # Handle scalar documents - shift @lines; - if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { - push @$self, - $self->_load_scalar( "$1", [ undef ], \@lines ); - next; - } - $in_document = 1; - } - - if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { - # A naked document - push @$self, undef; - while ( @lines and $lines[0] !~ /^---/ ) { - shift @lines; - } - $in_document = 0; - - # XXX The final '-+$' is to look for -- which ends up being an - # error later. - } elsif ( ! $in_document && @$self ) { - # only the first document can be explicit - die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; - } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) { - # An array at the root - my $document = [ ]; - push @$self, $document; - $self->_load_array( $document, [ 0 ], \@lines ); - - } elsif ( $lines[0] =~ /^(\s*)\S/ ) { - # A hash at the root - my $document = { }; - push @$self, $document; - $self->_load_hash( $document, [ length($1) ], \@lines ); - - } else { - # Shouldn't get here. @lines have whitespace-only lines - # stripped, and previous match is a line with any - # non-whitespace. So this clause should only be reachable via - # a perlbug where \s is not symmetric with \S - - # uncoverable statement - die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; - } - } - }; - if ( ref $@ eq 'SCALAR' ) { - $self->_error(${$@}); - } elsif ( $@ ) { - $self->_error($@); - } - - return $self; -} - -sub _unquote_single { - my ($self, $string) = @_; - return '' unless length $string; - $string =~ s/\'\'/\'/g; - return $string; -} - -sub _unquote_double { - my ($self, $string) = @_; - return '' unless length $string; - $string =~ s/\\"/"/g; - $string =~ - s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} - {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex; - return $string; -} - -# Load a YAML scalar string to the actual Perl scalar -sub _load_scalar { - my ($self, $string, $indent, $lines) = @_; - - # Trim trailing whitespace - $string =~ s/\s*\z//; - - # Explitic null/undef - return undef if $string eq '~'; - - # Single quote - if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) { - return $self->_unquote_single($1); - } - - # Double quote. - if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) { - return $self->_unquote_double($1); - } - - # Special cases - if ( $string =~ /^[\'\"!&]/ ) { - die \"CPAN::Meta::YAML does not support a feature in line '$string'"; - } - return {} if $string =~ /^{}(?:\s+\#.*)?\z/; - return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; - - # Regular unquoted string - if ( $string !~ /^[>|]/ ) { - die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" - if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or - $string =~ /:(?:\s|$)/; - $string =~ s/\s+#.*\z//; - return $string; - } - - # Error - die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines; - - # Check the indent depth - $lines->[0] =~ /^(\s*)/; - $indent->[-1] = length("$1"); - if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { - die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; - } - - # Pull the lines - my @multiline = (); - while ( @$lines ) { - $lines->[0] =~ /^(\s*)/; - last unless length($1) >= $indent->[-1]; - push @multiline, substr(shift(@$lines), length($1)); - } - - my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; - my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; - return join( $j, @multiline ) . $t; -} - -# Load an array -sub _load_array { - my ($self, $array, $indent, $lines) = @_; - - while ( @$lines ) { - # Check for a new document - if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { - while ( @$lines and $lines->[0] !~ /^---/ ) { - shift @$lines; - } - return 1; - } - - # Check the indent level - $lines->[0] =~ /^(\s*)/; - if ( length($1) < $indent->[-1] ) { - return 1; - } elsif ( length($1) > $indent->[-1] ) { - die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; - } - - if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { - # Inline nested hash - my $indent2 = length("$1"); - $lines->[0] =~ s/-/ /; - push @$array, { }; - $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); - - } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { - shift @$lines; - unless ( @$lines ) { - push @$array, undef; - return 1; - } - if ( $lines->[0] =~ /^(\s*)\-/ ) { - my $indent2 = length("$1"); - if ( $indent->[-1] == $indent2 ) { - # Null array entry - push @$array, undef; - } else { - # Naked indenter - push @$array, [ ]; - $self->_load_array( - $array->[-1], [ @$indent, $indent2 ], $lines - ); - } - - } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { - push @$array, { }; - $self->_load_hash( - $array->[-1], [ @$indent, length("$1") ], $lines - ); - - } else { - die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; - } - - } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { - # Array entry with a value - shift @$lines; - push @$array, $self->_load_scalar( - "$2", [ @$indent, undef ], $lines - ); - - } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { - # This is probably a structure like the following... - # --- - # foo: - # - list - # bar: value - # - # ... so lets return and let the hash parser handle it - return 1; - - } else { - die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; - } - } - - return 1; -} - -# Load a hash -sub _load_hash { - my ($self, $hash, $indent, $lines) = @_; - - while ( @$lines ) { - # Check for a new document - if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { - while ( @$lines and $lines->[0] !~ /^---/ ) { - shift @$lines; - } - return 1; - } - - # Check the indent level - $lines->[0] =~ /^(\s*)/; - if ( length($1) < $indent->[-1] ) { - return 1; - } elsif ( length($1) > $indent->[-1] ) { - die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; - } - - # Find the key - my $key; - - # Quoted keys - if ( $lines->[0] =~ - s/^\s*$re_capture_single_quoted$re_key_value_separator// - ) { - $key = $self->_unquote_single($1); - } - elsif ( $lines->[0] =~ - s/^\s*$re_capture_double_quoted$re_key_value_separator// - ) { - $key = $self->_unquote_double($1); - } - elsif ( $lines->[0] =~ - s/^\s*$re_capture_unquoted_key$re_key_value_separator// - ) { - $key = $1; - $key =~ s/\s+$//; - } - elsif ( $lines->[0] =~ /^\s*\?/ ) { - die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"; - } - else { - die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; - } - - # Do we have a value? - if ( length $lines->[0] ) { - # Yes - $hash->{$key} = $self->_load_scalar( - shift(@$lines), [ @$indent, undef ], $lines - ); - } else { - # An indent - shift @$lines; - unless ( @$lines ) { - $hash->{$key} = undef; - return 1; - } - if ( $lines->[0] =~ /^(\s*)-/ ) { - $hash->{$key} = []; - $self->_load_array( - $hash->{$key}, [ @$indent, length($1) ], $lines - ); - } elsif ( $lines->[0] =~ /^(\s*)./ ) { - my $indent2 = length("$1"); - if ( $indent->[-1] >= $indent2 ) { - # Null hash entry - $hash->{$key} = undef; - } else { - $hash->{$key} = {}; - $self->_load_hash( - $hash->{$key}, [ @$indent, length($1) ], $lines - ); - } - } - } - } - - return 1; -} - - -### -# Dumper functions: - -# Save an object to a file -sub _dump_file { - my $self = shift; - - require Fcntl; - - # Check the file - my $file = shift or $self->_error( 'You did not specify a file name' ); - - my $fh; - # flock if available (or warn if not possible for OS-specific reasons) - if ( _can_flock() ) { - # Open without truncation (truncate comes after lock) - my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT(); - sysopen( $fh, $file, $flags ); - unless ( $fh ) { - $self->_error("Failed to open file '$file' for writing: $!"); - } - - # Use no translation and strict UTF-8 - binmode( $fh, ":raw:encoding(UTF-8)"); - - flock( $fh, Fcntl::LOCK_EX() ) - or warn "Couldn't lock '$file' for reading: $!"; - - # truncate and spew contents - truncate $fh, 0; - seek $fh, 0, 0; - } - else { - open $fh, ">:unix:encoding(UTF-8)", $file; - } - - # serialize and spew to the handle - print {$fh} $self->_dump_string; - - # close the file (release the lock) - unless ( close $fh ) { - $self->_error("Failed to close file '$file': $!"); - } - - return 1; -} - -# Save an object to a string -sub _dump_string { - my $self = shift; - return '' unless ref $self && @$self; - - # Iterate over the documents - my $indent = 0; - my @lines = (); - - eval { - foreach my $cursor ( @$self ) { - push @lines, '---'; - - # An empty document - if ( ! defined $cursor ) { - # Do nothing - - # A scalar document - } elsif ( ! ref $cursor ) { - $lines[-1] .= ' ' . $self->_dump_scalar( $cursor ); - - # A list at the root - } elsif ( ref $cursor eq 'ARRAY' ) { - unless ( @$cursor ) { - $lines[-1] .= ' []'; - next; - } - push @lines, $self->_dump_array( $cursor, $indent, {} ); - - # A hash at the root - } elsif ( ref $cursor eq 'HASH' ) { - unless ( %$cursor ) { - $lines[-1] .= ' {}'; - next; - } - push @lines, $self->_dump_hash( $cursor, $indent, {} ); - - } else { - die \("Cannot serialize " . ref($cursor)); - } - } - }; - if ( ref $@ eq 'SCALAR' ) { - $self->_error(${$@}); - } elsif ( $@ ) { - $self->_error($@); - } - - join '', map { "$_\n" } @lines; -} - -sub _has_internal_string_value { - my $value = shift; - my $b_obj = B::svref_2object(\$value); # for round trip problem - return $b_obj->FLAGS & B::SVf_POK(); -} - -sub _dump_scalar { - my $string = $_[1]; - my $is_key = $_[2]; - # Check this before checking length or it winds up looking like a string! - my $has_string_flag = _has_internal_string_value($string); - return '~' unless defined $string; - return "''" unless length $string; - if (Scalar::Util::looks_like_number($string)) { - # keys and values that have been used as strings get quoted - if ( $is_key || $has_string_flag ) { - return qq['$string']; - } - else { - return $string; - } - } - if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) { - $string =~ s/\\/\\\\/g; - $string =~ s/"/\\"/g; - $string =~ s/\n/\\n/g; - $string =~ s/[\x85]/\\N/g; - $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; - $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge; - return qq|"$string"|; - } - if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or - $QUOTE{$string} - ) { - return "'$string'"; - } - return $string; -} - -sub _dump_array { - my ($self, $array, $indent, $seen) = @_; - if ( $seen->{refaddr($array)}++ ) { - die \"CPAN::Meta::YAML does not support circular references"; - } - my @lines = (); - foreach my $el ( @$array ) { - my $line = (' ' x $indent) . '-'; - my $type = ref $el; - if ( ! $type ) { - $line .= ' ' . $self->_dump_scalar( $el ); - push @lines, $line; - - } elsif ( $type eq 'ARRAY' ) { - if ( @$el ) { - push @lines, $line; - push @lines, $self->_dump_array( $el, $indent + 1, $seen ); - } else { - $line .= ' []'; - push @lines, $line; - } - - } elsif ( $type eq 'HASH' ) { - if ( keys %$el ) { - push @lines, $line; - push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); - } else { - $line .= ' {}'; - push @lines, $line; - } - - } else { - die \"CPAN::Meta::YAML does not support $type references"; - } - } - - @lines; -} - -sub _dump_hash { - my ($self, $hash, $indent, $seen) = @_; - if ( $seen->{refaddr($hash)}++ ) { - die \"CPAN::Meta::YAML does not support circular references"; - } - my @lines = (); - foreach my $name ( sort keys %$hash ) { - my $el = $hash->{$name}; - my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":"; - my $type = ref $el; - if ( ! $type ) { - $line .= ' ' . $self->_dump_scalar( $el ); - push @lines, $line; - - } elsif ( $type eq 'ARRAY' ) { - if ( @$el ) { - push @lines, $line; - push @lines, $self->_dump_array( $el, $indent + 1, $seen ); - } else { - $line .= ' []'; - push @lines, $line; - } - - } elsif ( $type eq 'HASH' ) { - if ( keys %$el ) { - push @lines, $line; - push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); - } else { - $line .= ' {}'; - push @lines, $line; - } - - } else { - die \"CPAN::Meta::YAML does not support $type references"; - } - } - - @lines; -} - - - -##################################################################### -# DEPRECATED API methods: - -# Error storage (DEPRECATED as of 1.57) -our $errstr = ''; - -# Set error -sub _error { - require Carp; - $errstr = $_[1]; - $errstr =~ s/ at \S+ line \d+.*//; - Carp::croak( $errstr ); -} - -# Retrieve error -my $errstr_warned; -sub errstr { - require Carp; - Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" ) - unless $errstr_warned++; - $errstr; -} - - - - -##################################################################### -# Helper functions. Possibly not needed. - - -# Use to detect nv or iv -use B; - -# XXX-INGY Is flock CPAN::Meta::YAML's responsibility? -# Some platforms can't flock :-( -# XXX-XDG I think it is. When reading and writing files, we ought -# to be locking whenever possible. People (foolishly) use YAML -# files for things like session storage, which has race issues. -my $HAS_FLOCK; -sub _can_flock { - if ( defined $HAS_FLOCK ) { - return $HAS_FLOCK; - } - else { - require Config; - my $c = \%Config::Config; - $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/; - require Fcntl if $HAS_FLOCK; - return $HAS_FLOCK; - } -} - - -# XXX-INGY Is this core in 5.8.1? Can we remove this? -# XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this -##################################################################### -# Use Scalar::Util if possible, otherwise emulate it - -BEGIN { - local $@; - if ( eval { require Scalar::Util } - && $Scalar::Util::VERSION - && eval($Scalar::Util::VERSION) >= 1.18 - ) { - *refaddr = *Scalar::Util::refaddr; - } - else { - eval <<'END_PERL'; -# Scalar::Util failed to load or too old -sub refaddr { - my $pkg = ref($_[0]) or return undef; - if ( !! UNIVERSAL::can($_[0], 'can') ) { - bless $_[0], 'Scalar::Util::Fake'; - } else { - $pkg = undef; - } - "$_[0]" =~ /0x(\w+)/; - my $i = do { no warnings 'portable'; hex $1 }; - bless $_[0], $pkg if defined $pkg; - $i; -} -END_PERL - } -} - - - - -1; - -# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong -# but leaving grey area stuff up here. -# -# I would like to change Read/Write to Load/Dump below without -# changing the actual API names. -# -# It might be better to put Load/Dump API in the SYNOPSIS instead of the -# dubious OO API. -# -# null and bool explanations may be outdated. - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files - -=head1 VERSION - -version 0.011 - -=head1 SYNOPSIS - - use CPAN::Meta::YAML; - - # reading a META file - open $fh, "<:utf8", "META.yml"; - $yaml_text = do { local $/; <$fh> }; - $yaml = CPAN::Meta::YAML->read_string($yaml_text) - or die CPAN::Meta::YAML->errstr; - - # finding the metadata - $meta = $yaml->[0]; - - # writing a META file - $yaml_text = $yaml->write_string - or die CPAN::Meta::YAML->errstr; - open $fh, ">:utf8", "META.yml"; - print $fh $yaml_text; - -=head1 DESCRIPTION - -This module implements a subset of the YAML specification for use in reading -and writing CPAN metadata files like F and F. It should -not be used for any other general YAML parsing or generation task. - -NOTE: F (and F) files should be UTF-8 encoded. Users are -responsible for proper encoding and decoding. In particular, the C and -C methods do B support UTF-8 and should not be used. - -=head1 SUPPORT - -This module is currently derived from L by Adam Kennedy. If -there are bugs in how it parses a particular META.yml file, please file -a bug report in the YAML::Tiny bugtracker: -L - -=head1 SEE ALSO - -L, L, L - -=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/CPAN-Meta-YAML.git - -=head1 AUTHORS - -=over 4 - -=item * - -Adam Kennedy - -=item * - -David Golden - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by Adam Kennedy. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut - -__END__ - - -# ABSTRACT: Read and write a subset of YAML for CPAN Meta files - - diff --git a/bundled/CPAN-Meta/CPAN/Meta.pm b/bundled/CPAN-Meta/CPAN/Meta.pm deleted file mode 100644 index 83e4ced..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta.pm +++ /dev/null @@ -1,1128 +0,0 @@ -use 5.006; -use strict; -use warnings; -package CPAN::Meta; -# VERSION -$CPAN::Meta::VERSION = '2.143240'; -#pod =head1 SYNOPSIS -#pod -#pod use v5.10; -#pod use strict; -#pod use warnings; -#pod use CPAN::Meta; -#pod use Module::Load; -#pod -#pod my $meta = CPAN::Meta->load_file('META.json'); -#pod -#pod printf "testing requirements for %s version %s\n", -#pod $meta->name, -#pod $meta->version; -#pod -#pod my $prereqs = $meta->effective_prereqs; -#pod -#pod for my $phase ( qw/configure runtime build test/ ) { -#pod say "Requirements for $phase:"; -#pod my $reqs = $prereqs->requirements_for($phase, "requires"); -#pod for my $module ( sort $reqs->required_modules ) { -#pod my $status; -#pod if ( eval { load $module unless $module eq 'perl'; 1 } ) { -#pod my $version = $module eq 'perl' ? $] : $module->VERSION; -#pod $status = $reqs->accepts_module($module, $version) -#pod ? "$version ok" : "$version not ok"; -#pod } else { -#pod $status = "missing" -#pod }; -#pod say " $module ($status)"; -#pod } -#pod } -#pod -#pod =head1 DESCRIPTION -#pod -#pod Software distributions released to the CPAN include a F or, for -#pod older distributions, F, which describes the distribution, its -#pod contents, and the requirements for building and installing the distribution. -#pod The data structure stored in the F file is described in -#pod L. -#pod -#pod CPAN::Meta provides a simple class to represent this distribution metadata (or -#pod I), along with some helpful methods for interrogating that data. -#pod -#pod The documentation below is only for the methods of the CPAN::Meta object. For -#pod information on the meaning of individual fields, consult the spec. -#pod -#pod =cut - -use Carp qw(carp croak); -use CPAN::Meta::Feature; -use CPAN::Meta::Prereqs; -use CPAN::Meta::Converter; -use CPAN::Meta::Validator; -use Parse::CPAN::Meta 1.4414 (); - -BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone } - -#pod =head1 STRING DATA -#pod -#pod The following methods return a single value, which is the value for the -#pod corresponding entry in the distmeta structure. Values should be either undef -#pod or strings. -#pod -#pod =for :list -#pod * abstract -#pod * description -#pod * dynamic_config -#pod * generated_by -#pod * name -#pod * release_status -#pod * version -#pod -#pod =cut - -BEGIN { - my @STRING_READERS = qw( - abstract - description - dynamic_config - generated_by - name - release_status - version - ); - - no strict 'refs'; - for my $attr (@STRING_READERS) { - *$attr = sub { $_[0]{ $attr } }; - } -} - -#pod =head1 LIST DATA -#pod -#pod These methods return lists of string values, which might be represented in the -#pod distmeta structure as arrayrefs or scalars: -#pod -#pod =for :list -#pod * authors -#pod * keywords -#pod * licenses -#pod -#pod The C and C methods may also be called as C and -#pod C, respectively, to match the field name in the distmeta structure. -#pod -#pod =cut - -BEGIN { - my @LIST_READERS = qw( - author - keywords - license - ); - - no strict 'refs'; - for my $attr (@LIST_READERS) { - *$attr = sub { - my $value = $_[0]{ $attr }; - croak "$attr must be called in list context" - unless wantarray; - return @{ _dclone($value) } if ref $value; - return $value; - }; - } -} - -sub authors { $_[0]->author } -sub licenses { $_[0]->license } - -#pod =head1 MAP DATA -#pod -#pod These readers return hashrefs of arbitrary unblessed data structures, each -#pod described more fully in the specification: -#pod -#pod =for :list -#pod * meta_spec -#pod * resources -#pod * provides -#pod * no_index -#pod * prereqs -#pod * optional_features -#pod -#pod =cut - -BEGIN { - my @MAP_READERS = qw( - meta-spec - resources - provides - no_index - - prereqs - optional_features - ); - - no strict 'refs'; - for my $attr (@MAP_READERS) { - (my $subname = $attr) =~ s/-/_/; - *$subname = sub { - my $value = $_[0]{ $attr }; - return _dclone($value) if $value; - return {}; - }; - } -} - -#pod =head1 CUSTOM DATA -#pod -#pod A list of custom keys are available from the C method and -#pod particular keys may be retrieved with the C method. -#pod -#pod say $meta->custom($_) for $meta->custom_keys; -#pod -#pod If a custom key refers to a data structure, a deep clone is returned. -#pod -#pod =cut - -sub custom_keys { - return grep { /^x_/i } keys %{$_[0]}; -} - -sub custom { - my ($self, $attr) = @_; - my $value = $self->{$attr}; - return _dclone($value) if ref $value; - return $value; -} - -#pod =method new -#pod -#pod my $meta = CPAN::Meta->new($distmeta_struct, \%options); -#pod -#pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash -#pod reference fails to validate. Older-format metadata will be up-converted to -#pod version 2 if they validate against the original stated specification. -#pod -#pod It takes an optional hashref of options. Valid options include: -#pod -#pod =over -#pod -#pod =item * -#pod -#pod lazy_validation -- if true, new will attempt to convert the given metadata -#pod to version 2 before attempting to validate it. This means than any -#pod fixable errors will be handled by CPAN::Meta::Converter before validation. -#pod (Note that this might result in invalid optional data being silently -#pod dropped.) The default is false. -#pod -#pod =back -#pod -#pod =cut - -sub _new { - my ($class, $struct, $options) = @_; - my $self; - - if ( $options->{lazy_validation} ) { - # try to convert to a valid structure; if succeeds, then return it - my $cmc = CPAN::Meta::Converter->new( $struct ); - $self = $cmc->convert( version => 2 ); # valid or dies - return bless $self, $class; - } - else { - # validate original struct - my $cmv = CPAN::Meta::Validator->new( $struct ); - unless ( $cmv->is_valid) { - die "Invalid metadata structure. Errors: " - . join(", ", $cmv->errors) . "\n"; - } - } - - # up-convert older spec versions - my $version = $struct->{'meta-spec'}{version} || '1.0'; - if ( $version == 2 ) { - $self = $struct; - } - else { - my $cmc = CPAN::Meta::Converter->new( $struct ); - $self = $cmc->convert( version => 2 ); - } - - return bless $self, $class; -} - -sub new { - my ($class, $struct, $options) = @_; - my $self = eval { $class->_new($struct, $options) }; - croak($@) if $@; - return $self; -} - -#pod =method create -#pod -#pod my $meta = CPAN::Meta->create($distmeta_struct, \%options); -#pod -#pod This is same as C, except that C and C fields -#pod will be generated if not provided. This means the metadata structure is -#pod assumed to otherwise follow the latest L. -#pod -#pod =cut - -sub create { - my ($class, $struct, $options) = @_; - my $version = __PACKAGE__->VERSION || 2; - $struct->{generated_by} ||= __PACKAGE__ . " version $version" ; - $struct->{'meta-spec'}{version} ||= int($version); - my $self = eval { $class->_new($struct, $options) }; - croak ($@) if $@; - return $self; -} - -#pod =method load_file -#pod -#pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options); -#pod -#pod Given a pathname to a file containing metadata, this deserializes the file -#pod according to its file suffix and constructs a new C object, just -#pod like C. It will die if the deserialized version fails to validate -#pod against its stated specification version. -#pod -#pod It takes the same options as C but C defaults to -#pod true. -#pod -#pod =cut - -sub load_file { - my ($class, $file, $options) = @_; - $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; - - croak "load_file() requires a valid, readable filename" - unless -r $file; - - my $self; - eval { - my $struct = Parse::CPAN::Meta->load_file( $file ); - $self = $class->_new($struct, $options); - }; - croak($@) if $@; - return $self; -} - -#pod =method load_yaml_string -#pod -#pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); -#pod -#pod This method returns a new CPAN::Meta object using the first document in the -#pod given YAML string. In other respects it is identical to C. -#pod -#pod =cut - -sub load_yaml_string { - my ($class, $yaml, $options) = @_; - $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; - - my $self; - eval { - my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml ); - $self = $class->_new($struct, $options); - }; - croak($@) if $@; - return $self; -} - -#pod =method load_json_string -#pod -#pod my $meta = CPAN::Meta->load_json_string($json, \%options); -#pod -#pod This method returns a new CPAN::Meta object using the structure represented by -#pod the given JSON string. In other respects it is identical to C. -#pod -#pod =cut - -sub load_json_string { - my ($class, $json, $options) = @_; - $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; - - my $self; - eval { - my $struct = Parse::CPAN::Meta->load_json_string( $json ); - $self = $class->_new($struct, $options); - }; - croak($@) if $@; - return $self; -} - -#pod =method load_string -#pod -#pod my $meta = CPAN::Meta->load_string($string, \%options); -#pod -#pod If you don't know if a string contains YAML or JSON, this method will use -#pod L to guess. In other respects it is identical to -#pod C. -#pod -#pod =cut - -sub load_string { - my ($class, $string, $options) = @_; - $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; - - my $self; - eval { - my $struct = Parse::CPAN::Meta->load_string( $string ); - $self = $class->_new($struct, $options); - }; - croak($@) if $@; - return $self; -} - -#pod =method save -#pod -#pod $meta->save($distmeta_file, \%options); -#pod -#pod Serializes the object as JSON and writes it to the given file. The only valid -#pod option is C, which defaults to '2'. On Perl 5.8.1 or later, the file -#pod is saved with UTF-8 encoding. -#pod -#pod For C 2 (or higher), the filename should end in '.json'. L -#pod is the default JSON backend. Using another JSON backend requires L 2.5 or -#pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate -#pod backend like L. -#pod -#pod For C less than 2, the filename should end in '.yml'. -#pod L is used to generate an older metadata structure, which -#pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may -#pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though -#pod this is not recommended due to subtle incompatibilities between YAML parsers on -#pod CPAN. -#pod -#pod =cut - -sub save { - my ($self, $file, $options) = @_; - - my $version = $options->{version} || '2'; - my $layer = $] ge '5.008001' ? ':utf8' : ''; - - if ( $version ge '2' ) { - carp "'$file' should end in '.json'" - unless $file =~ m{\.json$}; - } - else { - carp "'$file' should end in '.yml'" - unless $file =~ m{\.yml$}; - } - - my $data = $self->as_string( $options ); - open my $fh, ">$layer", $file - or die "Error opening '$file' for writing: $!\n"; - - print {$fh} $data; - close $fh - or die "Error closing '$file': $!\n"; - - return 1; -} - -#pod =method meta_spec_version -#pod -#pod This method returns the version part of the C entry in the distmeta -#pod structure. It is equivalent to: -#pod -#pod $meta->meta_spec->{version}; -#pod -#pod =cut - -sub meta_spec_version { - my ($self) = @_; - return $self->meta_spec->{version}; -} - -#pod =method effective_prereqs -#pod -#pod my $prereqs = $meta->effective_prereqs; -#pod -#pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); -#pod -#pod This method returns a L object describing all the -#pod prereqs for the distribution. If an arrayref of feature identifiers is given, -#pod the prereqs for the identified features are merged together with the -#pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. -#pod -#pod =cut - -sub effective_prereqs { - my ($self, $features) = @_; - $features ||= []; - - my $prereq = CPAN::Meta::Prereqs->new($self->prereqs); - - return $prereq unless @$features; - - my @other = map {; $self->feature($_)->prereqs } @$features; - - return $prereq->with_merged_prereqs(\@other); -} - -#pod =method should_index_file -#pod -#pod ... if $meta->should_index_file( $filename ); -#pod -#pod This method returns true if the given file should be indexed. It decides this -#pod by checking the C and C keys in the C property of -#pod the distmeta structure. Note that neither the version format nor -#pod C are considered. -#pod -#pod C<$filename> should be given in unix format. -#pod -#pod =cut - -sub should_index_file { - my ($self, $filename) = @_; - - for my $no_index_file (@{ $self->no_index->{file} || [] }) { - return if $filename eq $no_index_file; - } - - for my $no_index_dir (@{ $self->no_index->{directory} }) { - $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z}; - return if index($filename, $no_index_dir) == 0; - } - - return 1; -} - -#pod =method should_index_package -#pod -#pod ... if $meta->should_index_package( $package ); -#pod -#pod This method returns true if the given package should be indexed. It decides -#pod this by checking the C and C keys in the C -#pod property of the distmeta structure. Note that neither the version format nor -#pod C are considered. -#pod -#pod =cut - -sub should_index_package { - my ($self, $package) = @_; - - for my $no_index_pkg (@{ $self->no_index->{package} || [] }) { - return if $package eq $no_index_pkg; - } - - for my $no_index_ns (@{ $self->no_index->{namespace} }) { - return if index($package, "${no_index_ns}::") == 0; - } - - return 1; -} - -#pod =method features -#pod -#pod my @feature_objects = $meta->features; -#pod -#pod This method returns a list of L objects, one for each -#pod optional feature described by the distribution's metadata. -#pod -#pod =cut - -sub features { - my ($self) = @_; - - my $opt_f = $self->optional_features; - my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) } - keys %$opt_f; - - return @features; -} - -#pod =method feature -#pod -#pod my $feature_object = $meta->feature( $identifier ); -#pod -#pod This method returns a L object for the optional feature -#pod with the given identifier. If no feature with that identifier exists, an -#pod exception will be raised. -#pod -#pod =cut - -sub feature { - my ($self, $ident) = @_; - - croak "no feature named $ident" - unless my $f = $self->optional_features->{ $ident }; - - return CPAN::Meta::Feature->new($ident, $f); -} - -#pod =method as_struct -#pod -#pod my $copy = $meta->as_struct( \%options ); -#pod -#pod This method returns a deep copy of the object's metadata as an unblessed hash -#pod reference. It takes an optional hashref of options. If the hashref contains -#pod a C argument, the copied metadata will be converted to the version -#pod of the specification and returned. For example: -#pod -#pod my $old_spec = $meta->as_struct( {version => "1.4"} ); -#pod -#pod =cut - -sub as_struct { - my ($self, $options) = @_; - my $struct = _dclone($self); - if ( $options->{version} ) { - my $cmc = CPAN::Meta::Converter->new( $struct ); - $struct = $cmc->convert( version => $options->{version} ); - } - return $struct; -} - -#pod =method as_string -#pod -#pod my $string = $meta->as_string( \%options ); -#pod -#pod This method returns a serialized copy of the object's metadata as a character -#pod string. (The strings are B UTF-8 encoded.) It takes an optional hashref -#pod of options. If the hashref contains a C argument, the copied metadata -#pod will be converted to the version of the specification and returned. For -#pod example: -#pod -#pod my $string = $meta->as_string( {version => "1.4"} ); -#pod -#pod For C greater than or equal to 2, the string will be serialized as -#pod JSON. For C less than 2, the string will be serialized as YAML. In -#pod both cases, the same rules are followed as in the C method for choosing -#pod a serialization backend. -#pod -#pod =cut - -sub as_string { - my ($self, $options) = @_; - - my $version = $options->{version} || '2'; - - my $struct; - if ( $self->meta_spec_version ne $version ) { - my $cmc = CPAN::Meta::Converter->new( $self->as_struct ); - $struct = $cmc->convert( version => $version ); - } - else { - $struct = $self->as_struct; - } - - my ($data, $backend); - if ( $version ge '2' ) { - $backend = Parse::CPAN::Meta->json_backend(); - $data = $backend->new->pretty->canonical->encode($struct); - } - else { - $backend = Parse::CPAN::Meta->yaml_backend(); - $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) }; - if ( $@ ) { - croak $backend->can('errstr') ? $backend->errstr : $@ - } - } - - return $data; -} - -# Used by JSON::PP, etc. for "convert_blessed" -sub TO_JSON { - return { %{ $_[0] } }; -} - -1; - -# ABSTRACT: the distribution metadata for a CPAN dist - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta - the distribution metadata for a CPAN dist - -=head1 VERSION - -version 2.143240 - -=head1 SYNOPSIS - - use v5.10; - use strict; - use warnings; - use CPAN::Meta; - use Module::Load; - - my $meta = CPAN::Meta->load_file('META.json'); - - printf "testing requirements for %s version %s\n", - $meta->name, - $meta->version; - - my $prereqs = $meta->effective_prereqs; - - for my $phase ( qw/configure runtime build test/ ) { - say "Requirements for $phase:"; - my $reqs = $prereqs->requirements_for($phase, "requires"); - for my $module ( sort $reqs->required_modules ) { - my $status; - if ( eval { load $module unless $module eq 'perl'; 1 } ) { - my $version = $module eq 'perl' ? $] : $module->VERSION; - $status = $reqs->accepts_module($module, $version) - ? "$version ok" : "$version not ok"; - } else { - $status = "missing" - }; - say " $module ($status)"; - } - } - -=head1 DESCRIPTION - -Software distributions released to the CPAN include a F or, for -older distributions, F, which describes the distribution, its -contents, and the requirements for building and installing the distribution. -The data structure stored in the F file is described in -L. - -CPAN::Meta provides a simple class to represent this distribution metadata (or -I), along with some helpful methods for interrogating that data. - -The documentation below is only for the methods of the CPAN::Meta object. For -information on the meaning of individual fields, consult the spec. - -=head1 METHODS - -=head2 new - - my $meta = CPAN::Meta->new($distmeta_struct, \%options); - -Returns a valid CPAN::Meta object or dies if the supplied metadata hash -reference fails to validate. Older-format metadata will be up-converted to -version 2 if they validate against the original stated specification. - -It takes an optional hashref of options. Valid options include: - -=over - -=item * - -lazy_validation -- if true, new will attempt to convert the given metadata -to version 2 before attempting to validate it. This means than any -fixable errors will be handled by CPAN::Meta::Converter before validation. -(Note that this might result in invalid optional data being silently -dropped.) The default is false. - -=back - -=head2 create - - my $meta = CPAN::Meta->create($distmeta_struct, \%options); - -This is same as C, except that C and C fields -will be generated if not provided. This means the metadata structure is -assumed to otherwise follow the latest L. - -=head2 load_file - - my $meta = CPAN::Meta->load_file($distmeta_file, \%options); - -Given a pathname to a file containing metadata, this deserializes the file -according to its file suffix and constructs a new C object, just -like C. It will die if the deserialized version fails to validate -against its stated specification version. - -It takes the same options as C but C defaults to -true. - -=head2 load_yaml_string - - my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); - -This method returns a new CPAN::Meta object using the first document in the -given YAML string. In other respects it is identical to C. - -=head2 load_json_string - - my $meta = CPAN::Meta->load_json_string($json, \%options); - -This method returns a new CPAN::Meta object using the structure represented by -the given JSON string. In other respects it is identical to C. - -=head2 load_string - - my $meta = CPAN::Meta->load_string($string, \%options); - -If you don't know if a string contains YAML or JSON, this method will use -L to guess. In other respects it is identical to -C. - -=head2 save - - $meta->save($distmeta_file, \%options); - -Serializes the object as JSON and writes it to the given file. The only valid -option is C, which defaults to '2'. On Perl 5.8.1 or later, the file -is saved with UTF-8 encoding. - -For C 2 (or higher), the filename should end in '.json'. L -is the default JSON backend. Using another JSON backend requires L 2.5 or -later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate -backend like L. - -For C less than 2, the filename should end in '.yml'. -L is used to generate an older metadata structure, which -is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may -set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though -this is not recommended due to subtle incompatibilities between YAML parsers on -CPAN. - -=head2 meta_spec_version - -This method returns the version part of the C entry in the distmeta -structure. It is equivalent to: - - $meta->meta_spec->{version}; - -=head2 effective_prereqs - - my $prereqs = $meta->effective_prereqs; - - my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); - -This method returns a L object describing all the -prereqs for the distribution. If an arrayref of feature identifiers is given, -the prereqs for the identified features are merged together with the -distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. - -=head2 should_index_file - - ... if $meta->should_index_file( $filename ); - -This method returns true if the given file should be indexed. It decides this -by checking the C and C keys in the C property of -the distmeta structure. Note that neither the version format nor -C are considered. - -C<$filename> should be given in unix format. - -=head2 should_index_package - - ... if $meta->should_index_package( $package ); - -This method returns true if the given package should be indexed. It decides -this by checking the C and C keys in the C -property of the distmeta structure. Note that neither the version format nor -C are considered. - -=head2 features - - my @feature_objects = $meta->features; - -This method returns a list of L objects, one for each -optional feature described by the distribution's metadata. - -=head2 feature - - my $feature_object = $meta->feature( $identifier ); - -This method returns a L object for the optional feature -with the given identifier. If no feature with that identifier exists, an -exception will be raised. - -=head2 as_struct - - my $copy = $meta->as_struct( \%options ); - -This method returns a deep copy of the object's metadata as an unblessed hash -reference. It takes an optional hashref of options. If the hashref contains -a C argument, the copied metadata will be converted to the version -of the specification and returned. For example: - - my $old_spec = $meta->as_struct( {version => "1.4"} ); - -=head2 as_string - - my $string = $meta->as_string( \%options ); - -This method returns a serialized copy of the object's metadata as a character -string. (The strings are B UTF-8 encoded.) It takes an optional hashref -of options. If the hashref contains a C argument, the copied metadata -will be converted to the version of the specification and returned. For -example: - - my $string = $meta->as_string( {version => "1.4"} ); - -For C greater than or equal to 2, the string will be serialized as -JSON. For C less than 2, the string will be serialized as YAML. In -both cases, the same rules are followed as in the C method for choosing -a serialization backend. - -=head1 STRING DATA - -The following methods return a single value, which is the value for the -corresponding entry in the distmeta structure. Values should be either undef -or strings. - -=over 4 - -=item * - -abstract - -=item * - -description - -=item * - -dynamic_config - -=item * - -generated_by - -=item * - -name - -=item * - -release_status - -=item * - -version - -=back - -=head1 LIST DATA - -These methods return lists of string values, which might be represented in the -distmeta structure as arrayrefs or scalars: - -=over 4 - -=item * - -authors - -=item * - -keywords - -=item * - -licenses - -=back - -The C and C methods may also be called as C and -C, respectively, to match the field name in the distmeta structure. - -=head1 MAP DATA - -These readers return hashrefs of arbitrary unblessed data structures, each -described more fully in the specification: - -=over 4 - -=item * - -meta_spec - -=item * - -resources - -=item * - -provides - -=item * - -no_index - -=item * - -prereqs - -=item * - -optional_features - -=back - -=head1 CUSTOM DATA - -A list of custom keys are available from the C method and -particular keys may be retrieved with the C method. - - say $meta->custom($_) for $meta->custom_keys; - -If a custom key refers to a data structure, a deep clone is returned. - -=for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config -generated_by keywords license licenses meta_spec name no_index -optional_features prereqs provides release_status resources version - -=head1 BUGS - -Please report any bugs or feature using the CPAN Request Tracker. -Bugs can be submitted through the web interface at -L - -When submitting a bug or request, please include a test-file or a patch to an -existing test-file that illustrates the bug or desired feature. - -=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/Perl-Toolchain-Gang/CPAN-Meta.git - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 CONTRIBUTORS - -=for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern moznion Olaf Alders Olivier Mengue Randy Sims - -=over 4 - -=item * - -Ansgar Burchardt - -=item * - -Avar Arnfjord Bjarmason - -=item * - -Christopher J. Madsen - -=item * - -Chuck Adams - -=item * - -Cory G Watson - -=item * - -Damyan Ivanov - -=item * - -Eric Wilhelm - -=item * - -Graham Knop - -=item * - -Gregor Hermann - -=item * - -Karen Etheridge - -=item * - -Kenichi Ishigaki - -=item * - -Ken Williams - -=item * - -Lars Dieckow - -=item * - -Leon Timmermans - -=item * - -majensen - -=item * - -Mark Fowler - -=item * - -Matt S Trout - -=item * - -Michael G. Schwern - -=item * - -moznion - -=item * - -Olaf Alders - -=item * - -Olivier Mengue - -=item * - -Randy Sims - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta/CPAN/Meta/Converter.pm b/bundled/CPAN-Meta/CPAN/Meta/Converter.pm deleted file mode 100644 index fe89c36..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/Converter.pm +++ /dev/null @@ -1,1632 +0,0 @@ -use 5.006; -use strict; -use warnings; -package CPAN::Meta::Converter; -# VERSION -$CPAN::Meta::Converter::VERSION = '2.143240'; -#pod =head1 SYNOPSIS -#pod -#pod my $struct = decode_json_file('META.json'); -#pod -#pod my $cmc = CPAN::Meta::Converter->new( $struct ); -#pod -#pod my $new_struct = $cmc->convert( version => "2" ); -#pod -#pod =head1 DESCRIPTION -#pod -#pod This module converts CPAN Meta structures from one form to another. The -#pod primary use is to convert older structures to the most modern version of -#pod the specification, but other transformations may be implemented in the -#pod future as needed. (E.g. stripping all custom fields or stripping all -#pod optional fields.) -#pod -#pod =cut - -use CPAN::Meta::Validator; -use CPAN::Meta::Requirements; -use Parse::CPAN::Meta 1.4400 (); - -# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls -# before 5.10, we fall back to the EUMM bundled compatibility version module if -# that's the only thing available. This shouldn't ever happen in a normal CPAN -# install of CPAN::Meta::Requirements, as version.pm will be picked up from -# prereqs and be available at runtime. - -BEGIN { - eval "use version ()"; ## no critic - if ( my $err = $@ ) { - eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic - } -} - -# Perl 5.10.0 didn't have "is_qv" in version.pm -*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; - -sub _dclone { - my $ref = shift; - - # if an object is in the data structure and doesn't specify how to - # turn itself into JSON, we just stringify the object. That does the - # right thing for typical things that might be there, like version objects, - # Path::Class objects, etc. - no warnings 'once'; - no warnings 'redefine'; - local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; - - my $json = Parse::CPAN::Meta->json_backend()->new - ->utf8 - ->allow_blessed - ->convert_blessed; - $json->decode($json->encode($ref)) -} - -my %known_specs = ( - '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', - '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', - '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', - '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', - '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', - '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' -); - -my @spec_list = sort { $a <=> $b } keys %known_specs; -my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; - -#--------------------------------------------------------------------------# -# converters -# -# called as $converter->($element, $field_name, $full_meta, $to_version) -# -# defined return value used for field -# undef return value means field is skipped -#--------------------------------------------------------------------------# - -sub _keep { $_[0] } - -sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } - -sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } - -sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } - -sub _generated_by { - my $gen = shift; - my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || ""); - - return $sig unless defined $gen and length $gen; - return $gen if $gen =~ /\Q$sig/; - return "$gen, $sig"; -} - -sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } - -sub _prefix_custom { - my $key = shift; - $key =~ s/^(?!x_) # Unless it already starts with x_ - (?:x-?)? # Remove leading x- or x (if present) - /x_/ix; # and prepend x_ - return $key; -} - -sub _ucfirst_custom { - my $key = shift; - $key = ucfirst $key unless $key =~ /[A-Z]/; - return $key; -} - -sub _no_prefix_ucfirst_custom { - my $key = shift; - $key =~ s/^x_//; - return _ucfirst_custom($key); -} - -sub _change_meta_spec { - my ($element, undef, undef, $version) = @_; - return { - version => $version, - url => $known_specs{$version}, - }; -} - -my @open_source = ( - 'perl', - 'gpl', - 'apache', - 'artistic', - 'artistic_2', - 'lgpl', - 'bsd', - 'gpl', - 'mit', - 'mozilla', - 'open_source', -); - -my %is_open_source = map {; $_ => 1 } @open_source; - -my @valid_licenses_1 = ( - @open_source, - 'unrestricted', - 'restrictive', - 'unknown', -); - -my %license_map_1 = ( - ( map { $_ => $_ } @valid_licenses_1 ), - artistic2 => 'artistic_2', -); - -sub _license_1 { - my ($element) = @_; - return 'unknown' unless defined $element; - if ( $license_map_1{lc $element} ) { - return $license_map_1{lc $element}; - } - else { - return 'unknown'; - } -} - -my @valid_licenses_2 = qw( - agpl_3 - apache_1_1 - apache_2_0 - artistic_1 - artistic_2 - bsd - freebsd - gfdl_1_2 - gfdl_1_3 - gpl_1 - gpl_2 - gpl_3 - lgpl_2_1 - lgpl_3_0 - mit - mozilla_1_0 - mozilla_1_1 - openssl - perl_5 - qpl_1_0 - ssleay - sun - zlib - open_source - restricted - unrestricted - unknown -); - -# The "old" values were defined by Module::Build, and were often vague. I have -# made the decisions below based on reading Module::Build::API and how clearly -# it specifies the version of the license. -my %license_map_2 = ( - (map { $_ => $_ } @valid_licenses_2), - apache => 'apache_2_0', # clearly stated as 2.0 - artistic => 'artistic_1', # clearly stated as 1 - artistic2 => 'artistic_2', # clearly stated as 2 - gpl => 'open_source', # we don't know which GPL; punt - lgpl => 'open_source', # we don't know which LGPL; punt - mozilla => 'open_source', # we don't know which MPL; punt - perl => 'perl_5', # clearly Perl 5 - restrictive => 'restricted', -); - -sub _license_2 { - my ($element) = @_; - return [ 'unknown' ] unless defined $element; - $element = [ $element ] unless ref $element eq 'ARRAY'; - my @new_list; - for my $lic ( @$element ) { - next unless defined $lic; - if ( my $new = $license_map_2{lc $lic} ) { - push @new_list, $new; - } - } - return @new_list ? \@new_list : [ 'unknown' ]; -} - -my %license_downgrade_map = qw( - agpl_3 open_source - apache_1_1 apache - apache_2_0 apache - artistic_1 artistic - artistic_2 artistic_2 - bsd bsd - freebsd open_source - gfdl_1_2 open_source - gfdl_1_3 open_source - gpl_1 gpl - gpl_2 gpl - gpl_3 gpl - lgpl_2_1 lgpl - lgpl_3_0 lgpl - mit mit - mozilla_1_0 mozilla - mozilla_1_1 mozilla - openssl open_source - perl_5 perl - qpl_1_0 open_source - ssleay open_source - sun open_source - zlib open_source - open_source open_source - restricted restrictive - unrestricted unrestricted - unknown unknown -); - -sub _downgrade_license { - my ($element) = @_; - if ( ! defined $element ) { - return "unknown"; - } - elsif( ref $element eq 'ARRAY' ) { - if ( @$element > 1) { - if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) { - return 'unknown'; - } - else { - return 'open_source'; - } - } - elsif ( @$element == 1 ) { - return $license_downgrade_map{lc $element->[0]} || "unknown"; - } - } - elsif ( ! ref $element ) { - return $license_downgrade_map{lc $element} || "unknown"; - } - return "unknown"; -} - -my $no_index_spec_1_2 = { - 'file' => \&_listify, - 'dir' => \&_listify, - 'package' => \&_listify, - 'namespace' => \&_listify, -}; - -my $no_index_spec_1_3 = { - 'file' => \&_listify, - 'directory' => \&_listify, - 'package' => \&_listify, - 'namespace' => \&_listify, -}; - -my $no_index_spec_2 = { - 'file' => \&_listify, - 'directory' => \&_listify, - 'package' => \&_listify, - 'namespace' => \&_listify, - ':custom' => \&_prefix_custom, -}; - -sub _no_index_1_2 { - my (undef, undef, $meta) = @_; - my $no_index = $meta->{no_index} || $meta->{private}; - return unless $no_index; - - # cleanup wrong format - if ( ! ref $no_index ) { - my $item = $no_index; - $no_index = { dir => [ $item ], file => [ $item ] }; - } - elsif ( ref $no_index eq 'ARRAY' ) { - my $list = $no_index; - $no_index = { dir => [ @$list ], file => [ @$list ] }; - } - - # common mistake: files -> file - if ( exists $no_index->{files} ) { - $no_index->{file} = delete $no_index->{file}; - } - # common mistake: modules -> module - if ( exists $no_index->{modules} ) { - $no_index->{module} = delete $no_index->{module}; - } - return _convert($no_index, $no_index_spec_1_2); -} - -sub _no_index_directory { - my ($element, $key, $meta, $version) = @_; - return unless $element; - - # cleanup wrong format - if ( ! ref $element ) { - my $item = $element; - $element = { directory => [ $item ], file => [ $item ] }; - } - elsif ( ref $element eq 'ARRAY' ) { - my $list = $element; - $element = { directory => [ @$list ], file => [ @$list ] }; - } - - if ( exists $element->{dir} ) { - $element->{directory} = delete $element->{dir}; - } - # common mistake: files -> file - if ( exists $element->{files} ) { - $element->{file} = delete $element->{file}; - } - # common mistake: modules -> module - if ( exists $element->{modules} ) { - $element->{module} = delete $element->{module}; - } - my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; - return _convert($element, $spec); -} - -sub _is_module_name { - my $mod = shift; - return unless defined $mod && length $mod; - return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; -} - -sub _clean_version { - my ($element) = @_; - return 0 if ! defined $element; - - $element =~ s{^\s*}{}; - $element =~ s{\s*$}{}; - $element =~ s{^\.}{0.}; - - return 0 if ! length $element; - return 0 if ( $element eq 'undef' || $element eq '' ); - - my $v = eval { version->new($element) }; - # XXX check defined $v and not just $v because version objects leak memory - # in boolean context -- dagolden, 2012-02-03 - if ( defined $v ) { - return _is_qv($v) ? $v->normal : $element; - } - else { - return 0; - } -} - -sub _bad_version_hook { - my ($v) = @_; - $v =~ s{[a-z]+$}{}; # strip trailing alphabetics - my $vobj = eval { version->new($v) }; - return defined($vobj) ? $vobj : version->new(0); # or give up -} - -sub _version_map { - my ($element) = @_; - return unless defined $element; - if ( ref $element eq 'HASH' ) { - # XXX turn this into CPAN::Meta::Requirements with bad version hook - # and then turn it back into a hash - my $new_map = CPAN::Meta::Requirements->new( - { bad_version_hook => \&_bad_version_hook } # punt - ); - while ( my ($k,$v) = each %$element ) { - next unless _is_module_name($k); - if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '' ) { - $v = 0; - } - # some weird, old META have bad yml with module => module - # so check if value is like a module name and not like a version - if ( _is_module_name($v) && ! version::is_lax($v) ) { - $new_map->add_minimum($k => 0); - $new_map->add_minimum($v => 0); - } - $new_map->add_string_requirement($k => $v); - } - return $new_map->as_string_hash; - } - elsif ( ref $element eq 'ARRAY' ) { - my $hashref = { map { $_ => 0 } @$element }; - return _version_map($hashref); # cleanup any weird stuff - } - elsif ( ref $element eq '' && length $element ) { - return { $element => 0 } - } - return; -} - -sub _prereqs_from_1 { - my (undef, undef, $meta) = @_; - my $prereqs = {}; - for my $phase ( qw/build configure/ ) { - my $key = "${phase}_requires"; - $prereqs->{$phase}{requires} = _version_map($meta->{$key}) - if $meta->{$key}; - } - for my $rel ( qw/requires recommends conflicts/ ) { - $prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) - if $meta->{$rel}; - } - return $prereqs; -} - -my $prereqs_spec = { - configure => \&_prereqs_rel, - build => \&_prereqs_rel, - test => \&_prereqs_rel, - runtime => \&_prereqs_rel, - develop => \&_prereqs_rel, - ':custom' => \&_prefix_custom, -}; - -my $relation_spec = { - requires => \&_version_map, - recommends => \&_version_map, - suggests => \&_version_map, - conflicts => \&_version_map, - ':custom' => \&_prefix_custom, -}; - -sub _cleanup_prereqs { - my ($prereqs, $key, $meta, $to_version) = @_; - return unless $prereqs && ref $prereqs eq 'HASH'; - return _convert( $prereqs, $prereqs_spec, $to_version ); -} - -sub _prereqs_rel { - my ($relation, $key, $meta, $to_version) = @_; - return unless $relation && ref $relation eq 'HASH'; - return _convert( $relation, $relation_spec, $to_version ); -} - - -BEGIN { - my @old_prereqs = qw( - requires - configure_requires - recommends - conflicts - ); - - for ( @old_prereqs ) { - my $sub = "_get_$_"; - my ($phase,$type) = split qr/_/, $_; - if ( ! defined $type ) { - $type = $phase; - $phase = 'runtime'; - } - no strict 'refs'; - *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; - } -} - -sub _get_build_requires { - my ($data, $key, $meta) = @_; - - my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; - my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; - - my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); - my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); - - $test_req->add_requirements($build_req)->as_string_hash; -} - -sub _extract_prereqs { - my ($prereqs, $phase, $type) = @_; - return unless ref $prereqs eq 'HASH'; - return scalar _version_map($prereqs->{$phase}{$type}); -} - -sub _downgrade_optional_features { - my (undef, undef, $meta) = @_; - return unless exists $meta->{optional_features}; - my $origin = $meta->{optional_features}; - my $features = {}; - for my $name ( keys %$origin ) { - $features->{$name} = { - description => $origin->{$name}{description}, - requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), - configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), - build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), - recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), - conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), - }; - for my $k (keys %{$features->{$name}} ) { - delete $features->{$name}{$k} unless defined $features->{$name}{$k}; - } - } - return $features; -} - -sub _upgrade_optional_features { - my (undef, undef, $meta) = @_; - return unless exists $meta->{optional_features}; - my $origin = $meta->{optional_features}; - my $features = {}; - for my $name ( keys %$origin ) { - $features->{$name} = { - description => $origin->{$name}{description}, - prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), - }; - delete $features->{$name}{prereqs}{configure}; - } - return $features; -} - -my $optional_features_2_spec = { - description => \&_keep, - prereqs => \&_cleanup_prereqs, - ':custom' => \&_prefix_custom, -}; - -sub _feature_2 { - my ($element, $key, $meta, $to_version) = @_; - return unless $element && ref $element eq 'HASH'; - _convert( $element, $optional_features_2_spec, $to_version ); -} - -sub _cleanup_optional_features_2 { - my ($element, $key, $meta, $to_version) = @_; - return unless $element && ref $element eq 'HASH'; - my $new_data = {}; - for my $k ( keys %$element ) { - $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); - } - return unless keys %$new_data; - return $new_data; -} - -sub _optional_features_1_4 { - my ($element) = @_; - return unless $element; - $element = _optional_features_as_map($element); - for my $name ( keys %$element ) { - for my $drop ( qw/requires_packages requires_os excluded_os/ ) { - delete $element->{$name}{$drop}; - } - } - return $element; -} - -sub _optional_features_as_map { - my ($element) = @_; - return unless $element; - if ( ref $element eq 'ARRAY' ) { - my %map; - for my $feature ( @$element ) { - my (@parts) = %$feature; - $map{$parts[0]} = $parts[1]; - } - $element = \%map; - } - return $element; -} - -sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } - -sub _url_or_drop { - my ($element) = @_; - return $element if _is_urlish($element); - return; -} - -sub _url_list { - my ($element) = @_; - return unless $element; - $element = _listify( $element ); - $element = [ grep { _is_urlish($_) } @$element ]; - return unless @$element; - return $element; -} - -sub _author_list { - my ($element) = @_; - return [ 'unknown' ] unless $element; - $element = _listify( $element ); - $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; - return [ 'unknown' ] unless @$element; - return $element; -} - -my $resource2_upgrade = { - license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, - homepage => \&_url_or_drop, - bugtracker => sub { - my ($item) = @_; - return unless $item; - if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } - elsif( _is_urlish($item) ) { return { web => $item } } - else { return } - }, - repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, - ':custom' => \&_prefix_custom, -}; - -sub _upgrade_resources_2 { - my (undef, undef, $meta, $version) = @_; - return unless exists $meta->{resources}; - return _convert($meta->{resources}, $resource2_upgrade); -} - -my $bugtracker2_spec = { - web => \&_url_or_drop, - mailto => \&_keep, - ':custom' => \&_prefix_custom, -}; - -sub _repo_type { - my ($element, $key, $meta, $to_version) = @_; - return $element if defined $element; - return unless exists $meta->{url}; - my $repo_url = $meta->{url}; - for my $type ( qw/git svn/ ) { - return $type if $repo_url =~ m{\A$type}; - } - return; -} - -my $repository2_spec = { - web => \&_url_or_drop, - url => \&_url_or_drop, - type => \&_repo_type, - ':custom' => \&_prefix_custom, -}; - -my $resources2_cleanup = { - license => \&_url_list, - homepage => \&_url_or_drop, - bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, - repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, - ':custom' => \&_prefix_custom, -}; - -sub _cleanup_resources_2 { - my ($resources, $key, $meta, $to_version) = @_; - return unless $resources && ref $resources eq 'HASH'; - return _convert($resources, $resources2_cleanup, $to_version); -} - -my $resource1_spec = { - license => \&_url_or_drop, - homepage => \&_url_or_drop, - bugtracker => \&_url_or_drop, - repository => \&_url_or_drop, - ':custom' => \&_keep, -}; - -sub _resources_1_3 { - my (undef, undef, $meta, $version) = @_; - return unless exists $meta->{resources}; - return _convert($meta->{resources}, $resource1_spec); -} - -*_resources_1_4 = *_resources_1_3; - -sub _resources_1_2 { - my (undef, undef, $meta) = @_; - my $resources = $meta->{resources} || {}; - if ( $meta->{license_url} && ! $resources->{license} ) { - $resources->{license} = $meta->{license_url} - if _is_urlish($meta->{license_url}); - } - return unless keys %$resources; - return _convert($resources, $resource1_spec); -} - -my $resource_downgrade_spec = { - license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, - homepage => \&_url_or_drop, - bugtracker => sub { return $_[0]->{web} }, - repository => sub { return $_[0]->{url} || $_[0]->{web} }, - ':custom' => \&_no_prefix_ucfirst_custom, -}; - -sub _downgrade_resources { - my (undef, undef, $meta, $version) = @_; - return unless exists $meta->{resources}; - return _convert($meta->{resources}, $resource_downgrade_spec); -} - -sub _release_status { - my ($element, undef, $meta) = @_; - return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; - return _release_status_from_version(undef, undef, $meta); -} - -sub _release_status_from_version { - my (undef, undef, $meta) = @_; - my $version = $meta->{version} || ''; - return ( $version =~ /_/ ) ? 'testing' : 'stable'; -} - -my $provides_spec = { - file => \&_keep, - version => \&_keep, -}; - -my $provides_spec_2 = { - file => \&_keep, - version => \&_keep, - ':custom' => \&_prefix_custom, -}; - -sub _provides { - my ($element, $key, $meta, $to_version) = @_; - return unless defined $element && ref $element eq 'HASH'; - my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; - my $new_data = {}; - for my $k ( keys %$element ) { - $new_data->{$k} = _convert($element->{$k}, $spec, $to_version); - $new_data->{$k}{version} = _clean_version($element->{$k}{version}) - if exists $element->{$k}{version}; - } - return $new_data; -} - -sub _convert { - my ($data, $spec, $to_version, $is_fragment) = @_; - - my $new_data = {}; - for my $key ( keys %$spec ) { - next if $key eq ':custom' || $key eq ':drop'; - next unless my $fcn = $spec->{$key}; - if ( $is_fragment && $key eq 'generated_by' ) { - $fcn = \&_keep; - } - die "spec for '$key' is not a coderef" - unless ref $fcn && ref $fcn eq 'CODE'; - my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); - $new_data->{$key} = $new_value if defined $new_value; - } - - my $drop_list = $spec->{':drop'}; - my $customizer = $spec->{':custom'} || \&_keep; - - for my $key ( keys %$data ) { - next if $drop_list && grep { $key eq $_ } @$drop_list; - next if exists $spec->{$key}; # we handled it - $new_data->{ $customizer->($key) } = $data->{$key}; - } - - return $new_data; -} - -#--------------------------------------------------------------------------# -# define converters for each conversion -#--------------------------------------------------------------------------# - -# each converts from prior version -# special ":custom" field is used for keys not recognized in spec -my %up_convert = ( - '2-from-1.4' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_2, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'dynamic_config' => \&_keep_or_one, - # ADDED MANDATORY - 'release_status' => \&_release_status_from_version, - # PRIOR OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_upgrade_optional_features, - 'provides' => \&_provides, - 'resources' => \&_upgrade_resources_2, - # ADDED OPTIONAL - 'description' => \&_keep, - 'prereqs' => \&_prereqs_from_1, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - build_requires - configure_requires - conflicts - distribution_type - license_url - private - recommends - requires - ) ], - - # other random keys need x_ prefixing - ':custom' => \&_prefix_custom, - }, - '1.4-from-1.3' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_1_4, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_4, - # ADDED OPTIONAL - 'configure_requires' => \&_keep, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - license_url - private - )], - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.3-from-1.2' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - license_url - private - )], - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.2-from-1.1' => { - # PRIOR MANDATORY - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'license' => \&_license_1, - 'name' => \&_keep, - 'generated_by' => \&_generated_by, - # ADDED MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'meta-spec' => \&_change_meta_spec, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_1_2, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'resources' => \&_resources_1_2, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - license_url - private - )], - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.1-from-1.0' => { - # CHANGED TO MANDATORY - 'version' => \&_keep, - # IMPLIED MANDATORY - 'name' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'license_url' => \&_url_or_drop, - 'private' => \&_keep, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, -); - -my %down_convert = ( - '1.4-from-2' => { - # MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_downgrade_license, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # OPTIONAL - 'build_requires' => \&_get_build_requires, - 'configure_requires' => \&_get_configure_requires, - 'conflicts' => \&_get_conflicts, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_downgrade_optional_features, - 'provides' => \&_provides, - 'recommends' => \&_get_recommends, - 'requires' => \&_get_requires, - 'resources' => \&_downgrade_resources, - - # drop these unsupported fields (after conversion) - ':drop' => [ qw( - description - prereqs - release_status - )], - - # custom keys will be left unchanged - ':custom' => \&_keep - }, - '1.3-from-1.4' => { - # MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # drop these unsupported fields, but only after we convert - ':drop' => [ qw( - configure_requires - )], - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - '1.2-from-1.3' => { - # MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_1_2, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - '1.1-from-1.2' => { - # MANDATORY - 'version' => \&_keep, - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - # OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'private' => \&_keep, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - - # drop unsupported fields - ':drop' => [ qw( - abstract - author - provides - no_index - keywords - resources - )], - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, - '1.0-from-1.1' => { - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, -); - -my %cleanup = ( - '2' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_2, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'dynamic_config' => \&_keep_or_one, - # ADDED MANDATORY - 'release_status' => \&_release_status, - # PRIOR OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_cleanup_optional_features_2, - 'provides' => \&_provides, - 'resources' => \&_cleanup_resources_2, - # ADDED OPTIONAL - 'description' => \&_keep, - 'prereqs' => \&_cleanup_prereqs, - - # drop these deprecated fields, but only after we convert - ':drop' => [ qw( - build_requires - configure_requires - conflicts - distribution_type - license_url - private - recommends - requires - ) ], - - # other random keys need x_ prefixing - ':custom' => \&_prefix_custom, - }, - '1.4' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_1_4, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_4, - # ADDED OPTIONAL - 'configure_requires' => \&_keep, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.3' => { - # PRIOR MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'meta-spec' => \&_change_meta_spec, - 'name' => \&_keep, - 'version' => \&_keep, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'keywords' => \&_keep, - 'no_index' => \&_no_index_directory, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - 'resources' => \&_resources_1_3, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.2' => { - # PRIOR MANDATORY - 'version' => \&_keep, - # CHANGED TO MANDATORY - 'license' => \&_license_1, - 'name' => \&_keep, - 'generated_by' => \&_generated_by, - # ADDED MANDATORY - 'abstract' => \&_keep_or_unknown, - 'author' => \&_author_list, - 'meta-spec' => \&_change_meta_spec, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'keywords' => \&_keep, - 'no_index' => \&_no_index_1_2, - 'optional_features' => \&_optional_features_as_map, - 'provides' => \&_provides, - 'resources' => \&_resources_1_2, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.1' => { - # CHANGED TO MANDATORY - 'version' => \&_keep, - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - # PRIOR OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - # ADDED OPTIONAL - 'license_url' => \&_url_or_drop, - 'private' => \&_keep, - - # other random keys are OK if already valid - ':custom' => \&_keep - }, - '1.0' => { - # IMPLIED MANDATORY - 'name' => \&_keep, - 'meta-spec' => \&_change_meta_spec, - 'version' => \&_keep, - # IMPLIED OPTIONAL - 'build_requires' => \&_version_map, - 'conflicts' => \&_version_map, - 'distribution_type' => \&_keep, - 'dynamic_config' => \&_keep_or_one, - 'generated_by' => \&_generated_by, - 'license' => \&_license_1, - 'recommends' => \&_version_map, - 'requires' => \&_version_map, - - # other random keys are OK if already valid - ':custom' => \&_keep, - }, -); - -# for a given field in a spec version, what fields will it feed -# into in the *latest* spec (i.e. v2); meta-spec omitted because -# we always expect a meta-spec to be generated -my %fragments_generate = ( - '2' => { - 'abstract' => 'abstract', - 'author' => 'author', - 'generated_by' => 'generated_by', - 'license' => 'license', - 'name' => 'name', - 'version' => 'version', - 'dynamic_config' => 'dynamic_config', - 'release_status' => 'release_status', - 'keywords' => 'keywords', - 'no_index' => 'no_index', - 'optional_features' => 'optional_features', - 'provides' => 'provides', - 'resources' => 'resources', - 'description' => 'description', - 'prereqs' => 'prereqs', - }, - '1.4' => { - 'abstract' => 'abstract', - 'author' => 'author', - 'generated_by' => 'generated_by', - 'license' => 'license', - 'name' => 'name', - 'version' => 'version', - 'build_requires' => 'prereqs', - 'conflicts' => 'prereqs', - 'distribution_type' => 'distribution_type', - 'dynamic_config' => 'dynamic_config', - 'keywords' => 'keywords', - 'no_index' => 'no_index', - 'optional_features' => 'optional_features', - 'provides' => 'provides', - 'recommends' => 'prereqs', - 'requires' => 'prereqs', - 'resources' => 'resources', - 'configure_requires' => 'prereqs', - }, -); -# this is not quite true but will work well enough -# as 1.4 is a superset of earlier ones -$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/; - -#--------------------------------------------------------------------------# -# Code -#--------------------------------------------------------------------------# - -#pod =method new -#pod -#pod my $cmc = CPAN::Meta::Converter->new( $struct ); -#pod -#pod The constructor should be passed a valid metadata structure but invalid -#pod structures are accepted. If no meta-spec version is provided, version 1.0 will -#pod be assumed. -#pod -#pod Optionally, you can provide a C argument after C<$struct>: -#pod -#pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); -#pod -#pod This is only needed when converting a metadata fragment that does not include a -#pod C field. -#pod -#pod =cut - -sub new { - my ($class,$data,%args) = @_; - - # create an attributes hash - my $self = { - 'data' => $data, - 'spec' => _extract_spec_version($data, $args{default_version}), - }; - - # create the object - return bless $self, $class; -} - -sub _extract_spec_version { - my ($data, $default) = @_; - my $spec = $data->{'meta-spec'}; - - # is meta-spec there and valid? - return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec? - - # does the version key look like a valid version? - my $v = $spec->{version}; - if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) { - return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec - return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2 - } - - # otherwise, use heuristics: look for 1.x vs 2.0 fields - return "2" if exists $data->{prereqs}; - return "1.4" if exists $data->{configure_requires}; - return( $default || "1.2" ); # when meta-spec was first defined -} - -#pod =method convert -#pod -#pod my $new_struct = $cmc->convert( version => "2" ); -#pod -#pod Returns a new hash reference with the metadata converted to a different form. -#pod C will die if any conversion/standardization still results in an -#pod invalid structure. -#pod -#pod Valid parameters include: -#pod -#pod =over -#pod -#pod =item * -#pod -#pod C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). -#pod Defaults to the latest version of the CPAN Meta Spec. -#pod -#pod =back -#pod -#pod Conversion proceeds through each version in turn. For example, a version 1.2 -#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The -#pod conversion process attempts to clean-up simple errors and standardize data. -#pod For example, if C is given as a scalar, it will converted to an array -#pod reference containing the item. (Converting a structure to its own version will -#pod also clean-up and standardize.) -#pod -#pod When data are cleaned and standardized, missing or invalid fields will be -#pod replaced with sensible defaults when possible. This may be lossy or imprecise. -#pod For example, some badly structured META.yml files on CPAN have prerequisite -#pod modules listed as both keys and values: -#pod -#pod requires => { 'Foo::Bar' => 'Bam::Baz' } -#pod -#pod These would be split and each converted to a prerequisite with a minimum -#pod version of zero. -#pod -#pod When some mandatory fields are missing or invalid, the conversion will attempt -#pod to provide a sensible default or will fill them with a value of 'unknown'. For -#pod example a missing or unrecognized C field will result in a C -#pod field of 'unknown'. Fields that may get an 'unknown' include: -#pod -#pod =for :list -#pod * abstract -#pod * author -#pod * license -#pod -#pod =cut - -sub convert { - my ($self, %args) = @_; - my $args = { %args }; - - my $new_version = $args->{version} || $HIGHEST; - my $is_fragment = $args->{is_fragment}; - - my ($old_version) = $self->{spec}; - my $converted = _dclone($self->{data}); - - if ( $old_version == $new_version ) { - $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment ); - unless ( $args->{is_fragment} ) { - my $cmv = CPAN::Meta::Validator->new( $converted ); - unless ( $cmv->is_valid ) { - my $errs = join("\n", $cmv->errors); - die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; - } - } - return $converted; - } - elsif ( $old_version > $new_version ) { - my @vers = sort { $b <=> $a } keys %known_specs; - for my $i ( 0 .. $#vers-1 ) { - next if $vers[$i] > $old_version; - last if $vers[$i+1] < $new_version; - my $spec_string = "$vers[$i+1]-from-$vers[$i]"; - $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment ); - unless ( $args->{is_fragment} ) { - my $cmv = CPAN::Meta::Validator->new( $converted ); - unless ( $cmv->is_valid ) { - my $errs = join("\n", $cmv->errors); - die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; - } - } - } - return $converted; - } - else { - my @vers = sort { $a <=> $b } keys %known_specs; - for my $i ( 0 .. $#vers-1 ) { - next if $vers[$i] < $old_version; - last if $vers[$i+1] > $new_version; - my $spec_string = "$vers[$i+1]-from-$vers[$i]"; - $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment ); - unless ( $args->{is_fragment} ) { - my $cmv = CPAN::Meta::Validator->new( $converted ); - unless ( $cmv->is_valid ) { - my $errs = join("\n", $cmv->errors); - die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; - } - } - } - return $converted; - } -} - -#pod =method upgrade_fragment -#pod -#pod my $new_struct = $cmc->upgrade_fragment; -#pod -#pod Returns a new hash reference with the metadata converted to the latest version -#pod of the CPAN Meta Spec. No validation is done on the result -- you must -#pod validate after merging fragments into a complete metadata document. -#pod -#pod =cut - -sub upgrade_fragment { - my ($self) = @_; - my ($old_version) = $self->{spec}; - my %expected = - map {; $_ => 1 } - grep { defined } - map { $fragments_generate{$old_version}{$_} } - keys %{ $self->{data} }; - my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 ); - for my $key ( keys %$converted ) { - next if $key =~ /^x_/i || $key eq 'meta-spec'; - delete $converted->{$key} unless $expected{$key}; - } - return $converted; -} - -1; - -# ABSTRACT: Convert CPAN distribution metadata structures - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Converter - Convert CPAN distribution metadata structures - -=head1 VERSION - -version 2.143240 - -=head1 SYNOPSIS - - my $struct = decode_json_file('META.json'); - - my $cmc = CPAN::Meta::Converter->new( $struct ); - - my $new_struct = $cmc->convert( version => "2" ); - -=head1 DESCRIPTION - -This module converts CPAN Meta structures from one form to another. The -primary use is to convert older structures to the most modern version of -the specification, but other transformations may be implemented in the -future as needed. (E.g. stripping all custom fields or stripping all -optional fields.) - -=head1 METHODS - -=head2 new - - my $cmc = CPAN::Meta::Converter->new( $struct ); - -The constructor should be passed a valid metadata structure but invalid -structures are accepted. If no meta-spec version is provided, version 1.0 will -be assumed. - -Optionally, you can provide a C argument after C<$struct>: - - my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); - -This is only needed when converting a metadata fragment that does not include a -C field. - -=head2 convert - - my $new_struct = $cmc->convert( version => "2" ); - -Returns a new hash reference with the metadata converted to a different form. -C will die if any conversion/standardization still results in an -invalid structure. - -Valid parameters include: - -=over - -=item * - -C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). -Defaults to the latest version of the CPAN Meta Spec. - -=back - -Conversion proceeds through each version in turn. For example, a version 1.2 -structure might be converted to 1.3 then 1.4 then finally to version 2. The -conversion process attempts to clean-up simple errors and standardize data. -For example, if C is given as a scalar, it will converted to an array -reference containing the item. (Converting a structure to its own version will -also clean-up and standardize.) - -When data are cleaned and standardized, missing or invalid fields will be -replaced with sensible defaults when possible. This may be lossy or imprecise. -For example, some badly structured META.yml files on CPAN have prerequisite -modules listed as both keys and values: - - requires => { 'Foo::Bar' => 'Bam::Baz' } - -These would be split and each converted to a prerequisite with a minimum -version of zero. - -When some mandatory fields are missing or invalid, the conversion will attempt -to provide a sensible default or will fill them with a value of 'unknown'. For -example a missing or unrecognized C field will result in a C -field of 'unknown'. Fields that may get an 'unknown' include: - -=over 4 - -=item * - -abstract - -=item * - -author - -=item * - -license - -=back - -=head2 upgrade_fragment - - my $new_struct = $cmc->upgrade_fragment; - -Returns a new hash reference with the metadata converted to the latest version -of the CPAN Meta Spec. No validation is done on the result -- you must -validate after merging fragments into a complete metadata document. - -=head1 BUGS - -Please report any bugs or feature using the CPAN Request Tracker. -Bugs can be submitted through the web interface at -L - -When submitting a bug or request, please include a test-file or a patch to an -existing test-file that illustrates the bug or desired feature. - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut - -__END__ - - -# vim: ts=2 sts=2 sw=2 et: diff --git a/bundled/CPAN-Meta/CPAN/Meta/Feature.pm b/bundled/CPAN-Meta/CPAN/Meta/Feature.pm deleted file mode 100644 index 45ab897..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/Feature.pm +++ /dev/null @@ -1,145 +0,0 @@ -use 5.006; -use strict; -use warnings; -package CPAN::Meta::Feature; -# VERSION -$CPAN::Meta::Feature::VERSION = '2.143240'; -use CPAN::Meta::Prereqs; - -#pod =head1 DESCRIPTION -#pod -#pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN -#pod distribution and specified in the distribution's F (or F) -#pod file. -#pod -#pod For the most part, this class will only be used when operating on the result of -#pod the C or C methods on a L object. -#pod -#pod =method new -#pod -#pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); -#pod -#pod This returns a new Feature object. The C<%spec> argument to the constructor -#pod should be the same as the value of the C entry in the -#pod distmeta. It must contain entries for C and C. -#pod -#pod =cut - -sub new { - my ($class, $identifier, $spec) = @_; - - my %guts = ( - identifier => $identifier, - description => $spec->{description}, - prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}), - ); - - bless \%guts => $class; -} - -#pod =method identifier -#pod -#pod This method returns the feature's identifier. -#pod -#pod =cut - -sub identifier { $_[0]{identifier} } - -#pod =method description -#pod -#pod This method returns the feature's long description. -#pod -#pod =cut - -sub description { $_[0]{description} } - -#pod =method prereqs -#pod -#pod This method returns the feature's prerequisites as a L -#pod object. -#pod -#pod =cut - -sub prereqs { $_[0]{prereqs} } - -1; - -# ABSTRACT: an optional feature provided by a CPAN distribution - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Feature - an optional feature provided by a CPAN distribution - -=head1 VERSION - -version 2.143240 - -=head1 DESCRIPTION - -A CPAN::Meta::Feature object describes an optional feature offered by a CPAN -distribution and specified in the distribution's F (or F) -file. - -For the most part, this class will only be used when operating on the result of -the C or C methods on a L object. - -=head1 METHODS - -=head2 new - - my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); - -This returns a new Feature object. The C<%spec> argument to the constructor -should be the same as the value of the C entry in the -distmeta. It must contain entries for C and C. - -=head2 identifier - -This method returns the feature's identifier. - -=head2 description - -This method returns the feature's long description. - -=head2 prereqs - -This method returns the feature's prerequisites as a L -object. - -=head1 BUGS - -Please report any bugs or feature using the CPAN Request Tracker. -Bugs can be submitted through the web interface at -L - -When submitting a bug or request, please include a test-file or a patch to an -existing test-file that illustrates the bug or desired feature. - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta/CPAN/Meta/History.pm b/bundled/CPAN-Meta/CPAN/Meta/History.pm deleted file mode 100644 index b5339d1..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/History.pm +++ /dev/null @@ -1,315 +0,0 @@ -# vi:tw=72 -use 5.006; -use strict; -use warnings; -package CPAN::Meta::History; -# VERSION -$CPAN::Meta::History::VERSION = '2.143240'; -1; - -# ABSTRACT: history of CPAN Meta Spec changes - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::History - history of CPAN Meta Spec changes - -=head1 VERSION - -version 2.143240 - -=head1 DESCRIPTION - -The CPAN Meta Spec has gone through several iterations. It was -originally written in HTML and later revised into POD (though published -in HTML generated from the POD). Fields were added, removed or changed, -sometimes by design and sometimes to reflect real-world usage after the -fact. - -This document reconstructs the history of the CPAN Meta Spec based on -change logs, repository commit messages and the published HTML files. -In some cases, particularly prior to version 1.2, the exact version -when certain fields were introduced or changed is inconsistent between -sources. When in doubt, the published HTML files for versions 1.0 to -1.4 as they existed when version 2 was developed are used as the -definitive source. - -Starting with version 2, the specification document is part of the -CPAN-Meta distribution and will be published on CPAN as -L. - -Going forward, specification version numbers will be integers and -decimal portions will correspond to a release date for the CPAN::Meta -library. - -=head1 HISTORY - -=head2 Version 2 - -April 2010 - -=over - -=item * - -Revised spec examples as perl data structures rather than YAML - -=item * - -Switched to JSON serialization from YAML - -=item * - -Specified allowed version number formats - -=item * - -Replaced 'requires', 'build_requires', 'configure_requires', -'recommends' and 'conflicts' with new 'prereqs' data structure divided -by I (configure, build, test, runtime, etc.) and I -(requires, recommends, suggests, conflicts) - -=item * - -Added support for 'develop' phase for requirements for maintaining -a list of authoring tools - -=item * - -Changed 'license' to a list and revised the set of valid licenses - -=item * - -Made 'dynamic_config' mandatory to reduce confusion - -=item * - -Changed 'resources' subkey 'repository' to a hash that clarifies -repository type, url for browsing and url for checkout - -=item * - -Changed 'resources' subkey 'bugtracker' to a hash for either web -or mailto resource - -=item * - -Changed specification of 'optional_features': - -=over - -=item * - -Added formal specification and usage guide instead of just example - -=item * - -Changed to use new prereqs data structure instead of individual keys - -=back - -=item * - -Clarified intended use of 'author' as generalized contact list - -=item * - -Added 'release_status' field to indicate stable, testing or unstable -status to provide hints to indexers - -=item * - -Added 'description' field for a longer description of the distribution - -=item * - -Formalized use of "x_" or "X_" for all custom keys not listed in the -official spec - -=back - -=head2 Version 1.4 - -June 2008 - -=over - -=item * - -Noted explicit support for 'perl' in prerequisites - -=item * - -Added 'configure_requires' prerequisite type - -=item * - -Changed 'optional_features' - -=over - -=item * - -Example corrected to show map of maps instead of list of maps -(though descriptive text said 'map' even in v1.3) - -=item * - -Removed 'requires_packages', 'requires_os' and 'excluded_os' -as valid subkeys - -=back - -=back - -=head2 Version 1.3 - -November 2006 - -=over - -=item * - -Added 'no_index' subkey 'directory' and removed 'dir' to match actual -usage in the wild - -=item * - -Added a 'repository' subkey to 'resources' - -=back - -=head2 Version 1.2 - -August 2005 - -=over - -=item * - -Re-wrote and restructured spec in POD syntax - -=item * - -Changed 'name' to be mandatory - -=item * - -Changed 'generated_by' to be mandatory - -=item * - -Changed 'license' to be mandatory - -=item * - -Added version range specifications for prerequisites - -=item * - -Added required 'abstract' field - -=item * - -Added required 'author' field - -=item * - -Added required 'meta-spec' field to define 'version' (and 'url') of the -CPAN Meta Spec used for metadata - -=item * - -Added 'provides' field - -=item * - -Added 'no_index' field and deprecated 'private' field. 'no_index' -subkeys include 'file', 'dir', 'package' and 'namespace' - -=item * - -Added 'keywords' field - -=item * - -Added 'resources' field with subkeys 'homepage', 'license', and -'bugtracker' - -=item * - -Added 'optional_features' field as an alternate under 'recommends'. -Includes 'description', 'requires', 'build_requires', 'conflicts', -'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys - -=item * - -Removed 'license_uri' field - -=back - -=head2 Version 1.1 - -May 2003 - -=over - -=item * - -Changed 'version' to be mandatory - -=item * - -Added 'private' field - -=item * - -Added 'license_uri' field - -=back - -=head2 Version 1.0 - -March 2003 - -=over - -=item * - -Original release (in HTML format only) - -=item * - -Included 'name', 'version', 'license', 'distribution_type', 'requires', -'recommends', 'build_requires', 'conflicts', 'dynamic_config', -'generated_by' - -=back - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta/CPAN/Meta/Merge.pm b/bundled/CPAN-Meta/CPAN/Meta/Merge.pm deleted file mode 100644 index 5571c51..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/Merge.pm +++ /dev/null @@ -1,277 +0,0 @@ -use strict; -use warnings; - -package CPAN::Meta::Merge; -# VERSION -$CPAN::Meta::Merge::VERSION = '2.143240'; -use Carp qw/croak/; -use Scalar::Util qw/blessed/; -use CPAN::Meta::Converter; - -sub _identical { - my ($left, $right, $path) = @_; - croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right unless $left eq $right; - return $left; -} - -sub _merge { - my ($current, $next, $mergers, $path) = @_; - for my $key (keys %{$next}) { - if (not exists $current->{$key}) { - $current->{$key} = $next->{$key}; - } - elsif (my $merger = $mergers->{$key}) { - $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); - } - elsif ($merger = $mergers->{':default'}) { - $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); - } - else { - croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key; - } - } - return $current; -} - -sub _uniq { - my %seen = (); - return grep { not $seen{$_}++ } @_; -} - -sub _set_addition { - my ($left, $right) = @_; - return [ +_uniq(@{$left}, @{$right}) ]; -} - -sub _uniq_map { - my ($left, $right, $path) = @_; - for my $key (keys %{$right}) { - if (not exists $left->{$key}) { - $left->{$key} = $right->{$key}; - } - else { - croak 'Duplication of element ' . join '.', @{$path}, $key; - } - } - return $left; -} - -sub _improvize { - my ($left, $right, $path) = @_; - my ($name) = reverse @{$path}; - if ($name =~ /^x_/) { - if (ref($left) eq 'ARRAY') { - return _set_addition($left, $right, $path); - } - elsif (ref($left) eq 'HASH') { - return _uniq_map($left, $right, $path); - } - else { - return _identical($left, $right, $path); - } - } - croak sprintf "Can't merge '%s'", join '.', @{$path}; -} - -sub _optional_features { - my ($left, $right, $path) = @_; - - for my $key (keys %{$right}) { - if (not exists $left->{$key}) { - $left->{$key} = $right->{$key}; - } - else { - for my $subkey (keys %{ $right->{$key} }) { - next if $subkey eq 'prereqs'; - if (not exists $left->{$key}{$subkey}) { - $left->{$key}{$subkey} = $right->{$key}{$subkey}; - } - else { - Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" - if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} }; - } - } - - require CPAN::Meta::Prereqs; - $left->{$key}{prereqs} = - CPAN::Meta::Prereqs->new($left->{$key}{prereqs}) - ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs})) - ->as_string_hash; - } - } - return $left; -} - - -my %default = ( - abstract => \&_identical, - author => \&_set_addition, - dynamic_config => sub { - my ($left, $right) = @_; - return $left || $right; - }, - generated_by => sub { - my ($left, $right) = @_; - return join ', ', _uniq(split(/, /, $left), split(/, /, $right)); - }, - license => \&_set_addition, - 'meta-spec' => { - version => \&_identical, - url => \&_identical - }, - name => \&_identical, - release_status => \&_identical, - version => \&_identical, - description => \&_identical, - keywords => \&_set_addition, - no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ }, - optional_features => \&_optional_features, - prereqs => sub { - require CPAN::Meta::Prereqs; - my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1]; - return $left->with_merged_prereqs($right)->as_string_hash; - }, - provides => \&_uniq_map, - resources => { - license => \&_set_addition, - homepage => \&_identical, - bugtracker => \&_uniq_map, - repository => \&_uniq_map, - ':default' => \&_improvize, - }, - ':default' => \&_improvize, -); - -sub new { - my ($class, %arguments) = @_; - croak 'default version required' if not exists $arguments{default_version}; - my %mapping = %default; - my %extra = %{ $arguments{extra_mappings} || {} }; - for my $key (keys %extra) { - if (ref($mapping{$key}) eq 'HASH') { - $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } }; - } - else { - $mapping{$key} = $extra{$key}; - } - } - return bless { - default_version => $arguments{default_version}, - mapping => _coerce_mapping(\%mapping, []), - }, $class; -} - -my %coderef_for = ( - set_addition => \&_set_addition, - uniq_map => \&_uniq_map, - identical => \&_identical, - improvize => \&_improvize, -); - -sub _coerce_mapping { - my ($orig, $map_path) = @_; - my %ret; - for my $key (keys %{$orig}) { - my $value = $orig->{$key}; - if (ref($orig->{$key}) eq 'CODE') { - $ret{$key} = $value; - } - elsif (ref($value) eq 'HASH') { - my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]); - $ret{$key} = sub { - my ($left, $right, $path) = @_; - return _merge($left, $right, $mapping, [ @{$path} ]); - }; - } - elsif ($coderef_for{$value}) { - $ret{$key} = $coderef_for{$value}; - } - else { - croak "Don't know what to do with " . join '.', @{$map_path}, $key; - } - } - return \%ret; -} - -sub merge { - my ($self, @items) = @_; - my $current = {}; - for my $next (@items) { - if ( blessed($next) && $next->isa('CPAN::Meta') ) { - $next = $next->as_struct; - } - elsif ( ref($next) eq 'HASH' ) { - my $cmc = CPAN::Meta::Converter->new( - $next, default_version => $self->{default_version} - ); - $next = $cmc->upgrade_fragment; - } - else { - croak "Don't know how to merge '$next'"; - } - $current = _merge($current, $next, $self->{mapping}, []); - } - return $current; -} - -1; - -# ABSTRACT: Merging CPAN Meta fragments - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Merge - Merging CPAN Meta fragments - -=head1 VERSION - -version 2.143240 - -=head1 SYNOPSIS - - my $merger = CPAN::Meta::Merge->new(default_version => "2"); - my $meta = $merger->merge($base, @additional); - -=head1 DESCRIPTION - -=head1 METHODS - -=head2 new - -This creates a CPAN::Meta::Merge object. It takes one mandatory named -argument, C, declaring the version of the meta-spec that must be -used for the merge. It can optionally take an C argument -that allows one to add additional merging functions for specific elements. - -=head2 merge(@fragments) - -Merge all C<@fragments> together. It will accept both CPAN::Meta objects and -(possibly incomplete) hashrefs of metadata. - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta/CPAN/Meta/Prereqs.pm b/bundled/CPAN-Meta/CPAN/Meta/Prereqs.pm deleted file mode 100644 index 748a237..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/Prereqs.pm +++ /dev/null @@ -1,418 +0,0 @@ -use 5.006; -use strict; -use warnings; -package CPAN::Meta::Prereqs; -# VERSION -$CPAN::Meta::Prereqs::VERSION = '2.143240'; -#pod =head1 DESCRIPTION -#pod -#pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN -#pod distribution or one of its optional features. Each set of prereqs is -#pod organized by phase and type, as described in L. -#pod -#pod =cut - -use Carp qw(confess); -use Scalar::Util qw(blessed); -use CPAN::Meta::Requirements 2.121; - -#pod =method new -#pod -#pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); -#pod -#pod This method returns a new set of Prereqs. The input should look like the -#pod contents of the C field described in L, meaning -#pod something more or less like this: -#pod -#pod my $prereq = CPAN::Meta::Prereqs->new({ -#pod runtime => { -#pod requires => { -#pod 'Some::Module' => '1.234', -#pod ..., -#pod }, -#pod ..., -#pod }, -#pod ..., -#pod }); -#pod -#pod You can also construct an empty set of prereqs with: -#pod -#pod my $prereqs = CPAN::Meta::Prereqs->new; -#pod -#pod This empty set of prereqs is useful for accumulating new prereqs before finally -#pod dumping the whole set into a structure or string. -#pod -#pod =cut - -sub __legal_phases { qw(configure build test runtime develop) } -sub __legal_types { qw(requires recommends suggests conflicts) } - -# expect a prereq spec from META.json -- rjbs, 2010-04-11 -sub new { - my ($class, $prereq_spec) = @_; - $prereq_spec ||= {}; - - my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases; - my %is_legal_type = map {; $_ => 1 } $class->__legal_types; - - my %guts; - PHASE: for my $phase (keys %$prereq_spec) { - next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase}; - - my $phase_spec = $prereq_spec->{ $phase }; - next PHASE unless keys %$phase_spec; - - TYPE: for my $type (keys %$phase_spec) { - next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type}; - - my $spec = $phase_spec->{ $type }; - - next TYPE unless keys %$spec; - - $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash( - $spec - ); - } - } - - return bless \%guts => $class; -} - -#pod =method requirements_for -#pod -#pod my $requirements = $prereqs->requirements_for( $phase, $type ); -#pod -#pod This method returns a L object for the given -#pod phase/type combination. If no prerequisites are registered for that -#pod combination, a new CPAN::Meta::Requirements object will be returned, and it may -#pod be added to as needed. -#pod -#pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will -#pod be raised. -#pod -#pod =cut - -sub requirements_for { - my ($self, $phase, $type) = @_; - - confess "requirements_for called without phase" unless defined $phase; - confess "requirements_for called without type" unless defined $type; - - unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { - confess "requested requirements for unknown phase: $phase"; - } - - unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { - confess "requested requirements for unknown type: $type"; - } - - my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new); - - $req->finalize if $self->is_finalized; - - return $req; -} - -#pod =method with_merged_prereqs -#pod -#pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); -#pod -#pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); -#pod -#pod This method returns a new CPAN::Meta::Prereqs objects in which all the -#pod other prerequisites given are merged into the current set. This is primarily -#pod provided for combining a distribution's core prereqs with the prereqs of one of -#pod its optional features. -#pod -#pod The new prereqs object has no ties to the originals, and altering it further -#pod will not alter them. -#pod -#pod =cut - -sub with_merged_prereqs { - my ($self, $other) = @_; - - my @other = blessed($other) ? $other : @$other; - - my @prereq_objs = ($self, @other); - - my %new_arg; - - for my $phase ($self->__legal_phases) { - for my $type ($self->__legal_types) { - my $req = CPAN::Meta::Requirements->new; - - for my $prereq (@prereq_objs) { - my $this_req = $prereq->requirements_for($phase, $type); - next unless $this_req->required_modules; - - $req->add_requirements($this_req); - } - - next unless $req->required_modules; - - $new_arg{ $phase }{ $type } = $req->as_string_hash; - } - } - - return (ref $self)->new(\%new_arg); -} - -#pod =method merged_requirements -#pod -#pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); -#pod my $new_reqs = $prereqs->merged_requirements( \@phases ); -#pod my $new_reqs = $preerqs->merged_requirements(); -#pod -#pod This method joins together all requirements across a number of phases -#pod and types into a new L object. If arguments -#pod are omitted, it defaults to "runtime", "build" and "test" for phases -#pod and "requires" and "recommends" for types. -#pod -#pod =cut - -sub merged_requirements { - my ($self, $phases, $types) = @_; - $phases = [qw/runtime build test/] unless defined $phases; - $types = [qw/requires recommends/] unless defined $types; - - confess "merged_requirements phases argument must be an arrayref" - unless ref $phases eq 'ARRAY'; - confess "merged_requirements types argument must be an arrayref" - unless ref $types eq 'ARRAY'; - - my $req = CPAN::Meta::Requirements->new; - - for my $phase ( @$phases ) { - unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { - confess "requested requirements for unknown phase: $phase"; - } - for my $type ( @$types ) { - unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { - confess "requested requirements for unknown type: $type"; - } - $req->add_requirements( $self->requirements_for($phase, $type) ); - } - } - - $req->finalize if $self->is_finalized; - - return $req; -} - - -#pod =method as_string_hash -#pod -#pod This method returns a hashref containing structures suitable for dumping into a -#pod distmeta data structure. It is made up of hashes and strings, only; there will -#pod be no Prereqs, CPAN::Meta::Requirements, or C objects inside it. -#pod -#pod =cut - -sub as_string_hash { - my ($self) = @_; - - my %hash; - - for my $phase ($self->__legal_phases) { - for my $type ($self->__legal_types) { - my $req = $self->requirements_for($phase, $type); - next unless $req->required_modules; - - $hash{ $phase }{ $type } = $req->as_string_hash; - } - } - - return \%hash; -} - -#pod =method is_finalized -#pod -#pod This method returns true if the set of prereqs has been marked "finalized," and -#pod cannot be altered. -#pod -#pod =cut - -sub is_finalized { $_[0]{finalized} } - -#pod =method finalize -#pod -#pod Calling C on a Prereqs object will close it for further modification. -#pod Attempting to make any changes that would actually alter the prereqs will -#pod result in an exception being thrown. -#pod -#pod =cut - -sub finalize { - my ($self) = @_; - - $self->{finalized} = 1; - - for my $phase (keys %{ $self->{prereqs} }) { - $_->finalize for values %{ $self->{prereqs}{$phase} }; - } -} - -#pod =method clone -#pod -#pod my $cloned_prereqs = $prereqs->clone; -#pod -#pod This method returns a Prereqs object that is identical to the original object, -#pod but can be altered without affecting the original object. Finalization does -#pod not survive cloning, meaning that you may clone a finalized set of prereqs and -#pod then modify the clone. -#pod -#pod =cut - -sub clone { - my ($self) = @_; - - my $clone = (ref $self)->new( $self->as_string_hash ); -} - -1; - -# ABSTRACT: a set of distribution prerequisites by phase and type - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type - -=head1 VERSION - -version 2.143240 - -=head1 DESCRIPTION - -A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN -distribution or one of its optional features. Each set of prereqs is -organized by phase and type, as described in L. - -=head1 METHODS - -=head2 new - - my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); - -This method returns a new set of Prereqs. The input should look like the -contents of the C field described in L, meaning -something more or less like this: - - my $prereq = CPAN::Meta::Prereqs->new({ - runtime => { - requires => { - 'Some::Module' => '1.234', - ..., - }, - ..., - }, - ..., - }); - -You can also construct an empty set of prereqs with: - - my $prereqs = CPAN::Meta::Prereqs->new; - -This empty set of prereqs is useful for accumulating new prereqs before finally -dumping the whole set into a structure or string. - -=head2 requirements_for - - my $requirements = $prereqs->requirements_for( $phase, $type ); - -This method returns a L object for the given -phase/type combination. If no prerequisites are registered for that -combination, a new CPAN::Meta::Requirements object will be returned, and it may -be added to as needed. - -If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will -be raised. - -=head2 with_merged_prereqs - - my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); - - my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); - -This method returns a new CPAN::Meta::Prereqs objects in which all the -other prerequisites given are merged into the current set. This is primarily -provided for combining a distribution's core prereqs with the prereqs of one of -its optional features. - -The new prereqs object has no ties to the originals, and altering it further -will not alter them. - -=head2 merged_requirements - - my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); - my $new_reqs = $prereqs->merged_requirements( \@phases ); - my $new_reqs = $preerqs->merged_requirements(); - -This method joins together all requirements across a number of phases -and types into a new L object. If arguments -are omitted, it defaults to "runtime", "build" and "test" for phases -and "requires" and "recommends" for types. - -=head2 as_string_hash - -This method returns a hashref containing structures suitable for dumping into a -distmeta data structure. It is made up of hashes and strings, only; there will -be no Prereqs, CPAN::Meta::Requirements, or C objects inside it. - -=head2 is_finalized - -This method returns true if the set of prereqs has been marked "finalized," and -cannot be altered. - -=head2 finalize - -Calling C on a Prereqs object will close it for further modification. -Attempting to make any changes that would actually alter the prereqs will -result in an exception being thrown. - -=head2 clone - - my $cloned_prereqs = $prereqs->clone; - -This method returns a Prereqs object that is identical to the original object, -but can be altered without affecting the original object. Finalization does -not survive cloning, meaning that you may clone a finalized set of prereqs and -then modify the clone. - -=head1 BUGS - -Please report any bugs or feature using the CPAN Request Tracker. -Bugs can be submitted through the web interface at -L - -When submitting a bug or request, please include a test-file or a patch to an -existing test-file that illustrates the bug or desired feature. - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta/CPAN/Meta/Spec.pm b/bundled/CPAN-Meta/CPAN/Meta/Spec.pm deleted file mode 100644 index a4e330b..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/Spec.pm +++ /dev/null @@ -1,1234 +0,0 @@ -# XXX RULES FOR PATCHING THIS FILE XXX -# Patches that fix typos or formatting are acceptable. Patches -# that change semantics are not acceptable without prior approval -# by David Golden or Ricardo Signes. - -use 5.006; -use strict; -use warnings; -package CPAN::Meta::Spec; -# VERSION -$CPAN::Meta::Spec::VERSION = '2.143240'; -1; - -# ABSTRACT: specification for CPAN distribution metadata - - -# vi:tw=72 - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Spec - specification for CPAN distribution metadata - -=head1 VERSION - -version 2.143240 - -=head1 SYNOPSIS - - my $distmeta = { - name => 'Module-Build', - abstract => 'Build and install Perl modules', - description => "Module::Build is a system for " - . "building, testing, and installing Perl modules. " - . "It is meant to ... blah blah blah ...", - version => '0.36', - release_status => 'stable', - author => [ - 'Ken Williams ', - 'Module-Build List ', # additional contact - ], - license => [ 'perl_5' ], - prereqs => { - runtime => { - requires => { - 'perl' => '5.006', - 'ExtUtils::Install' => '0', - 'File::Basename' => '0', - 'File::Compare' => '0', - 'IO::File' => '0', - }, - recommends => { - 'Archive::Tar' => '1.00', - 'ExtUtils::Install' => '0.3', - 'ExtUtils::ParseXS' => '2.02', - }, - }, - build => { - requires => { - 'Test::More' => '0', - }, - } - }, - resources => { - license => ['http://dev.perl.org/licenses/'], - }, - optional_features => { - domination => { - description => 'Take over the world', - prereqs => { - develop => { requires => { 'Genius::Evil' => '1.234' } }, - runtime => { requires => { 'Machine::Weather' => '2.0' } }, - }, - }, - }, - dynamic_config => 1, - keywords => [ qw/ toolchain cpan dual-life / ], - 'meta-spec' => { - version => '2', - url => 'https://metacpan.org/pod/CPAN::Meta::Spec', - }, - generated_by => 'Module::Build version 0.36', - }; - -=head1 DESCRIPTION - -This document describes version 2 of the CPAN distribution metadata -specification, also known as the "CPAN Meta Spec". - -Revisions of this specification for typo corrections and prose -clarifications may be issued as CPAN::Meta::Spec 2.I. These -revisions will never change semantics or add or remove specified -behavior. - -Distribution metadata describe important properties of Perl -distributions. Distribution building tools like Module::Build, -Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a -metadata file in accordance with this specification and include it with -the distribution for use by automated tools that index, examine, package -or install Perl distributions. - -=head1 TERMINOLOGY - -=over 4 - -=item distribution - -This is the primary object described by the metadata. In the context of -this document it usually refers to a collection of modules, scripts, -and/or documents that are distributed together for other developers to -use. Examples of distributions are C, C, -or C. - -=item module - -This refers to a reusable library of code contained in a single file. -Modules usually contain one or more packages and are often referred -to by the name of a primary package that can be mapped to the file -name. For example, one might refer to C instead of -F - -=item package - -This refers to a namespace declared with the Perl C statement. -In Perl, packages often have a version number property given by the -C<$VERSION> variable in the namespace. - -=item consumer - -This refers to code that reads a metadata file, deserializes it into a -data structure in memory, or interprets a data structure of metadata -elements. - -=item producer - -This refers to code that constructs a metadata data structure, -serializes into a bytestream and/or writes it to disk. - -=item must, should, may, etc. - -These terms are interpreted as described in IETF RFC 2119. - -=back - -=head1 DATA TYPES - -Fields in the L section describe data elements, each of -which has an associated data type as described herein. There are four -primitive types: Boolean, String, List and Map. Other types are -subtypes of primitives and define compound data structures or define -constraints on the values of a data element. - -=head2 Boolean - -A I is used to provide a true or false value. It B be -represented as a defined value. - -=head2 String - -A I is data element containing a non-zero length sequence of -Unicode characters, such as an ordinary Perl scalar that is not a -reference. - -=head2 List - -A I is an ordered collection of zero or more data elements. -Elements of a List may be of mixed types. - -Producers B represent List elements using a data structure which -unambiguously indicates that multiple values are possible, such as a -reference to a Perl array (an "arrayref"). - -Consumers expecting a List B consider a String as equivalent to a -List of length 1. - -=head2 Map - -A I is an unordered collection of zero or more data elements -("values"), indexed by associated String elements ("keys"). The Map's -value elements may be of mixed types. - -=head2 License String - -A I is a subtype of String with a restricted set of -values. Valid values are described in detail in the description of -the L field. - -=head2 URL - -I is a subtype of String containing a Uniform Resource Locator or -Identifier. [ This type is called URL and not URI for historical reasons. ] - -=head2 Version - -A I is a subtype of String containing a value that describes -the version number of packages or distributions. Restrictions on format -are described in detail in the L section. - -=head2 Version Range - -The I type is a subtype of String. It describes a range -of Versions that may be present or installed to fulfill prerequisites. -It is specified in detail in the L section. - -=head1 STRUCTURE - -The metadata structure is a data element of type Map. This section -describes valid keys within the Map. - -Any keys not described in this specification document (whether top-level -or within compound data structures described herein) are considered -I and B begin with an "x" or "X" and be followed by an -underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a -custom key refers to a compound data structure, subkeys within it do not -need an "x_" or "X_" prefix. - -Consumers of metadata may ignore any or all custom keys. All other keys -not described herein are invalid and should be ignored by consumers. -Producers must not generate or output invalid keys. - -For each key, an example is provided followed by a description. The -description begins with the version of spec in which the key was added -or in which the definition was modified, whether the key is I -or I and the data type of the corresponding data element. -These items are in parentheses, brackets and braces, respectively. - -If a data type is a Map or Map subtype, valid subkeys will be described -as well. - -Some fields are marked I. These are shown for historical -context and must not be produced in or consumed from any metadata structure -of version 2 or higher. - -=head2 REQUIRED FIELDS - -=head3 abstract - -Example: - - abstract => 'Build and install Perl modules' - -(Spec 1.2) [required] {String} - -This is a short description of the purpose of the distribution. - -=head3 author - -Example: - - author => [ 'Ken Williams ' ] - -(Spec 1.2) [required] {List of one or more Strings} - -This List indicates the person(s) to contact concerning the -distribution. The preferred form of the contact string is: - - contact-name - -This field provides a general contact list independent of other -structured fields provided within the L field, such as -C. The addressee(s) can be contacted for any purpose -including but not limited to (security) problems with the distribution, -questions about the distribution or bugs in the distribution. - -A distribution's original author is usually the contact listed within -this field. Co-maintainers, successor maintainers or mailing lists -devoted to the distribution may also be listed in addition to or instead -of the original author. - -=head3 dynamic_config - -Example: - - dynamic_config => 1 - -(Spec 2) [required] {Boolean} - -A boolean flag indicating whether a F or F (or -similar) must be executed to determine prerequisites. - -This field should be set to a true value if the distribution performs -some dynamic configuration (asking questions, sensing the environment, -etc.) as part of its configuration. This field should be set to a false -value to indicate that prerequisites included in metadata may be -considered final and valid for static analysis. - -Note: when this field is true, post-configuration prerequisites are not -guaranteed to bear any relation whatsoever to those stated in the metadata, -and relying on them doing so is an error. See also -L in the implementors' -notes. - -This field explicitly B indicate whether installation may be -safely performed without using a Makefile or Build file, as there may be -special files to install or custom installation targets (e.g. for -dual-life modules that exist on CPAN as well as in the Perl core). This -field only defines whether or not prerequisites are exactly as given in the -metadata. - -=head3 generated_by - -Example: - - generated_by => 'Module::Build version 0.36' - -(Spec 1.0) [required] {String} - -This field indicates the tool that was used to create this metadata. -There are no defined semantics for this field, but it is traditional to -use a string in the form "Generating::Package version 1.23" or the -author's name, if the file was generated by hand. - -=head3 license - -Example: - - license => [ 'perl_5' ] - - license => [ 'apache_2_0', 'mozilla_1_0' ] - -(Spec 2) [required] {List of one or more License Strings} - -One or more licenses that apply to some or all of the files in the -distribution. If multiple licenses are listed, the distribution -documentation should be consulted to clarify the interpretation of -multiple licenses. - -The following list of license strings are valid: - - string description - ------------- ----------------------------------------------- - agpl_3 GNU Affero General Public License, Version 3 - apache_1_1 Apache Software License, Version 1.1 - apache_2_0 Apache License, Version 2.0 - artistic_1 Artistic License, (Version 1) - artistic_2 Artistic License, Version 2.0 - bsd BSD License (three-clause) - freebsd FreeBSD License (two-clause) - gfdl_1_2 GNU Free Documentation License, Version 1.2 - gfdl_1_3 GNU Free Documentation License, Version 1.3 - gpl_1 GNU General Public License, Version 1 - gpl_2 GNU General Public License, Version 2 - gpl_3 GNU General Public License, Version 3 - lgpl_2_1 GNU Lesser General Public License, Version 2.1 - lgpl_3_0 GNU Lesser General Public License, Version 3.0 - mit MIT (aka X11) License - mozilla_1_0 Mozilla Public License, Version 1.0 - mozilla_1_1 Mozilla Public License, Version 1.1 - openssl OpenSSL License - perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later) - qpl_1_0 Q Public License, Version 1.0 - ssleay Original SSLeay License - sun Sun Internet Standards Source License (SISSL) - zlib zlib License - -The following license strings are also valid and indicate other -licensing not described above: - - string description - ------------- ----------------------------------------------- - open_source Other Open Source Initiative (OSI) approved license - restricted Requires special permission from copyright holder - unrestricted Not an OSI approved license, but not restricted - unknown License not provided in metadata - -All other strings are invalid in the license field. - -=head3 meta-spec - -Example: - - 'meta-spec' => { - version => '2', - url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', - } - -(Spec 1.2) [required] {Map} - -This field indicates the version of the CPAN Meta Spec that should be -used to interpret the metadata. Consumers must check this key as soon -as possible and abort further metadata processing if the meta-spec -version is not supported by the consumer. - -The following keys are valid, but only C is required. - -=over - -=item version - -This subkey gives the integer I of the CPAN Meta Spec against -which the document was generated. - -=item url - -This is a I of the metadata specification document corresponding to -the given version. This is strictly for human-consumption and should -not impact the interpretation of the document. - -For the version 2 spec, either of these are recommended: - -=over 4 - -=item * - -C - -=item * - -C - -=back - -=back - -=head3 name - -Example: - - name => 'Module-Build' - -(Spec 1.0) [required] {String} - -This field is the name of the distribution. This is often created by -taking the "main package" in the distribution and changing C<::> to -C<->, but the name may be completely unrelated to the packages within -the distribution. For example, L is distributed as part -of the distribution name "libwww-perl". - -=head3 release_status - -Example: - - release_status => 'stable' - -(Spec 2) [required] {String} - -This field provides the release status of this distribution. If the -C field contains an underscore character, then -C B be "stable." - -The C field B have one of the following values: - -=over - -=item stable - -This indicates an ordinary, "final" release that should be indexed by PAUSE -or other indexers. - -=item testing - -This indicates a "beta" release that is substantially complete, but has an -elevated risk of bugs and requires additional testing. The distribution -should not be installed over a stable release without an explicit request -or other confirmation from a user. This release status may also be used -for "release candidate" versions of a distribution. - -=item unstable - -This indicates an "alpha" release that is under active development, but has -been released for early feedback or testing and may be missing features or -may have serious bugs. The distribution should not be installed over a -stable release without an explicit request or other confirmation from a -user. - -=back - -Consumers B use this field to determine how to index the -distribution for CPAN or other repositories in addition to or in -replacement of heuristics based on version number or file name. - -=head3 version - -Example: - - version => '0.36' - -(Spec 1.0) [required] {Version} - -This field gives the version of the distribution to which the metadata -structure refers. - -=head2 OPTIONAL FIELDS - -=head3 description - -Example: - - description => "Module::Build is a system for " - . "building, testing, and installing Perl modules. " - . "It is meant to ... blah blah blah ...", - -(Spec 2) [optional] {String} - -A longer, more complete description of the purpose or intended use of -the distribution than the one provided by the C key. - -=head3 keywords - -Example: - - keywords => [ qw/ toolchain cpan dual-life / ] - -(Spec 1.1) [optional] {List of zero or more Strings} - -A List of keywords that describe this distribution. Keywords -B include whitespace. - -=head3 no_index - -Example: - - no_index => { - file => [ 'My/Module.pm' ], - directory => [ 'My/Private' ], - package => [ 'My::Module::Secret' ], - namespace => [ 'My::Module::Sample' ], - } - -(Spec 1.2) [optional] {Map} - -This Map describes any files, directories, packages, and namespaces that -are private to the packaging or implementation of the distribution and -should be ignored by indexing or search tools. Note that this is a list of -exclusions, and the spec does not define what to I - see -L in the implementors notes for more -information. - -Valid subkeys are as follows: - -=over - -=item file - -A I of relative paths to files. Paths B specified with -unix conventions. - -=item directory - -A I of relative paths to directories. Paths B specified -with unix conventions. - -[ Note: previous editions of the spec had C instead of C ] - -=item package - -A I of package names. - -=item namespace - -A I of package namespaces, where anything below the namespace -must be ignored, but I the namespace itself. - -In the example above for C, C would -be ignored, but C would not. - -=back - -=head3 optional_features - -Example: - - optional_features => { - sqlite => { - description => 'Provides SQLite support', - prereqs => { - runtime => { - requires => { - 'DBD::SQLite' => '1.25' - } - } - } - } - } - -(Spec 2) [optional] {Map} - -This Map describes optional features with incremental prerequisites. -Each key of the C Map is a String used to identify -the feature and each value is a Map with additional information about -the feature. Valid subkeys include: - -=over - -=item description - -This is a String describing the feature. Every optional feature -should provide a description - -=item prereqs - -This entry is required and has the same structure as that of the -C> key. It provides a list of package requirements -that must be satisfied for the feature to be supported or enabled. - -There is one crucial restriction: the prereqs of an optional feature -B include C phase prereqs. - -=back - -Consumers B include optional features as prerequisites without -explicit instruction from users (whether via interactive prompting, -a function parameter or a configuration value, etc. ). - -If an optional feature is used by a consumer to add additional -prerequisites, the consumer should merge the optional feature -prerequisites into those given by the C key using the same -semantics. See L for details on -merging prerequisites. - -I Because there is currently no way for a -distribution to specify a dependency on an optional feature of another -dependency, the use of C is discouraged. Instead, -create a separate, installable distribution that ensures the desired -feature is available. For example, if C has a C feature, -release a separate C distribution that satisfies -requirements for the feature. - -=head3 prereqs - -Example: - - prereqs => { - runtime => { - requires => { - 'perl' => '5.006', - 'File::Spec' => '0.86', - 'JSON' => '2.16', - }, - recommends => { - 'JSON::XS' => '2.26', - }, - suggests => { - 'Archive::Tar' => '0', - }, - }, - build => { - requires => { - 'Alien::SDL' => '1.00', - }, - }, - test => { - recommends => { - 'Test::Deep' => '0.10', - }, - } - } - -(Spec 2) [optional] {Map} - -This is a Map that describes all the prerequisites of the distribution. -The keys are phases of activity, such as C, C, C -or C. Values are Maps in which the keys name the type of -prerequisite relationship such as C, C, or -C and the value provides a set of prerequisite relations. The -set of relations B be specified as a Map of package names to -version ranges. - -The full definition for this field is given in the L -section. - -=head3 provides - -Example: - - provides => { - 'Foo::Bar' => { - file => 'lib/Foo/Bar.pm', - version => '0.27_02', - }, - 'Foo::Bar::Blah' => { - file => 'lib/Foo/Bar/Blah.pm', - }, - 'Foo::Bar::Baz' => { - file => 'lib/Foo/Bar/Baz.pm', - version => '0.3', - }, - } - -(Spec 1.2) [optional] {Map} - -This describes all packages provided by this distribution. This -information is used by distribution and automation mechanisms like -PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in -which distribution various packages can be found. - -The keys of C are package names that can be found within -the distribution. If a package name key is provided, it must -have a Map with the following valid subkeys: - -=over - -=item file - -This field is required. It must contain a Unix-style relative file path -from the root of the distribution directory to a file that contains or -generates the package. It may be given as C or C -to claim a package for indexing without needing a C<*.pm>. - -=item version - -If it exists, this field must contains a I String for the -package. If the package does not have a C<$VERSION>, this field must -be omitted. - -=back - -=head3 resources - -Example: - - resources => { - license => [ 'http://dev.perl.org/licenses/' ], - homepage => 'http://sourceforge.net/projects/module-build', - bugtracker => { - web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta', - mailto => 'meta-bugs@example.com', - }, - repository => { - url => 'git://github.com/dagolden/cpan-meta.git', - web => 'http://github.com/dagolden/cpan-meta', - type => 'git', - }, - x_twitter => 'http://twitter.com/cpan_linked/', - } - -(Spec 2) [optional] {Map} - -This field describes resources related to this distribution. - -Valid subkeys include: - -=over - -=item homepage - -The official home of this project on the web. - -=item license - -A List of I's that relate to this distribution's license. As with the -top-level C field, distribution documentation should be consulted -to clarify the interpretation of multiple licenses provided here. - -=item bugtracker - -This entry describes the bug tracking system for this distribution. It -is a Map with the following valid keys: - - web - a URL pointing to a web front-end for the bug tracker - mailto - an email address to which bugs can be sent - -=item repository - -This entry describes the source control repository for this distribution. It -is a Map with the following valid keys: - - url - a URL pointing to the repository itself - web - a URL pointing to a web front-end for the repository - type - a lowercase string indicating the VCS used - -Because a url like C is ambiguous as to -type, producers should provide a C whenever a C key is given. -The C field should be the name of the most common program used -to work with the repository, e.g. C, C, C, C, -C or C. - -=back - -=head2 DEPRECATED FIELDS - -=head3 build_requires - -I<(Deprecated in Spec 2)> [optional] {String} - -Replaced by C - -=head3 configure_requires - -I<(Deprecated in Spec 2)> [optional] {String} - -Replaced by C - -=head3 conflicts - -I<(Deprecated in Spec 2)> [optional] {String} - -Replaced by C - -=head3 distribution_type - -I<(Deprecated in Spec 2)> [optional] {String} - -This field indicated 'module' or 'script' but was considered -meaningless, since many distributions are hybrids of several kinds of -things. - -=head3 license_uri - -I<(Deprecated in Spec 1.2)> [optional] {URL} - -Replaced by C in C - -=head3 private - -I<(Deprecated in Spec 1.2)> [optional] {Map} - -This field has been renamed to L. - -=head3 recommends - -I<(Deprecated in Spec 2)> [optional] {String} - -Replaced by C - -=head3 requires - -I<(Deprecated in Spec 2)> [optional] {String} - -Replaced by C - -=head1 VERSION NUMBERS - -=head2 Version Formats - -This section defines the Version type, used by several fields in the -CPAN Meta Spec. - -Version numbers must be treated as strings, not numbers. For -example, C<1.200> B be serialized as C<1.2>. Version -comparison should be delegated to the Perl L module, version -0.80 or newer. - -Unless otherwise specified, version numbers B appear in one of two -formats: - -=over - -=item Decimal versions - -Decimal versions are regular "decimal numbers", with some limitations. -They B be non-negative and B begin and end with a digit. A -single underscore B be included, but B be between two digits. -They B use exponential notation ("1.23e-2"). - - version => '1.234' # OK - version => '1.23_04' # OK - - version => '1.23_04_05' # Illegal - version => '1.' # Illegal - version => '.1' # Illegal - -=item Dotted-integer versions - -Dotted-integer (also known as dotted-decimal) versions consist of -positive integers separated by full stop characters (i.e. "dots", -"periods" or "decimal points"). This are equivalent in format to Perl -"v-strings", with some additional restrictions on form. They must be -given in "normal" form, which has a leading "v" character and at least -three integer components. To retain a one-to-one mapping with decimal -versions, all components after the first B be restricted to the -range 0 to 999. The final component B be separated by an -underscore character instead of a period. - - version => 'v1.2.3' # OK - version => 'v1.2_3' # OK - version => 'v1.2.3.4' # OK - version => 'v1.2.3_4' # OK - version => 'v2009.10.31' # OK - - version => 'v1.2' # Illegal - version => '1.2.3' # Illegal - version => 'v1.2_3_4' # Illegal - version => 'v1.2009.10.31' # Not recommended - -=back - -=head2 Version Ranges - -Some fields (prereq, optional_features) indicate the particular -version(s) of some other module that may be required as a prerequisite. -This section details the Version Range type used to provide this -information. - -The simplest format for a Version Range is just the version -number itself, e.g. C<2.4>. This means that B version 2.4 -must be present. To indicate that B version of a prerequisite is -okay, even if the prerequisite doesn't define a version at all, use -the version C<0>. - -Alternatively, a version range B use the operators E (less than), -E= (less than or equal), E (greater than), E= (greater than -or equal), == (equal), and != (not equal). For example, the -specification C 2.0> means that any version of the prerequisite -less than 2.0 is suitable. - -For more complicated situations, version specifications B be AND-ed -together using commas. The specification C= 1.2, != 1.5, E -2.0> indicates a version that must be B 1.2, B 2.0, -and B 1.5. - -=head1 PREREQUISITES - -=head2 Prereq Spec - -The C key in the top-level metadata and within -C define the relationship between a distribution and -other packages. The prereq spec structure is a hierarchical data -structure which divides prerequisites into I of activity in the -installation process and I that indicate how -prerequisites should be resolved. - -For example, to specify that C is C during the -C phase, this entry would appear in the distribution metadata: - - prereqs => { - test => { - requires => { - 'Data::Dumper' => '2.00' - } - } - } - -=head3 Phases - -Requirements for regular use must be listed in the C phase. -Other requirements should be listed in the earliest stage in which they -are required and consumers must accumulate and satisfy requirements -across phases before executing the activity. For example, C -requirements must also be available during the C phase. - - before action requirements that must be met - ---------------- -------------------------------- - perl Build.PL configure - perl Makefile.PL - - make configure, runtime, build - Build - - make test configure, runtime, build, test - Build test - -Consumers that install the distribution must ensure that -I requirements are also installed and may install -dependencies from other phases. - - after action requirements that must be met - ---------------- -------------------------------- - make install runtime - Build install - -=over - -=item configure - -The configure phase occurs before any dynamic configuration has been -attempted. Libraries required by the configure phase B be -available for use before the distribution building tool has been -executed. - -=item build - -The build phase is when the distribution's source code is compiled (if -necessary) and otherwise made ready for installation. - -=item test - -The test phase is when the distribution's automated test suite is run. -Any library that is needed only for testing and not for subsequent use -should be listed here. - -=item runtime - -The runtime phase refers not only to when the distribution's contents -are installed, but also to its continued use. Any library that is a -prerequisite for regular use of this distribution should be indicated -here. - -=item develop - -The develop phase's prereqs are libraries needed to work on the -distribution's source code as its author does. These tools might be -needed to build a release tarball, to run author-only tests, or to -perform other tasks related to developing new versions of the -distribution. - -=back - -=head3 Relationships - -=over - -=item requires - -These dependencies B be installed for proper completion of the -phase. - -=item recommends - -Recommended dependencies are I encouraged and should be -satisfied except in resource constrained environments. - -=item suggests - -These dependencies are optional, but are suggested for enhanced operation -of the described distribution. - -=item conflicts - -These libraries cannot be installed when the phase is in operation. -This is a very rare situation, and the C relationship should -be used with great caution, or not at all. - -=back - -=head2 Merging and Resolving Prerequisites - -Whenever metadata consumers merge prerequisites, either from different -phases or from C, they should merged in a way which -preserves the intended semantics of the prerequisite structure. Generally, -this means concatenating the version specifications using commas, as -described in the L section. - -Another subtle error that can occur in resolving prerequisites comes from -the way that modules in prerequisites are indexed to distribution files on -CPAN. When a module is deleted from a distribution, prerequisites calling -for that module could indicate an older distribution should be installed, -potentially overwriting files from a newer distribution. - -For example, as of Oct 31, 2009, the CPAN index file contained these -module-distribution mappings: - - Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz - Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz - Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz - -Consider the case where "Class::MOP" 0.94 is installed. If a -distribution specified "Class::MOP::Class::Immutable" as a prerequisite, -it could result in Class-MOP-0.36.tar.gz being installed, overwriting -any files from Class-MOP-0.94.tar.gz. - -Consumers of metadata B test whether prerequisites would result -in installed module files being "downgraded" to an older version and -B warn users or ignore the prerequisite that would cause such a -result. - -=head1 SERIALIZATION - -Distribution metadata should be serialized (as a hashref) as -JSON-encoded data and packaged with distributions as the file -F. - -In the past, the distribution metadata structure had been packed with -distributions as F, a file in the YAML Tiny format (for which, -see L). Tools that consume distribution metadata from disk -should be capable of loading F, but should prefer F -if both are found. - -=head1 NOTES FOR IMPLEMENTORS - -=head2 Extracting Version Numbers from Perl Modules - -To get the version number from a Perl module, consumers should use the -C<< MM->parse_version($file) >> method provided by -L or L. For example, for the -module given by C<$mod>, the version may be retrieved in one of the -following ways: - - # via ExtUtils::MakeMaker - my $file = MM->_installed_file_for_module($mod); - my $version = MM->parse_version($file) - -The private C<_installed_file_for_module> method may be replaced with -other methods for locating a module in C<@INC>. - - # via Module::Metadata - my $info = Module::Metadata->new_from_module($mod); - my $version = $info->version; - -If only a filename is available, the following approach may be used: - - # via Module::Build - my $info = Module::Metadata->new_from_file($file); - my $version = $info->version; - -=head2 Comparing Version Numbers - -The L module provides the most reliable way to compare version -numbers in all the various ways they might be provided or might exist -within modules. Given two strings containing version numbers, C<$v1> and -C<$v2>, they should be converted to C objects before using -ordinary comparison operators. For example: - - use version; - if ( version->new($v1) <=> version->new($v2) ) { - print "Versions are not equal\n"; - } - -If the only comparison needed is whether an installed module is of a -sufficiently high version, a direct test may be done using the string -form of C and the C function. For example, for module C<$mod> -and version prerequisite C<$prereq>: - - if ( eval "use $mod $prereq (); 1" ) { - print "Module $mod version is OK.\n"; - } - -If the values of C<$mod> and C<$prereq> have not been scrubbed, however, -this presents security implications. - -=head2 Prerequisites for dynamically configured distributions - -When C is true, it is an error to presume that the -prerequisites given in distribution metadata will have any relationship -whatsoever to the actual prerequisites of the distribution. - -In practice, however, one can generally expect such prerequisites to be -one of two things: - -=over 4 - -=item * - -The minimum prerequisites for the distribution, to which dynamic configuration will only add items - -=item * - -Whatever the distribution configured with on the releaser's machine at release time - -=back - -The second case often turns out to have identical results to the first case, -albeit only by accident. - -As such, consumers may use this data for informational analysis, but -presenting it to the user as canonical or relying on it as such is -invariably the height of folly. - -=head2 Indexing distributions a la PAUSE - -While no_index tells you what must be ignored when indexing, this spec holds -no opinion on how you should get your initial candidate list of things to -possibly index. For "normal" distributions you might consider simply indexing -the contents of lib/, but there are many fascinating oddities on CPAN and -many dists from the days when it was normal to put the main .pm file in the -root of the distribution archive - so PAUSE currently indexes all .pm and .PL -files that are not either (a) specifically excluded by no_index (b) in -C, C, or C directories, or common 'mistake' directories such as -C. - -Or: If you're trying to be PAUSE-like, make sure you skip C, C and -C as well as anything marked as no_index. - -Also remember: If the META file contains a provides field, you shouldn't be -indexing anything in the first place - just use that. - -=head1 SEE ALSO - -=over 4 - -=item * - -CPAN, L - -=item * - -JSON, L - -=item * - -YAML, L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=item * - -L - -=back - -=head1 HISTORY - -Ken Williams wrote the original CPAN Meta Spec (also known as the -"META.yml spec") in 2003 and maintained it through several revisions -with input from various members of the community. In 2005, Randy -Sims redrafted it from HTML to POD for the version 1.2 release. Ken -continued to maintain the spec through version 1.4. - -In late 2009, David Golden organized the version 2 proposal review -process. David and Ricardo Signes drafted the final version 2 spec -in April 2010 based on the version 1.4 spec and patches contributed -during the proposal process. - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/CPAN-Meta/CPAN/Meta/Validator.pm b/bundled/CPAN-Meta/CPAN/Meta/Validator.pm deleted file mode 100644 index 8799f52..0000000 --- a/bundled/CPAN-Meta/CPAN/Meta/Validator.pm +++ /dev/null @@ -1,1206 +0,0 @@ -use 5.006; -use strict; -use warnings; -package CPAN::Meta::Validator; -# VERSION -$CPAN::Meta::Validator::VERSION = '2.143240'; -#pod =head1 SYNOPSIS -#pod -#pod my $struct = decode_json_file('META.json'); -#pod -#pod my $cmv = CPAN::Meta::Validator->new( $struct ); -#pod -#pod unless ( $cmv->is_valid ) { -#pod my $msg = "Invalid META structure. Errors found:\n"; -#pod $msg .= join( "\n", $cmv->errors ); -#pod die $msg; -#pod } -#pod -#pod =head1 DESCRIPTION -#pod -#pod This module validates a CPAN Meta structure against the version of the -#pod the specification claimed in the C field of the structure. -#pod -#pod =cut - -#--------------------------------------------------------------------------# -# This code copied and adapted from Test::CPAN::Meta -# by Barbie, for Miss Barbell Productions, -# L -#--------------------------------------------------------------------------# - -#--------------------------------------------------------------------------# -# Specification Definitions -#--------------------------------------------------------------------------# - -my %known_specs = ( - '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', - '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', - '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', - '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', - '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' -); -my %known_urls = map {$known_specs{$_} => $_} keys %known_specs; - -my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } }; - -my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } }; - -my $no_index_2 = { - 'map' => { file => { list => { value => \&string } }, - directory => { list => { value => \&string } }, - 'package' => { list => { value => \&string } }, - namespace => { list => { value => \&string } }, - ':key' => { name => \&custom_2, value => \&anything }, - } -}; - -my $no_index_1_3 = { - 'map' => { file => { list => { value => \&string } }, - directory => { list => { value => \&string } }, - 'package' => { list => { value => \&string } }, - namespace => { list => { value => \&string } }, - ':key' => { name => \&string, value => \&anything }, - } -}; - -my $no_index_1_2 = { - 'map' => { file => { list => { value => \&string } }, - dir => { list => { value => \&string } }, - 'package' => { list => { value => \&string } }, - namespace => { list => { value => \&string } }, - ':key' => { name => \&string, value => \&anything }, - } -}; - -my $no_index_1_1 = { - 'map' => { ':key' => { name => \&string, list => { value => \&string } }, - } -}; - -my $prereq_map = { - map => { - ':key' => { - name => \&phase, - 'map' => { - ':key' => { - name => \&relation, - %$module_map1, - }, - }, - } - }, -}; - -my %definitions = ( - '2' => { - # REQUIRED - 'abstract' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'dynamic_config' => { mandatory => 1, value => \&boolean }, - 'generated_by' => { mandatory => 1, value => \&string }, - 'license' => { mandatory => 1, list => { value => \&license } }, - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { value => \&url }, - ':key' => { name => \&custom_2, value => \&anything }, - } - }, - 'name' => { mandatory => 1, value => \&string }, - 'release_status' => { mandatory => 1, value => \&release_status }, - 'version' => { mandatory => 1, value => \&version }, - - # OPTIONAL - 'description' => { value => \&string }, - 'keywords' => { list => { value => \&string } }, - 'no_index' => $no_index_2, - 'optional_features' => { - 'map' => { - ':key' => { - name => \&string, - 'map' => { - description => { value => \&string }, - prereqs => $prereq_map, - ':key' => { name => \&custom_2, value => \&anything }, - } - } - } - }, - 'prereqs' => $prereq_map, - 'provides' => { - 'map' => { - ':key' => { - name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&custom_2, value => \&anything }, - } - } - } - }, - 'resources' => { - 'map' => { - license => { list => { value => \&url } }, - homepage => { value => \&url }, - bugtracker => { - 'map' => { - web => { value => \&url }, - mailto => { value => \&string}, - ':key' => { name => \&custom_2, value => \&anything }, - } - }, - repository => { - 'map' => { - web => { value => \&url }, - url => { value => \&url }, - type => { value => \&string }, - ':key' => { name => \&custom_2, value => \&anything }, - } - }, - ':key' => { value => \&string, name => \&custom_2 }, - } - }, - - # CUSTOM -- additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&custom_2, value => \&anything }, - }, - -'1.4' => { - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { mandatory => 1, value => \&urlspec }, - ':key' => { name => \&string, value => \&anything }, - }, - }, - - 'name' => { mandatory => 1, value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'abstract' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'license' => { mandatory => 1, value => \&license }, - 'generated_by' => { mandatory => 1, value => \&string }, - - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'configure_requires' => $module_map1, - 'conflicts' => $module_map2, - - 'optional_features' => { - 'map' => { - ':key' => { name => \&string, - 'map' => { description => { value => \&string }, - requires => $module_map1, - recommends => $module_map1, - build_requires => $module_map1, - conflicts => $module_map2, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'provides' => { - 'map' => { - ':key' => { name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'no_index' => $no_index_1_3, - 'private' => $no_index_1_3, - - 'keywords' => { list => { value => \&string } }, - - 'resources' => { - 'map' => { license => { value => \&url }, - homepage => { value => \&url }, - bugtracker => { value => \&url }, - repository => { value => \&url }, - ':key' => { value => \&string, name => \&custom_1 }, - } - }, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, -}, - -'1.3' => { - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { mandatory => 1, value => \&urlspec }, - ':key' => { name => \&string, value => \&anything }, - }, - }, - - 'name' => { mandatory => 1, value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'abstract' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'license' => { mandatory => 1, value => \&license }, - 'generated_by' => { mandatory => 1, value => \&string }, - - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - 'optional_features' => { - 'map' => { - ':key' => { name => \&string, - 'map' => { description => { value => \&string }, - requires => $module_map1, - recommends => $module_map1, - build_requires => $module_map1, - conflicts => $module_map2, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'provides' => { - 'map' => { - ':key' => { name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - - 'no_index' => $no_index_1_3, - 'private' => $no_index_1_3, - - 'keywords' => { list => { value => \&string } }, - - 'resources' => { - 'map' => { license => { value => \&url }, - homepage => { value => \&url }, - bugtracker => { value => \&url }, - repository => { value => \&url }, - ':key' => { value => \&string, name => \&custom_1 }, - } - }, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, -}, - -# v1.2 is misleading, it seems to assume that a number of fields where created -# within v1.1, when they were created within v1.2. This may have been an -# original mistake, and that a v1.1 was retro fitted into the timeline, when -# v1.2 was originally slated as v1.1. But I could be wrong ;) -'1.2' => { - 'meta-spec' => { - mandatory => 1, - 'map' => { - version => { mandatory => 1, value => \&version}, - url => { mandatory => 1, value => \&urlspec }, - ':key' => { name => \&string, value => \&anything }, - }, - }, - - - 'name' => { mandatory => 1, value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'license' => { mandatory => 1, value => \&license }, - 'generated_by' => { mandatory => 1, value => \&string }, - 'author' => { mandatory => 1, list => { value => \&string } }, - 'abstract' => { mandatory => 1, value => \&string }, - - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'keywords' => { list => { value => \&string } }, - - 'private' => $no_index_1_2, - '$no_index' => $no_index_1_2, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - 'optional_features' => { - 'map' => { - ':key' => { name => \&string, - 'map' => { description => { value => \&string }, - requires => $module_map1, - recommends => $module_map1, - build_requires => $module_map1, - conflicts => $module_map2, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'provides' => { - 'map' => { - ':key' => { name => \&module, - 'map' => { - file => { mandatory => 1, value => \&file }, - version => { value => \&version }, - ':key' => { name => \&string, value => \&anything }, - } - } - } - }, - - 'resources' => { - 'map' => { license => { value => \&url }, - homepage => { value => \&url }, - bugtracker => { value => \&url }, - repository => { value => \&url }, - ':key' => { value => \&string, name => \&custom_1 }, - } - }, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, -}, - -# note that the 1.1 spec only specifies 'version' as mandatory -'1.1' => { - 'name' => { value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'license' => { value => \&license }, - 'generated_by' => { value => \&string }, - - 'license_uri' => { value => \&url }, - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'private' => $no_index_1_1, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, -}, - -# note that the 1.0 spec doesn't specify optional or mandatory fields -# but we will treat version as mandatory since otherwise META 1.0 is -# completely arbitrary and pointless -'1.0' => { - 'name' => { value => \&string }, - 'version' => { mandatory => 1, value => \&version }, - 'license' => { value => \&license }, - 'generated_by' => { value => \&string }, - - 'license_uri' => { value => \&url }, - 'distribution_type' => { value => \&string }, - 'dynamic_config' => { value => \&boolean }, - - 'requires' => $module_map1, - 'recommends' => $module_map1, - 'build_requires' => $module_map1, - 'conflicts' => $module_map2, - - # additional user defined key/value pairs - # note we can only validate the key name, as the structure is user defined - ':key' => { name => \&string, value => \&anything }, -}, -); - -#--------------------------------------------------------------------------# -# Code -#--------------------------------------------------------------------------# - -#pod =method new -#pod -#pod my $cmv = CPAN::Meta::Validator->new( $struct ) -#pod -#pod The constructor must be passed a metadata structure. -#pod -#pod =cut - -sub new { - my ($class,$data) = @_; - - # create an attributes hash - my $self = { - 'data' => $data, - 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0", - 'errors' => undef, - }; - - # create the object - return bless $self, $class; -} - -#pod =method is_valid -#pod -#pod if ( $cmv->is_valid ) { -#pod ... -#pod } -#pod -#pod Returns a boolean value indicating whether the metadata provided -#pod is valid. -#pod -#pod =cut - -sub is_valid { - my $self = shift; - my $data = $self->{data}; - my $spec_version = $self->{spec}; - $self->check_map($definitions{$spec_version},$data); - return ! $self->errors; -} - -#pod =method errors -#pod -#pod warn( join "\n", $cmv->errors ); -#pod -#pod Returns a list of errors seen during validation. -#pod -#pod =cut - -sub errors { - my $self = shift; - return () unless(defined $self->{errors}); - return @{$self->{errors}}; -} - -#pod =begin :internals -#pod -#pod =head2 Check Methods -#pod -#pod =over -#pod -#pod =item * -#pod -#pod check_map($spec,$data) -#pod -#pod Checks whether a map (or hash) part of the data structure conforms to the -#pod appropriate specification definition. -#pod -#pod =item * -#pod -#pod check_list($spec,$data) -#pod -#pod Checks whether a list (or array) part of the data structure conforms to -#pod the appropriate specification definition. -#pod -#pod =item * -#pod -#pod =back -#pod -#pod =cut - -my $spec_error = "Missing validation action in specification. " - . "Must be one of 'map', 'list', or 'value'"; - -sub check_map { - my ($self,$spec,$data) = @_; - - if(ref($spec) ne 'HASH') { - $self->_error( "Unknown META specification, cannot validate." ); - return; - } - - if(ref($data) ne 'HASH') { - $self->_error( "Expected a map structure from string or file." ); - return; - } - - for my $key (keys %$spec) { - next unless($spec->{$key}->{mandatory}); - next if(defined $data->{$key}); - push @{$self->{stack}}, $key; - $self->_error( "Missing mandatory field, '$key'" ); - pop @{$self->{stack}}; - } - - for my $key (keys %$data) { - push @{$self->{stack}}, $key; - if($spec->{$key}) { - if($spec->{$key}{value}) { - $spec->{$key}{value}->($self,$key,$data->{$key}); - } elsif($spec->{$key}{'map'}) { - $self->check_map($spec->{$key}{'map'},$data->{$key}); - } elsif($spec->{$key}{'list'}) { - $self->check_list($spec->{$key}{'list'},$data->{$key}); - } else { - $self->_error( "$spec_error for '$key'" ); - } - - } elsif ($spec->{':key'}) { - $spec->{':key'}{name}->($self,$key,$key); - if($spec->{':key'}{value}) { - $spec->{':key'}{value}->($self,$key,$data->{$key}); - } elsif($spec->{':key'}{'map'}) { - $self->check_map($spec->{':key'}{'map'},$data->{$key}); - } elsif($spec->{':key'}{'list'}) { - $self->check_list($spec->{':key'}{'list'},$data->{$key}); - } else { - $self->_error( "$spec_error for ':key'" ); - } - - - } else { - $self->_error( "Unknown key, '$key', found in map structure" ); - } - pop @{$self->{stack}}; - } -} - -sub check_list { - my ($self,$spec,$data) = @_; - - if(ref($data) ne 'ARRAY') { - $self->_error( "Expected a list structure" ); - return; - } - - if(defined $spec->{mandatory}) { - if(!defined $data->[0]) { - $self->_error( "Missing entries from mandatory list" ); - } - } - - for my $value (@$data) { - push @{$self->{stack}}, $value || ""; - if(defined $spec->{value}) { - $spec->{value}->($self,'list',$value); - } elsif(defined $spec->{'map'}) { - $self->check_map($spec->{'map'},$value); - } elsif(defined $spec->{'list'}) { - $self->check_list($spec->{'list'},$value); - } elsif ($spec->{':key'}) { - $self->check_map($spec,$value); - } else { - $self->_error( "$spec_error associated with '$self->{stack}[-2]'" ); - } - pop @{$self->{stack}}; - } -} - -#pod =head2 Validator Methods -#pod -#pod =over -#pod -#pod =item * -#pod -#pod header($self,$key,$value) -#pod -#pod Validates that the header is valid. -#pod -#pod Note: No longer used as we now read the data structure, not the file. -#pod -#pod =item * -#pod -#pod url($self,$key,$value) -#pod -#pod Validates that a given value is in an acceptable URL format -#pod -#pod =item * -#pod -#pod urlspec($self,$key,$value) -#pod -#pod Validates that the URL to a META specification is a known one. -#pod -#pod =item * -#pod -#pod string_or_undef($self,$key,$value) -#pod -#pod Validates that the value is either a string or an undef value. Bit of a -#pod catchall function for parts of the data structure that are completely user -#pod defined. -#pod -#pod =item * -#pod -#pod string($self,$key,$value) -#pod -#pod Validates that a string exists for the given key. -#pod -#pod =item * -#pod -#pod file($self,$key,$value) -#pod -#pod Validate that a file is passed for the given key. This may be made more -#pod thorough in the future. For now it acts like \&string. -#pod -#pod =item * -#pod -#pod exversion($self,$key,$value) -#pod -#pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. -#pod -#pod =item * -#pod -#pod version($self,$key,$value) -#pod -#pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00' -#pod are both valid. A leading 'v' like 'v1.2.3' is also valid. -#pod -#pod =item * -#pod -#pod boolean($self,$key,$value) -#pod -#pod Validates for a boolean value. Currently these values are '1', '0', 'true', -#pod 'false', however the latter 2 may be removed. -#pod -#pod =item * -#pod -#pod license($self,$key,$value) -#pod -#pod Validates that a value is given for the license. Returns 1 if an known license -#pod type, or 2 if a value is given but the license type is not a recommended one. -#pod -#pod =item * -#pod -#pod custom_1($self,$key,$value) -#pod -#pod Validates that the given key is in CamelCase, to indicate a user defined -#pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X -#pod of the spec, this was only explicitly stated for 'resources'. -#pod -#pod =item * -#pod -#pod custom_2($self,$key,$value) -#pod -#pod Validates that the given key begins with 'x_' or 'X_', to indicate a user -#pod defined keyword and only has characters in the class [-_a-zA-Z] -#pod -#pod =item * -#pod -#pod identifier($self,$key,$value) -#pod -#pod Validates that key is in an acceptable format for the META specification, -#pod for an identifier, i.e. any that matches the regular expression -#pod qr/[a-z][a-z_]/i. -#pod -#pod =item * -#pod -#pod module($self,$key,$value) -#pod -#pod Validates that a given key is in an acceptable module name format, e.g. -#pod 'Test::CPAN::Meta::Version'. -#pod -#pod =back -#pod -#pod =end :internals -#pod -#pod =cut - -sub header { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value && $value =~ /^--- #YAML:1.0/); - } - $self->_error( "file does not have a valid YAML header." ); - return 0; -} - -sub release_status { - my ($self,$key,$value) = @_; - if(defined $value) { - my $version = $self->{data}{version} || ''; - if ( $version =~ /_/ ) { - return 1 if ( $value =~ /\A(?:testing|unstable)\z/ ); - $self->_error( "'$value' for '$key' is invalid for version '$version'" ); - } - else { - return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ ); - $self->_error( "'$value' for '$key' is invalid" ); - } - } - else { - $self->_error( "'$key' is not defined" ); - } - return 0; -} - -# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003 -sub _uri_split { - return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; -} - -sub url { - my ($self,$key,$value) = @_; - if(defined $value) { - my ($scheme, $auth, $path, $query, $frag) = _uri_split($value); - unless ( defined $scheme && length $scheme ) { - $self->_error( "'$value' for '$key' does not have a URL scheme" ); - return 0; - } - unless ( defined $auth && length $auth ) { - $self->_error( "'$value' for '$key' does not have a URL authority" ); - return 0; - } - return 1; - } - $value ||= ''; - $self->_error( "'$value' for '$key' is not a valid URL." ); - return 0; -} - -sub urlspec { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value && $known_specs{$self->{spec}} eq $value); - if($value && $known_urls{$value}) { - $self->_error( 'META specification URL does not match version' ); - return 0; - } - } - $self->_error( 'Unknown META specification' ); - return 0; -} - -sub anything { return 1 } - -sub string { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value || $value =~ /^0$/); - } - $self->_error( "value is an undefined string" ); - return 0; -} - -sub string_or_undef { - my ($self,$key,$value) = @_; - return 1 unless(defined $value); - return 1 if($value || $value =~ /^0$/); - $self->_error( "No string defined for '$key'" ); - return 0; -} - -sub file { - my ($self,$key,$value) = @_; - return 1 if(defined $value); - $self->_error( "No file defined for '$key'" ); - return 0; -} - -sub exversion { - my ($self,$key,$value) = @_; - if(defined $value && ($value || $value =~ /0/)) { - my $pass = 1; - for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); } - return $pass; - } - $value = '' unless(defined $value); - $self->_error( "'$value' for '$key' is not a valid version." ); - return 0; -} - -sub version { - my ($self,$key,$value) = @_; - if(defined $value) { - return 0 unless($value || $value =~ /0/); - return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/); - } else { - $value = ''; - } - $self->_error( "'$value' for '$key' is not a valid version." ); - return 0; -} - -sub boolean { - my ($self,$key,$value) = @_; - if(defined $value) { - return 1 if($value =~ /^(0|1|true|false)$/); - } else { - $value = ''; - } - $self->_error( "'$value' for '$key' is not a boolean value." ); - return 0; -} - -my %v1_licenses = ( - 'perl' => 'http://dev.perl.org/licenses/', - 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', - 'apache' => 'http://apache.org/licenses/LICENSE-2.0', - 'artistic' => 'http://opensource.org/licenses/artistic-license.php', - 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', - 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php', - 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', - 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', - 'mit' => 'http://opensource.org/licenses/mit-license.php', - 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php', - 'open_source' => undef, - 'unrestricted' => undef, - 'restrictive' => undef, - 'unknown' => undef, -); - -my %v2_licenses = map { $_ => 1 } qw( - agpl_3 - apache_1_1 - apache_2_0 - artistic_1 - artistic_2 - bsd - freebsd - gfdl_1_2 - gfdl_1_3 - gpl_1 - gpl_2 - gpl_3 - lgpl_2_1 - lgpl_3_0 - mit - mozilla_1_0 - mozilla_1_1 - openssl - perl_5 - qpl_1_0 - ssleay - sun - zlib - open_source - restricted - unrestricted - unknown -); - -sub license { - my ($self,$key,$value) = @_; - my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses; - if(defined $value) { - return 1 if($value && exists $licenses->{$value}); - } else { - $value = ''; - } - $self->_error( "License '$value' is invalid" ); - return 0; -} - -sub custom_1 { - my ($self,$key) = @_; - if(defined $key) { - # a valid user defined key should be alphabetic - # and contain at least one capital case letter. - return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/); - } else { - $key = ''; - } - $self->_error( "Custom resource '$key' must be in CamelCase." ); - return 0; -} - -sub custom_2 { - my ($self,$key) = @_; - if(defined $key) { - return 1 if($key && $key =~ /^x_/i); # user defined - } else { - $key = ''; - } - $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." ); - return 0; -} - -sub identifier { - my ($self,$key) = @_; - if(defined $key) { - return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined - } else { - $key = ''; - } - $self->_error( "Key '$key' is not a legal identifier." ); - return 0; -} - -sub module { - my ($self,$key) = @_; - if(defined $key) { - return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/); - } else { - $key = ''; - } - $self->_error( "Key '$key' is not a legal module name." ); - return 0; -} - -my @valid_phases = qw/ configure build test runtime develop /; -sub phase { - my ($self,$key) = @_; - if(defined $key) { - return 1 if( length $key && grep { $key eq $_ } @valid_phases ); - return 1 if $key =~ /x_/i; - } else { - $key = ''; - } - $self->_error( "Key '$key' is not a legal phase." ); - return 0; -} - -my @valid_relations = qw/ requires recommends suggests conflicts /; -sub relation { - my ($self,$key) = @_; - if(defined $key) { - return 1 if( length $key && grep { $key eq $_ } @valid_relations ); - return 1 if $key =~ /x_/i; - } else { - $key = ''; - } - $self->_error( "Key '$key' is not a legal prereq relationship." ); - return 0; -} - -sub _error { - my $self = shift; - my $mess = shift; - - $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack}); - $mess .= " [Validation: $self->{spec}]"; - - push @{$self->{errors}}, $mess; -} - -1; - -# ABSTRACT: validate CPAN distribution metadata structures - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -CPAN::Meta::Validator - validate CPAN distribution metadata structures - -=head1 VERSION - -version 2.143240 - -=head1 SYNOPSIS - - my $struct = decode_json_file('META.json'); - - my $cmv = CPAN::Meta::Validator->new( $struct ); - - unless ( $cmv->is_valid ) { - my $msg = "Invalid META structure. Errors found:\n"; - $msg .= join( "\n", $cmv->errors ); - die $msg; - } - -=head1 DESCRIPTION - -This module validates a CPAN Meta structure against the version of the -the specification claimed in the C field of the structure. - -=head1 METHODS - -=head2 new - - my $cmv = CPAN::Meta::Validator->new( $struct ) - -The constructor must be passed a metadata structure. - -=head2 is_valid - - if ( $cmv->is_valid ) { - ... - } - -Returns a boolean value indicating whether the metadata provided -is valid. - -=head2 errors - - warn( join "\n", $cmv->errors ); - -Returns a list of errors seen during validation. - -=begin :internals - -=head2 Check Methods - -=over - -=item * - -check_map($spec,$data) - -Checks whether a map (or hash) part of the data structure conforms to the -appropriate specification definition. - -=item * - -check_list($spec,$data) - -Checks whether a list (or array) part of the data structure conforms to -the appropriate specification definition. - -=item * - -=back - -=head2 Validator Methods - -=over - -=item * - -header($self,$key,$value) - -Validates that the header is valid. - -Note: No longer used as we now read the data structure, not the file. - -=item * - -url($self,$key,$value) - -Validates that a given value is in an acceptable URL format - -=item * - -urlspec($self,$key,$value) - -Validates that the URL to a META specification is a known one. - -=item * - -string_or_undef($self,$key,$value) - -Validates that the value is either a string or an undef value. Bit of a -catchall function for parts of the data structure that are completely user -defined. - -=item * - -string($self,$key,$value) - -Validates that a string exists for the given key. - -=item * - -file($self,$key,$value) - -Validate that a file is passed for the given key. This may be made more -thorough in the future. For now it acts like \&string. - -=item * - -exversion($self,$key,$value) - -Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. - -=item * - -version($self,$key,$value) - -Validates a single version string. Versions of the type '5.8.8' and '0.00_00' -are both valid. A leading 'v' like 'v1.2.3' is also valid. - -=item * - -boolean($self,$key,$value) - -Validates for a boolean value. Currently these values are '1', '0', 'true', -'false', however the latter 2 may be removed. - -=item * - -license($self,$key,$value) - -Validates that a value is given for the license. Returns 1 if an known license -type, or 2 if a value is given but the license type is not a recommended one. - -=item * - -custom_1($self,$key,$value) - -Validates that the given key is in CamelCase, to indicate a user defined -keyword and only has characters in the class [-_a-zA-Z]. In version 1.X -of the spec, this was only explicitly stated for 'resources'. - -=item * - -custom_2($self,$key,$value) - -Validates that the given key begins with 'x_' or 'X_', to indicate a user -defined keyword and only has characters in the class [-_a-zA-Z] - -=item * - -identifier($self,$key,$value) - -Validates that key is in an acceptable format for the META specification, -for an identifier, i.e. any that matches the regular expression -qr/[a-z][a-z_]/i. - -=item * - -module($self,$key,$value) - -Validates that a given key is in an acceptable module name format, e.g. -'Test::CPAN::Meta::Version'. - -=back - -=end :internals - -=for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file -identifier license module phase relation release_status string string_or_undef -url urlspec version header check_map - -=head1 BUGS - -Please report any bugs or feature using the CPAN Request Tracker. -Bugs can be submitted through the web interface at -L - -When submitting a bug or request, please include a test-file or a patch to an -existing test-file that illustrates the bug or desired feature. - -=head1 AUTHORS - -=over 4 - -=item * - -David Golden - -=item * - -Ricardo Signes - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2010 by David Golden and Ricardo Signes. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/ExtUtils-Install/ExtUtils/Install.pm b/bundled/ExtUtils-Install/ExtUtils/Install.pm deleted file mode 100644 index 202a1cc..0000000 --- a/bundled/ExtUtils-Install/ExtUtils/Install.pm +++ /dev/null @@ -1,1356 +0,0 @@ -package ExtUtils::Install; -use strict; - -use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config); - -use AutoSplit; -use Carp (); -use Config qw(%Config); -use Cwd qw(cwd); -use Exporter; -use ExtUtils::Packlist; -use File::Basename qw(dirname); -use File::Compare qw(compare); -use File::Copy; -use File::Find qw(find); -use File::Path; -use File::Spec; - - -@ISA = ('Exporter'); -@EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); - -=pod - -=head1 NAME - -ExtUtils::Install - install files from here to there - -=head1 SYNOPSIS - - use ExtUtils::Install; - - install({ 'blib/lib' => 'some/install/dir' } ); - - uninstall($packlist); - - pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' }); - -=head1 VERSION - -2.06 - -=cut - -$VERSION = '2.06'; # <-- do not forget to update the POD section just above this line! -$VERSION = eval $VERSION; - -=pod - -=head1 DESCRIPTION - -Handles the installing and uninstalling of perl modules, scripts, man -pages, etc... - -Both install() and uninstall() are specific to the way -ExtUtils::MakeMaker handles the installation and deinstallation of -perl modules. They are not designed as general purpose tools. - -On some operating systems such as Win32 installation may not be possible -until after a reboot has occurred. This can have varying consequences: -removing an old DLL does not impact programs using the new one, but if -a new DLL cannot be installed properly until reboot then anything -depending on it must wait. The package variable - - $ExtUtils::Install::MUST_REBOOT - -is used to store this status. - -If this variable is true then such an operation has occurred and -anything depending on this module cannot proceed until a reboot -has occurred. - -If this value is defined but false then such an operation has -ocurred, but should not impact later operations. - -=over - -=begin _private - -=item _chmod($$;$) - -Wrapper to chmod() for debugging and error trapping. - -=item _warnonce(@) - -Warns about something only once. - -=item _choke(@) - -Dies with a special message. - -=back - -=end _private - -=cut - -my $Is_VMS = $^O eq 'VMS'; -my $Is_MacPerl = $^O eq 'MacOS'; -my $Is_Win32 = $^O eq 'MSWin32'; -my $Is_cygwin = $^O eq 'cygwin'; -my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin); - - -my $Inc_uninstall_warn_handler; - -# install relative to here - -my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; -my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET}; - -my $Curdir = File::Spec->curdir; -my $Updir = File::Spec->updir; - -sub _estr(@) { - return join "\n",'!' x 72,@_,'!' x 72,''; -} - -{my %warned; -sub _warnonce(@) { - my $first=shift; - my $msg=_estr "WARNING: $first",@_; - warn $msg unless $warned{$msg}++; -}} - -sub _choke(@) { - my $first=shift; - my $msg=_estr "ERROR: $first",@_; - Carp::croak($msg); -} - - -sub _chmod($$;$) { - my ( $mode, $item, $verbose )=@_; - $verbose ||= 0; - if (chmod $mode, $item) { - printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1; - } else { - my $err="$!"; - _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n", - $mode, $item, $err - if -e $item; - } -} - -=begin _private - -=over - -=item _move_file_at_boot( $file, $target, $moan ) - -OS-Specific, Win32/Cygwin - -Schedules a file to be moved/renamed/deleted at next boot. -$file should be a filespec of an existing file -$target should be a ref to an array if the file is to be deleted -otherwise it should be a filespec for a rename. If the file is existing -it will be replaced. - -Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred -and sets it to 1 to indicate that a move operation has been requested. - -returns 1 on success, on failure if $moan is false errors are fatal. -If $moan is true then returns 0 on error and warns instead of dies. - -=end _private - -=cut - -{ - my $Has_Win32API_File; - sub _move_file_at_boot { #XXX OS-SPECIFIC - my ( $file, $target, $moan )= @_; - Carp::confess("Panic: Can't _move_file_at_boot on this platform!") - unless $CanMoveAtBoot; - - my $descr= ref $target - ? "'$file' for deletion" - : "'$file' for installation as '$target'"; - - # *note* CanMoveAtBoot is only incidentally the same condition as below - # this needs not hold true in the future. - $Has_Win32API_File = ($Is_Win32 || $Is_cygwin) - ? (eval {require Win32API::File; 1} || 0) - : 0 unless defined $Has_Win32API_File; - if ( ! $Has_Win32API_File ) { - - my @msg=( - "Cannot schedule $descr at reboot.", - "Try installing Win32API::File to allow operations on locked files", - "to be scheduled during reboot. Or try to perform the operation by", - "hand yourself. (You may need to close other perl processes first)" - ); - if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } - return 0; - } - my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT(); - $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING() - unless ref $target; - - _chmod( 0666, $file ); - _chmod( 0666, $target ) unless ref $target; - - if (Win32API::File::MoveFileEx( $file, $target, $opts )) { - $MUST_REBOOT ||= ref $target ? 0 : 1; - return 1; - } else { - my @msg=( - "MoveFileEx $descr at reboot failed: $^E", - "You may try to perform the operation by hand yourself. ", - "(You may need to close other perl processes first).", - ); - if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } - } - return 0; - } -} - - -=begin _private - - -=item _unlink_or_rename( $file, $tryhard, $installing ) - -OS-Specific, Win32/Cygwin - -Tries to get a file out of the way by unlinking it or renaming it. On -some OS'es (Win32 based) DLL files can end up locked such that they can -be renamed but not deleted. Likewise sometimes a file can be locked such -that it cant even be renamed or changed except at reboot. To handle -these cases this routine finds a tempfile name that it can either rename -the file out of the way or use as a proxy for the install so that the -rename can happen later (at reboot). - - $file : the file to remove. - $tryhard : should advanced tricks be used for deletion - $installing : we are not merely deleting but we want to overwrite - -When $tryhard is not true if the unlink fails its fatal. When $tryhard -is true then the file is attempted to be renamed. The renamed file is -then scheduled for deletion. If the rename fails then $installing -governs what happens. If it is false the failure is fatal. If it is true -then an attempt is made to schedule installation at boot using a -temporary file to hold the new file. If this fails then a fatal error is -thrown, if it succeeds it returns the temporary file name (which will be -a derivative of the original in the same directory) so that the caller can -use it to install under. In all other cases of success returns $file. -On failure throws a fatal error. - -=end _private - -=cut - - - -sub _unlink_or_rename { #XXX OS-SPECIFIC - my ( $file, $tryhard, $installing )= @_; - - # this chmod was originally unconditional. However, its not needed on - # POSIXy systems since permission to unlink a file is specified by the - # directory rather than the file; and in fact it screwed up hard- and - # symlinked files. Keep it for other platforms in case its still - # needed there. - if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) { - _chmod( 0666, $file ); - } - my $unlink_count = 0; - while (unlink $file) { $unlink_count++; } - return $file if $unlink_count > 0; - my $error="$!"; - - _choke("Cannot unlink '$file': $!") - unless $CanMoveAtBoot && $tryhard; - - my $tmp= "AAA"; - ++$tmp while -e "$file.$tmp"; - $tmp= "$file.$tmp"; - - warn "WARNING: Unable to unlink '$file': $error\n", - "Going to try to rename it to '$tmp'.\n"; - - if ( rename $file, $tmp ) { - warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n"; - # when $installing we can set $moan to true. - # IOW, if we cant delete the renamed file at reboot its - # not the end of the world. The other cases are more serious - # and need to be fatal. - _move_file_at_boot( $tmp, [], $installing ); - return $file; - } elsif ( $installing ) { - _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor". - " installation as '$file' at reboot.\n"); - _move_file_at_boot( $tmp, $file ); - return $tmp; - } else { - _choke("Rename failed:$!", "Cannot proceed."); - } - -} - - -=pod - -=back - -=head2 Functions - -=begin _private - -=over - -=item _get_install_skip - -Handles loading the INSTALL.SKIP file. Returns an array of patterns to use. - -=cut - - - -sub _get_install_skip { - my ( $skip, $verbose )= @_; - if ($ENV{EU_INSTALL_IGNORE_SKIP}) { - print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n" - if $verbose>2; - return []; - } - if ( ! defined $skip ) { - print "Looking for install skip list\n" - if $verbose>2; - for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) { - next unless $file; - print "\tChecking for $file\n" - if $verbose>2; - if (-e $file) { - $skip= $file; - last; - } - } - } - if ($skip && !ref $skip) { - print "Reading skip patterns from '$skip'.\n" - if $verbose; - if (open my $fh,$skip ) { - my @patterns; - while (<$fh>) { - chomp; - next if /^\s*(?:#|$)/; - print "\tSkip pattern: $_\n" if $verbose>3; - push @patterns, $_; - } - $skip= \@patterns; - } else { - warn "Can't read skip file:'$skip':$!\n"; - $skip=[]; - } - } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) { - print "Using array for skip list\n" - if $verbose>2; - } elsif ($verbose) { - print "No skip list found.\n" - if $verbose>1; - $skip= []; - } - warn "Got @{[0+@$skip]} skip patterns.\n" - if $verbose>3; - return $skip -} - -=pod - -=item _have_write_access - -Abstract a -w check that tries to use POSIX::access() if possible. - -=cut - -{ - my $has_posix; - sub _have_write_access { - my $dir=shift; - unless (defined $has_posix) { - $has_posix= (!$Is_cygwin && !$Is_Win32 - && eval 'local $^W; require POSIX; 1') || 0; - } - if ($has_posix) { - return POSIX::access($dir, POSIX::W_OK()); - } else { - return -w $dir; - } - } -} - -=pod - -=item _can_write_dir(C<$dir>) - -Checks whether a given directory is writable, taking account -the possibility that the directory might not exist and would have to -be created first. - -Returns a list, containing: C<($writable, $determined_by, @create)> - -C<$writable> says whether the directory is (hypothetically) writable - -C<$determined_by> is the directory the status was determined from. It will be -either the C<$dir>, or one of its parents. - -C<@create> is a list of directories that would probably have to be created -to make the requested directory. It may not actually be correct on -relative paths with C<..> in them. But for our purposes it should work ok - -=cut - - -sub _can_write_dir { - my $dir=shift; - return - unless defined $dir and length $dir; - - my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1); - my @dirs = File::Spec->splitdir($dirs); - unshift @dirs, File::Spec->curdir - unless File::Spec->file_name_is_absolute($dir); - - my $path=''; - my @make; - while (@dirs) { - if ($Is_VMS) { - $dir = File::Spec->catdir($vol,@dirs); - } - else { - $dir = File::Spec->catdir(@dirs); - $dir = File::Spec->catpath($vol,$dir,'') - if defined $vol and length $vol; - } - next if ( $dir eq $path ); - if ( ! -e $dir ) { - unshift @make,$dir; - next; - } - if ( _have_write_access($dir) ) { - return 1,$dir,@make - } else { - return 0,$dir,@make - } - } continue { - pop @dirs; - } - return 0; -} - -=pod - -=item _mkpath($dir,$show,$mode,$verbose,$dry_run) - -Wrapper around File::Path::mkpath() to handle errors. - -If $verbose is true and >1 then additional diagnostics will be produced, also -this will force $show to true. - -If $dry_run is true then the directory will not be created but a check will be -made to see whether it would be possible to write to the directory, or that -it would be possible to create the directory. - -If $dry_run is not true dies if the directory can not be created or is not -writable. - -=cut - -sub _mkpath { - my ($dir,$show,$mode,$verbose,$dry_run)=@_; - if ( $verbose && $verbose > 1 && ! -d $dir) { - $show= 1; - printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode; - } - if (!$dry_run) { - if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) { - _choke("Can't create '$dir'","$@"); - } - - } - my ($can,$root,@make)=_can_write_dir($dir); - if (!$can) { - my @msg=( - "Can't create '$dir'", - $root ? "Do not have write permissions on '$root'" - : "Unknown Error" - ); - if ($dry_run) { - _warnonce @msg; - } else { - _choke @msg; - } - } elsif ($show and $dry_run) { - print "$_\n" for @make; - } - -} - -=pod - -=item _copy($from,$to,$verbose,$dry_run) - -Wrapper around File::Copy::copy to handle errors. - -If $verbose is true and >1 then additional diagnostics will be emitted. - -If $dry_run is true then the copy will not actually occur. - -Dies if the copy fails. - -=cut - - -sub _copy { - my ( $from, $to, $verbose, $dry_run)=@_; - if ($verbose && $verbose>1) { - printf "copy(%s,%s)\n", $from, $to; - } - if (!$dry_run) { - File::Copy::copy($from,$to) - or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" ); - } -} - -=pod - -=item _chdir($from) - -Wrapper around chdir to catch errors. - -If not called in void context returns the cwd from before the chdir. - -dies on error. - -=cut - -sub _chdir { - my ($dir)= @_; - my $ret; - if (defined wantarray) { - $ret= cwd; - } - chdir $dir - or _choke("Couldn't chdir to '$dir': $!"); - return $ret; -} - -=pod - -=back - -=end _private - -=over - -=item B - - # deprecated forms - install(\%from_to); - install(\%from_to, $verbose, $dry_run, $uninstall_shadows, - $skip, $always_copy, \%result); - - # recommended form as of 1.47 - install([ - from_to => \%from_to, - verbose => 1, - dry_run => 0, - uninstall_shadows => 1, - skip => undef, - always_copy => 1, - result => \%install_results, - ]); - - -Copies each directory tree of %from_to to its corresponding value -preserving timestamps and permissions. - -There are two keys with a special meaning in the hash: "read" and -"write". These contain packlist files. After the copying is done, -install() will write the list of target files to $from_to{write}. If -$from_to{read} is given the contents of this file will be merged into -the written file. The read and the written file may be identical, but -on AFS it is quite likely that people are installing to a different -directory than the one where the files later appear. - -If $verbose is true, will print out each file removed. Default is -false. This is "make install VERBINST=1". $verbose values going -up to 5 show increasingly more diagnostics output. - -If $dry_run is true it will only print what it was going to do -without actually doing it. Default is false. - -If $uninstall_shadows is true any differing versions throughout @INC -will be uninstalled. This is "make install UNINST=1" - -As of 1.37_02 install() supports the use of a list of patterns to filter out -files that shouldn't be installed. If $skip is omitted or undefined then -install will try to read the list from INSTALL.SKIP in the CWD. This file is -a list of regular expressions and is just like the MANIFEST.SKIP file used -by L. - -A default site INSTALL.SKIP may be provided by setting then environment -variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a -distribution specific INSTALL.SKIP. If the environment variable -EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be -performed. - -If $skip is undefined then the skip file will be autodetected and used if it -is found. If $skip is a reference to an array then it is assumed the array -contains the list of patterns, if $skip is a true non reference it is -assumed to be the filename holding the list of patterns, any other value of -$skip is taken to mean that no install filtering should occur. - -B - -As of version 1.47 the following additions were made to the install interface. -Note that the new argument style and use of the %result hash is recommended. - -The $always_copy parameter which when true causes files to be updated -regardless as to whether they have changed, if it is defined but false then -copies are made only if the files have changed, if it is undefined then the -value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default. - -The %result hash will be populated with the various keys/subhashes reflecting -the install. Currently these keys and their structure are: - - install => { $target => $source }, - install_fail => { $target => $source }, - install_unchanged => { $target => $source }, - - install_filtered => { $source => $pattern }, - - uninstall => { $uninstalled => $source }, - uninstall_fail => { $uninstalled => $source }, - -where C<$source> is the filespec of the file being installed. C<$target> is where -it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC> -or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that -caused a source file to be skipped. In future more keys will be added, such as to -show created directories, however this requires changes in other modules and must -therefore wait. - -These keys will be populated before any exceptions are thrown should there be an -error. - -Note that all updates of the %result are additive, the hash will not be -cleared before use, thus allowing status results of many installs to be easily -aggregated. - -B - -If there is only one argument and it is a reference to an array then -the array is assumed to contain a list of key-value pairs specifying -the options. In this case the option "from_to" is mandatory. This style -means that you do not have to supply a cryptic list of arguments and can -use a self documenting argument list that is easier to understand. - -This is now the recommended interface to install(). - -B - -If all actions were successful install will return a hashref of the results -as described above for the $result parameter. If any action is a failure -then install will die, therefore it is recommended to pass in the $result -parameter instead of using the return value. If the result parameter is -provided then the returned hashref will be the passed in hashref. - -=cut - -sub install { #XXX OS-SPECIFIC - my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_; - if (@_==1 and eval { 1+@$from_to }) { - my %opts = @$from_to; - $from_to = $opts{from_to} - or Carp::confess("from_to is a mandatory parameter"); - $verbose = $opts{verbose}; - $dry_run = $opts{dry_run}; - $uninstall_shadows = $opts{uninstall_shadows}; - $skip = $opts{skip}; - $always_copy = $opts{always_copy}; - $result = $opts{result}; - } - - $result ||= {}; - $verbose ||= 0; - $dry_run ||= 0; - - $skip= _get_install_skip($skip,$verbose); - $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY} - || $ENV{EU_ALWAYS_COPY} - || 0 - unless defined $always_copy; - - my(%from_to) = %$from_to; - my(%pack, $dir, %warned); - my($packlist) = ExtUtils::Packlist->new(); - - local(*DIR); - for (qw/read write/) { - $pack{$_}=$from_to{$_}; - delete $from_to{$_}; - } - my $tmpfile = install_rooted_file($pack{"read"}); - $packlist->read($tmpfile) if (-f $tmpfile); - my $cwd = cwd(); - my @found_files; - my %check_dirs; - - MOD_INSTALL: foreach my $source (sort keys %from_to) { - #copy the tree to the target directory without altering - #timestamp and permission and remember for the .packlist - #file. The packlist file contains the absolute paths of the - #install locations. AFS users may call this a bug. We'll have - #to reconsider how to add the means to satisfy AFS users also. - - #October 1997: we want to install .pm files into archlib if - #there are any files in arch. So we depend on having ./blib/arch - #hardcoded here. - - my $targetroot = install_rooted_dir($from_to{$source}); - - my $blib_lib = File::Spec->catdir('blib', 'lib'); - my $blib_arch = File::Spec->catdir('blib', 'arch'); - if ($source eq $blib_lib and - exists $from_to{$blib_arch} and - directory_not_empty($blib_arch) - ){ - $targetroot = install_rooted_dir($from_to{$blib_arch}); - print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"; - } - - next unless -d $source; - _chdir($source); - # 5.5.3's File::Find missing no_chdir option - # XXX OS-SPECIFIC - # File::Find seems to always be Unixy except on MacPerl :( - my $current_directory= $Is_MacPerl ? $Curdir : '.'; - find(sub { - my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; - - return if !-f _; - my $origfile = $_; - - return if $origfile eq ".exists"; - my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); - my $targetfile = File::Spec->catfile($targetdir, $origfile); - my $sourcedir = File::Spec->catdir($source, $File::Find::dir); - my $sourcefile = File::Spec->catfile($sourcedir, $origfile); - - for my $pat (@$skip) { - if ( $sourcefile=~/$pat/ ) { - print "Skipping $targetfile (filtered)\n" - if $verbose>1; - $result->{install_filtered}{$sourcefile} = $pat; - return; - } - } - # we have to do this for back compat with old File::Finds - # and because the target is relative - my $save_cwd = _chdir($cwd); - my $diff = 0; - # XXX: I wonder how useful this logic is actually -- demerphq - if ( $always_copy or !-f $targetfile or -s $targetfile != $size) { - $diff++; - } else { - # we might not need to copy this file - $diff = compare($sourcefile, $targetfile); - } - $check_dirs{$targetdir}++ - unless -w $targetfile; - - push @found_files, - [ $diff, $File::Find::dir, $origfile, - $mode, $size, $atime, $mtime, - $targetdir, $targetfile, $sourcedir, $sourcefile, - - ]; - #restore the original directory we were in when File::Find - #called us so that it doesn't get horribly confused. - _chdir($save_cwd); - }, $current_directory ); - _chdir($cwd); - } - foreach my $targetdir (sort keys %check_dirs) { - _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); - } - foreach my $found (@found_files) { - my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, - $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found; - - my $realtarget= $targetfile; - if ($diff) { - eval { - if (-f $targetfile) { - print "_unlink_or_rename($targetfile)\n" if $verbose>1; - $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) - unless $dry_run; - } elsif ( ! -d $targetdir ) { - _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); - } - print "Installing $targetfile\n"; - - _copy( $sourcefile, $targetfile, $verbose, $dry_run, ); - - - #XXX OS-SPECIFIC - print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; - utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1; - - - $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); - $mode = $mode | 0222 - if $realtarget ne $targetfile; - _chmod( $mode, $targetfile, $verbose ); - $result->{install}{$targetfile} = $sourcefile; - 1 - } or do { - $result->{install_fail}{$targetfile} = $sourcefile; - die $@; - }; - } else { - $result->{install_unchanged}{$targetfile} = $sourcefile; - print "Skipping $targetfile (unchanged)\n" if $verbose; - } - - if ( $uninstall_shadows ) { - inc_uninstall($sourcefile,$ffd, $verbose, - $dry_run, - $realtarget ne $targetfile ? $realtarget : "", - $result); - } - - # Record the full pathname. - $packlist->{$targetfile}++; - } - - if ($pack{'write'}) { - $dir = install_rooted_dir(dirname($pack{'write'})); - _mkpath( $dir, 0, 0755, $verbose, $dry_run ); - print "Writing $pack{'write'}\n" if $verbose; - $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run; - } - - _do_cleanup($verbose); - return $result; -} - -=begin _private - -=item _do_cleanup - -Standardize finish event for after another instruction has occurred. -Handles converting $MUST_REBOOT to a die for instance. - -=end _private - -=cut - -sub _do_cleanup { - my ($verbose) = @_; - if ($MUST_REBOOT) { - die _estr "Operation not completed! ", - "You must reboot to complete the installation.", - "Sorry."; - } elsif (defined $MUST_REBOOT & $verbose) { - warn _estr "Installation will be completed at the next reboot.\n", - "However it is not necessary to reboot immediately.\n"; - } -} - -=begin _undocumented - -=item install_rooted_file( $file ) - -Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT -is defined. - -=item install_rooted_dir( $dir ) - -Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT -is defined. - -=end _undocumented - -=cut - - -sub install_rooted_file { - if (defined $INSTALL_ROOT) { - File::Spec->catfile($INSTALL_ROOT, $_[0]); - } else { - $_[0]; - } -} - - -sub install_rooted_dir { - if (defined $INSTALL_ROOT) { - File::Spec->catdir($INSTALL_ROOT, $_[0]); - } else { - $_[0]; - } -} - -=begin _undocumented - -=item forceunlink( $file, $tryhard ) - -Tries to delete a file. If $tryhard is true then we will use whatever -devious tricks we can to delete the file. Currently this only applies to -Win32 in that it will try to use Win32API::File to schedule a delete at -reboot. A wrapper for _unlink_or_rename(). - -=end _undocumented - -=cut - - -sub forceunlink { - my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC - _unlink_or_rename( $file, $tryhard, not("installing") ); -} - -=begin _undocumented - -=item directory_not_empty( $dir ) - -Returns 1 if there is an .exists file somewhere in a directory tree. -Returns 0 if there is not. - -=end _undocumented - -=cut - -sub directory_not_empty ($) { - my($dir) = @_; - my $files = 0; - find(sub { - return if $_ eq ".exists"; - if (-f) { - $File::Find::prune++; - $files = 1; - } - }, $dir); - return $files; -} - -=pod - -=item B I - - install_default(); - install_default($fullext); - -Calls install() with arguments to copy a module from blib/ to the -default site installation location. - -$fullext is the name of the module converted to a directory -(ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it -will attempt to read it from @ARGV. - -This is primarily useful for install scripts. - -B This function is not really useful because of the hard-coded -install location with no way to control site vs core vs vendor -directories and the strange way in which the module name is given. -Consider its use discouraged. - -=cut - -sub install_default { - @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument"); - my $FULLEXT = @_ ? shift : $ARGV[0]; - defined $FULLEXT or die "Do not know to where to write install log"; - my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib"); - my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch"); - my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin'); - my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script'); - my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1'); - my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3'); - - my @INST_HTML; - if($Config{installhtmldir}) { - my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html'); - @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir}); - } - - install({ - read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", - write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", - $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? - $Config{installsitearch} : - $Config{installsitelib}, - $INST_ARCHLIB => $Config{installsitearch}, - $INST_BIN => $Config{installbin} , - $INST_SCRIPT => $Config{installscript}, - $INST_MAN1DIR => $Config{installman1dir}, - $INST_MAN3DIR => $Config{installman3dir}, - @INST_HTML, - },1,0,0); -} - - -=item B - - uninstall($packlist_file); - uninstall($packlist_file, $verbose, $dont_execute); - -Removes the files listed in a $packlist_file. - -If $verbose is true, will print out each file removed. Default is -false. - -If $dont_execute is true it will only print what it was going to do -without actually doing it. Default is false. - -=cut - -sub uninstall { - my($fil,$verbose,$dry_run) = @_; - $verbose ||= 0; - $dry_run ||= 0; - - die _estr "ERROR: no packlist file found: '$fil'" - unless -f $fil; - # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); - # require $my_req; # Hairy, but for the first - my ($packlist) = ExtUtils::Packlist->new($fil); - foreach (sort(keys(%$packlist))) { - chomp; - print "unlink $_\n" if $verbose; - forceunlink($_,'tryhard') unless $dry_run; - } - print "unlink $fil\n" if $verbose; - forceunlink($fil, 'tryhard') unless $dry_run; - _do_cleanup($verbose); -} - -=begin _undocumented - -=item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results) - -Remove shadowed files. If $ignore is true then it is assumed to hold -a filename to ignore. This is used to prevent spurious warnings from -occurring when doing an install at reboot. - -We now only die when failing to remove a file that has precedence over -our own, when our install has precedence we only warn. - -$results is assumed to contain a hashref which will have the keys -'uninstall' and 'uninstall_fail' populated with keys for the files -removed and values of the source files they would shadow. - -=end _undocumented - -=cut - -sub inc_uninstall { - my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_; - my($dir); - $ignore||=""; - my $file = (File::Spec->splitpath($filepath))[2]; - my %seen_dir = (); - - my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} - ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; - - my @dirs=( @PERL_ENV_LIB, - @INC, - @Config{qw(archlibexp - privlibexp - sitearchexp - sitelibexp)}); - - #warn join "\n","---",@dirs,"---"; - my $seen_ours; - foreach $dir ( @dirs ) { - my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir); - next if $canonpath eq $Curdir; - next if $seen_dir{$canonpath}++; - my $targetfile = File::Spec->catfile($canonpath,$libdir,$file); - next unless -f $targetfile; - - # The reason why we compare file's contents is, that we cannot - # know, which is the file we just installed (AFS). So we leave - # an identical file in place - my $diff = 0; - if ( -f $targetfile && -s _ == -s $filepath) { - # We have a good chance, we can skip this one - $diff = compare($filepath,$targetfile); - } else { - $diff++; - } - print "#$file and $targetfile differ\n" if $diff && $verbose > 1; - - if (!$diff or $targetfile eq $ignore) { - $seen_ours = 1; - next; - } - if ($dry_run) { - $results->{uninstall}{$targetfile} = $filepath; - if ($verbose) { - $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new(); - $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. - $Inc_uninstall_warn_handler->add( - File::Spec->catfile($libdir, $file), - $targetfile - ); - } - # if not verbose, we just say nothing - } else { - print "Unlinking $targetfile (shadowing?)\n" if $verbose; - eval { - die "Fake die for testing" - if $ExtUtils::Install::Testing and - ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile); - forceunlink($targetfile,'tryhard'); - $results->{uninstall}{$targetfile} = $filepath; - 1; - } or do { - $results->{fail_uninstall}{$targetfile} = $filepath; - if ($seen_ours) { - warn "Failed to remove probably harmless shadow file '$targetfile'\n"; - } else { - die "$@\n"; - } - }; - } - } -} - -=begin _undocumented - -=item run_filter($cmd,$src,$dest) - -Filter $src using $cmd into $dest. - -=end _undocumented - -=cut - -sub run_filter { - my ($cmd, $src, $dest) = @_; - local(*CMD, *SRC); - open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; - open(SRC, $src) || die "Cannot open $src: $!"; - my $buf; - my $sz = 1024; - while (my $len = sysread(SRC, $buf, $sz)) { - syswrite(CMD, $buf, $len); - } - close SRC; - close CMD or die "Filter command '$cmd' failed for $src"; -} - -=pod - -=item B - - pm_to_blib(\%from_to); - pm_to_blib(\%from_to, $autosplit_dir); - pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd); - -Copies each key of %from_to to its corresponding value efficiently. -If an $autosplit_dir is provided, all .pm files will be autosplit into it. -Any destination directories are created. - -$filter_cmd is an optional shell command to run each .pm file through -prior to splitting and copying. Input is the contents of the module, -output the new module contents. - -You can have an environment variable PERL_INSTALL_ROOT set which will -be prepended as a directory to each installed file (and directory). - -By default verbose output is generated, setting the PERL_INSTALL_QUIET -environment variable will silence this output. - -=cut - -sub pm_to_blib { - my($fromto,$autodir,$pm_filter) = @_; - - _mkpath($autodir,0,0755) if defined $autodir; - while(my($from, $to) = each %$fromto) { - if( -f $to && -s $from == -s $to && -M $to < -M $from ) { - print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; - next; - } - - # When a pm_filter is defined, we need to pre-process the source first - # to determine whether it has changed or not. Therefore, only perform - # the comparison check when there's no filter to be ran. - # -- RAM, 03/01/2001 - - my $need_filtering = defined $pm_filter && length $pm_filter && - $from =~ /\.pm$/; - - if (!$need_filtering && 0 == compare($from,$to)) { - print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; - next; - } - if (-f $to){ - # we wont try hard here. its too likely to mess things up. - forceunlink($to); - } else { - _mkpath(dirname($to),0,0755); - } - if ($need_filtering) { - run_filter($pm_filter, $from, $to); - print "$pm_filter <$from >$to\n"; - } else { - _copy( $from, $to ); - print "cp $from $to\n" unless $INSTALL_QUIET; - } - my($mode,$atime,$mtime) = (stat $from)[2,8,9]; - utime($atime,$mtime+$Is_VMS,$to); - _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); - next unless $from =~ /\.pm$/; - _autosplit($to,$autodir) if defined $autodir; - } -} - - -=begin _private - -=item _autosplit - -From 1.0307 back, AutoSplit will sometimes leave an open filehandle to -the file being split. This causes problems on systems with mandatory -locking (ie. Windows). So we wrap it and close the filehandle. - -=end _private - -=cut - -sub _autosplit { #XXX OS-SPECIFIC - my $retval = autosplit(@_); - close *AutoSplit::IN if defined *AutoSplit::IN{IO}; - - return $retval; -} - - -package ExtUtils::Install::Warn; - -sub new { bless {}, shift } - -sub add { - my($self,$file,$targetfile) = @_; - push @{$self->{$file}}, $targetfile; -} - -sub DESTROY { - unless(defined $INSTALL_ROOT) { - my $self = shift; - my($file,$i,$plural); - foreach $file (sort keys %$self) { - $plural = @{$self->{$file}} > 1 ? "s" : ""; - print "## Differing version$plural of $file found. You might like to\n"; - for (0..$#{$self->{$file}}) { - print "rm ", $self->{$file}[$_], "\n"; - $i++; - } - } - $plural = $i>1 ? "all those files" : "this file"; - my $inst = (_invokant() eq 'ExtUtils::MakeMaker') - ? ( $Config::Config{make} || 'make' ).' install' - . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' ) - : './Build install uninst=1'; - print "## Running '$inst' will unlink $plural for you.\n"; - } -} - -=begin _private - -=item _invokant - -Does a heuristic on the stack to see who called us for more intelligent -error messages. Currently assumes we will be called only by Module::Build -or by ExtUtils::MakeMaker. - -=end _private - -=cut - -sub _invokant { - my @stack; - my $frame = 0; - while (my $file = (caller($frame++))[1]) { - push @stack, (File::Spec->splitpath($file))[2]; - } - - my $builder; - my $top = pop @stack; - if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) { - $builder = 'Module::Build'; - } else { - $builder = 'ExtUtils::MakeMaker'; - } - return $builder; -} - -=pod - -=back - -=head1 ENVIRONMENT - -=over 4 - -=item B - -Will be prepended to each install path. - -=item B - -Will prevent the automatic use of INSTALL.SKIP as the install skip file. - -=item B - -If there is no INSTALL.SKIP file in the make directory then this value -can be used to provide a default. - -=item B - -If this environment variable is true then normal install processes will -always overwrite older identical files during the install process. - -Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY -is not defined until at least the 1.50 release. Please ensure you use the -correct EU_INSTALL_ALWAYS_COPY. - -=back - -=head1 AUTHOR - -Original author lost in the mists of time. Probably the same as Makemaker. - -Production release currently maintained by demerphq C, -extensive changes by Michael G. Schwern. - -Send bug reports via http://rt.cpan.org/. Please send your -generated Makefile along with your report. - -=head1 LICENSE - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See L - - -=cut - -1; diff --git a/bundled/ExtUtils-Install/ExtUtils/Installed.pm b/bundled/ExtUtils-Install/ExtUtils/Installed.pm deleted file mode 100644 index d094e9d..0000000 --- a/bundled/ExtUtils-Install/ExtUtils/Installed.pm +++ /dev/null @@ -1,471 +0,0 @@ -package ExtUtils::Installed; - -use 5.00503; -use strict; -#use warnings; # XXX requires 5.6 -use Carp qw(); -use ExtUtils::Packlist; -use ExtUtils::MakeMaker; -use Config; -use File::Find; -use File::Basename; -use File::Spec; - -my $Is_VMS = $^O eq 'VMS'; -my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); - -require VMS::Filespec if $Is_VMS; - -use vars qw($VERSION); -$VERSION = '2.06'; -$VERSION = eval $VERSION; - -sub _is_prefix { - my ($self, $path, $prefix) = @_; - return unless defined $prefix && defined $path; - - if( $Is_VMS ) { - $prefix = VMS::Filespec::unixify($prefix); - $path = VMS::Filespec::unixify($path); - } - - # Unix path normalization. - $prefix = File::Spec->canonpath($prefix); - - return 1 if substr($path, 0, length($prefix)) eq $prefix; - - if ($DOSISH) { - $path =~ s|\\|/|g; - $prefix =~ s|\\|/|g; - return 1 if $path =~ m{^\Q$prefix\E}i; - } - return(0); -} - -sub _is_doc { - my ($self, $path) = @_; - - my $man1dir = $self->{':private:'}{Config}{man1direxp}; - my $man3dir = $self->{':private:'}{Config}{man3direxp}; - return(($man1dir && $self->_is_prefix($path, $man1dir)) - || - ($man3dir && $self->_is_prefix($path, $man3dir)) - ? 1 : 0) -} - -sub _is_type { - my ($self, $path, $type) = @_; - return 1 if $type eq "all"; - - return($self->_is_doc($path)) if $type eq "doc"; - my $conf= $self->{':private:'}{Config}; - if ($type eq "prog") { - return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp}) - && !($self->_is_doc($path)) ? 1 : 0); - } - return(0); -} - -sub _is_under { - my ($self, $path, @under) = @_; - $under[0] = "" if (! @under); - foreach my $dir (@under) { - return(1) if ($self->_is_prefix($path, $dir)); - } - - return(0); -} - -sub _fix_dirs { - my ($self, @dirs)= @_; - # File::Find does not know how to deal with VMS filepaths. - if( $Is_VMS ) { - $_ = VMS::Filespec::unixify($_) - for @dirs; - } - - if ($DOSISH) { - s|\\|/|g for @dirs; - } - return wantarray ? @dirs : $dirs[0]; -} - -sub _make_entry { - my ($self, $module, $packlist_file, $modfile)= @_; - - my $data= { - module => $module, - packlist => scalar(ExtUtils::Packlist->new($packlist_file)), - packlist_file => $packlist_file, - }; - - if (!$modfile) { - $data->{version} = $self->{':private:'}{Config}{version}; - } else { - $data->{modfile} = $modfile; - # Find the top-level module file in @INC - $data->{version} = ''; - foreach my $dir (@{$self->{':private:'}{INC}}) { - my $p = File::Spec->catfile($dir, $modfile); - if (-r $p) { - $module = _module_name($p, $module) if $Is_VMS; - - $data->{version} = MM->parse_version($p); - $data->{version_from} = $p; - $data->{packlist_valid} = exists $data->{packlist}{$p}; - last; - } - } - } - $self->{$module}= $data; -} - -our $INSTALLED; -sub new { - my ($class) = shift(@_); - $class = ref($class) || $class; - - my %args = @_; - - return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default}); - - my $self = bless {}, $class; - - $INSTALLED= $self if $args{default_set} || $args{default}; - - - if ($args{config_override}) { - eval { - $self->{':private:'}{Config} = { %{$args{config_override}} }; - } or Carp::croak( - "The 'config_override' parameter must be a hash reference." - ); - } - else { - $self->{':private:'}{Config} = \%Config; - } - - for my $tuple ([inc_override => INC => [ @INC ] ], - [ extra_libs => EXTRA => [] ]) - { - my ($arg,$key,$val)=@$tuple; - if ( $args{$arg} ) { - eval { - $self->{':private:'}{$key} = [ @{$args{$arg}} ]; - } or Carp::croak( - "The '$arg' parameter must be an array reference." - ); - } - elsif ($val) { - $self->{':private:'}{$key} = $val; - } - } - { - my %dupe; - @{$self->{':private:'}{LIBDIRS}} = - grep { $_ ne '.' || ! $args{skip_cwd} } - grep { -e $_ && !$dupe{$_}++ } - @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}}; - } - - my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}}); - - # Read the core packlist - my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp}); - $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist')); - - my $root; - # Read the module packlists - my $sub = sub { - # Only process module .packlists - return if $_ ne ".packlist" || $File::Find::dir eq $archlib; - - # Hack of the leading bits of the paths & convert to a module name - my $module = $File::Find::name; - my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s - or do { - # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n", - # join ("\n",@dirs); - return; - }; - - my $modfile = "$module.pm"; - $module =~ s!/!::!g; - - return if $self->{$module}; #shadowing? - $self->_make_entry($module,$File::Find::name,$modfile); - }; - while (@dirs) { - $root= shift @dirs; - next if !-d $root; - find($sub,$root); - } - - return $self; -} - -# VMS's non-case preserving file-system means the package name can't -# be reconstructed from the filename. -sub _module_name { - my($file, $orig_module) = @_; - - my $module = ''; - if (open PACKFH, $file) { - while () { - if (/package\s+(\S+)\s*;/) { - my $pack = $1; - # Make a sanity check, that lower case $module - # is identical to lowercase $pack before - # accepting it - if (lc($pack) eq lc($orig_module)) { - $module = $pack; - last; - } - } - } - close PACKFH; - } - - print STDERR "Couldn't figure out the package name for $file\n" - unless $module; - - return $module; -} - -sub modules { - my ($self) = @_; - $self= $self->new(default=>1) if !ref $self; - - # Bug/feature of sort in scalar context requires this. - return wantarray - ? sort grep { not /^:private:$/ } keys %$self - : grep { not /^:private:$/ } keys %$self; -} - -sub files { - my ($self, $module, $type, @under) = @_; - $self= $self->new(default=>1) if !ref $self; - - # Validate arguments - Carp::croak("$module is not installed") if (! exists($self->{$module})); - $type = "all" if (! defined($type)); - Carp::croak('type must be "all", "prog" or "doc"') - if ($type ne "all" && $type ne "prog" && $type ne "doc"); - - my (@files); - foreach my $file (keys(%{$self->{$module}{packlist}})) { - push(@files, $file) - if ($self->_is_type($file, $type) && - $self->_is_under($file, @under)); - } - return(@files); -} - -sub directories { - my ($self, $module, $type, @under) = @_; - $self= $self->new(default=>1) if !ref $self; - my (%dirs); - foreach my $file ($self->files($module, $type, @under)) { - $dirs{dirname($file)}++; - } - return sort keys %dirs; -} - -sub directory_tree { - my ($self, $module, $type, @under) = @_; - $self= $self->new(default=>1) if !ref $self; - my (%dirs); - foreach my $dir ($self->directories($module, $type, @under)) { - $dirs{$dir}++; - my ($last) = (""); - while ($last ne $dir) { - $last = $dir; - $dir = dirname($dir); - last if !$self->_is_under($dir, @under); - $dirs{$dir}++; - } - } - return(sort(keys(%dirs))); -} - -sub validate { - my ($self, $module, $remove) = @_; - $self= $self->new(default=>1) if !ref $self; - Carp::croak("$module is not installed") if (! exists($self->{$module})); - return($self->{$module}{packlist}->validate($remove)); -} - -sub packlist { - my ($self, $module) = @_; - $self= $self->new(default=>1) if !ref $self; - Carp::croak("$module is not installed") if (! exists($self->{$module})); - return($self->{$module}{packlist}); -} - -sub version { - my ($self, $module) = @_; - $self= $self->new(default=>1) if !ref $self; - Carp::croak("$module is not installed") if (! exists($self->{$module})); - return($self->{$module}{version}); -} - -sub debug_dump { - my ($self, $module) = @_; - $self= $self->new(default=>1) if !ref $self; - local $self->{":private:"}{Config}; - require Data::Dumper; - print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump(); -} - - -1; - -__END__ - -=head1 NAME - -ExtUtils::Installed - Inventory management of installed modules - -=head1 SYNOPSIS - - use ExtUtils::Installed; - my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 ); - my (@modules) = $inst->modules(); - my (@missing) = $inst->validate("DBI"); - my $all_files = $inst->files("DBI"); - my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local"); - my $all_dirs = $inst->directories("DBI"); - my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog"); - my $packlist = $inst->packlist("DBI"); - -=head1 DESCRIPTION - -ExtUtils::Installed provides a standard way to find out what core and module -files have been installed. It uses the information stored in .packlist files -created during installation to provide this information. In addition it -provides facilities to classify the installed files and to extract directory -information from the .packlist files. - -=head1 USAGE - -The new() function searches for all the installed .packlists on the system, and -stores their contents. The .packlists can be queried with the functions -described below. Where it searches by default is determined by the settings found -in C<%Config::Config>, and what the value is of the PERL5LIB environment variable. - -=head1 METHODS - -Unless specified otherwise all method can be called as class methods, or as object -methods. If called as class methods then the "default" object will be used, and if -necessary created using the current processes %Config and @INC. See the -'default' option to new() for details. - - -=over 4 - -=item new() - -This takes optional named parameters. Without parameters, this -searches for all the installed .packlists on the system using -information from C<%Config::Config> and the default module search -paths C<@INC>. The packlists are read using the -L module. - -If the named parameter C is true, the current directory C<.> will -be stripped from C<@INC> before searching for .packlists. This keeps -ExtUtils::Installed from finding modules installed in other perls that -happen to be located below the current directory. - -If the named parameter C is specified, -it should be a reference to a hash which contains all information -usually found in C<%Config::Config>. For example, you can obtain -the configuration information for a separate perl installation and -pass that in. - - my $yoda_cfg = get_fake_config('yoda'); - my $yoda_inst = - ExtUtils::Installed->new(config_override=>$yoda_cfg); - -Similarly, the parameter C may be a reference to an -array which is used in place of the default module search paths -from C<@INC>. - - use Config; - my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB}); - my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs); - -B: You probably do not want to use these options alone, almost always -you will want to set both together. - -The parameter C can be used to specify B paths to -search for installed modules. For instance - - my $installed = - ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]); - -This should only be necessary if F is not in PERL5LIB. - -Finally there is the 'default', and the related 'default_get' and 'default_set' -options. These options control the "default" object which is provided by the -class interface to the methods. Setting C to true tells the constructor -to return the default object if it is defined. Setting C to true tells -the constructor to make the default object the constructed object. Setting the -C option is like setting both to true. This is used primarily internally -and probably isn't interesting to any real user. - -=item modules() - -This returns a list of the names of all the installed modules. The perl 'core' -is given the special name 'Perl'. - -=item files() - -This takes one mandatory parameter, the name of a module. It returns a list of -all the filenames from the package. To obtain a list of core perl files, use -the module name 'Perl'. Additional parameters are allowed. The first is one -of the strings "prog", "doc" or "all", to select either just program files, -just manual files or all files. The remaining parameters are a list of -directories. The filenames returned will be restricted to those under the -specified directories. - -=item directories() - -This takes one mandatory parameter, the name of a module. It returns a list of -all the directories from the package. Additional parameters are allowed. The -first is one of the strings "prog", "doc" or "all", to select either just -program directories, just manual directories or all directories. The remaining -parameters are a list of directories. The directories returned will be -restricted to those under the specified directories. This method returns only -the leaf directories that contain files from the specified module. - -=item directory_tree() - -This is identical in operation to directories(), except that it includes all the -intermediate directories back up to the specified directories. - -=item validate() - -This takes one mandatory parameter, the name of a module. It checks that all -the files listed in the modules .packlist actually exist, and returns a list of -any missing files. If an optional second argument which evaluates to true is -given any missing files will be removed from the .packlist - -=item packlist() - -This returns the ExtUtils::Packlist object for the specified module. - -=item version() - -This returns the version number for the specified module. - -=back - -=head1 EXAMPLE - -See the example in L. - -=head1 AUTHOR - -Alan Burlison - -=cut diff --git a/bundled/ExtUtils-Install/ExtUtils/Packlist.pm b/bundled/ExtUtils-Install/ExtUtils/Packlist.pm deleted file mode 100644 index 9cc4e98..0000000 --- a/bundled/ExtUtils-Install/ExtUtils/Packlist.pm +++ /dev/null @@ -1,353 +0,0 @@ -package ExtUtils::Packlist; - -use 5.00503; -use strict; -use Carp qw(); -use Config; -use vars qw($VERSION $Relocations); -$VERSION = '2.06'; -$VERSION = eval $VERSION; - -# Used for generating filehandle globs. IO::File might not be available! -my $fhname = "FH1"; - -=begin _undocumented - -=over - -=item mkfh() - -Make a filehandle. Same kind of idea as Symbol::gensym(). - -=cut - -sub mkfh() -{ -no strict; -local $^W; -my $fh = \*{$fhname++}; -use strict; -return($fh); -} - -=item __find_relocations - -Works out what absolute paths in the configuration have been located at run -time relative to $^X, and generates a regexp that matches them - -=back - -=end _undocumented - -=cut - -sub __find_relocations -{ - my %paths; - while (my ($raw_key, $raw_val) = each %Config) { - my $exp_key = $raw_key . "exp"; - next unless exists $Config{$exp_key}; - next unless $raw_val =~ m!\.\.\./!; - $paths{$Config{$exp_key}}++; - } - # Longest prefixes go first in the alternatives - my $alternations = join "|", map {quotemeta $_} - sort {length $b <=> length $a} keys %paths; - qr/^($alternations)/o; -} - -sub new($$) -{ -my ($class, $packfile) = @_; -$class = ref($class) || $class; -my %self; -tie(%self, $class, $packfile); -return(bless(\%self, $class)); -} - -sub TIEHASH -{ -my ($class, $packfile) = @_; -my $self = { packfile => $packfile }; -bless($self, $class); -$self->read($packfile) if (defined($packfile) && -f $packfile); -return($self); -} - -sub STORE -{ -$_[0]->{data}->{$_[1]} = $_[2]; -} - -sub FETCH -{ -return($_[0]->{data}->{$_[1]}); -} - -sub FIRSTKEY -{ -my $reset = scalar(keys(%{$_[0]->{data}})); -return(each(%{$_[0]->{data}})); -} - -sub NEXTKEY -{ -return(each(%{$_[0]->{data}})); -} - -sub EXISTS -{ -return(exists($_[0]->{data}->{$_[1]})); -} - -sub DELETE -{ -return(delete($_[0]->{data}->{$_[1]})); -} - -sub CLEAR -{ -%{$_[0]->{data}} = (); -} - -sub DESTROY -{ -} - -sub read($;$) -{ -my ($self, $packfile) = @_; -$self = tied(%$self) || $self; - -if (defined($packfile)) { $self->{packfile} = $packfile; } -else { $packfile = $self->{packfile}; } -Carp::croak("No packlist filename specified") if (! defined($packfile)); -my $fh = mkfh(); -open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!"); -$self->{data} = {}; -my ($line); -while (defined($line = <$fh>)) - { - chomp $line; - my ($key, $data) = $line; - if ($key =~ /^(.*?)( \w+=.*)$/) - { - $key = $1; - $data = { map { split('=', $_) } split(' ', $2)}; - - if ($Config{userelocatableinc} && $data->{relocate_as}) - { - require File::Spec; - require Cwd; - my ($vol, $dir) = File::Spec->splitpath($packfile); - my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as}); - $key = Cwd::realpath($newpath); - } - } - $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths - $self->{data}->{$key} = $data; - } -close($fh); -} - -sub write($;$) -{ -my ($self, $packfile) = @_; -$self = tied(%$self) || $self; -if (defined($packfile)) { $self->{packfile} = $packfile; } -else { $packfile = $self->{packfile}; } -Carp::croak("No packlist filename specified") if (! defined($packfile)); -my $fh = mkfh(); -open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!"); -foreach my $key (sort(keys(%{$self->{data}}))) - { - my $data = $self->{data}->{$key}; - if ($Config{userelocatableinc}) { - $Relocations ||= __find_relocations(); - if ($packfile =~ $Relocations) { - # We are writing into a subdirectory of a run-time relocated - # path. Figure out if the this file is also within a subdir. - my $prefix = $1; - if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix))) - { - # The relocated path is within the found prefix - my $packfile_prefix; - (undef, $packfile_prefix) - = File::Spec->splitpath($packfile); - - my $relocate_as - = File::Spec->abs2rel($key, $packfile_prefix); - - if (!ref $data) { - $data = {}; - } - $data->{relocate_as} = $relocate_as; - } - } - } - print $fh ("$key"); - if (ref($data)) - { - foreach my $k (sort(keys(%$data))) - { - print $fh (" $k=$data->{$k}"); - } - } - print $fh ("\n"); - } -close($fh); -} - -sub validate($;$) -{ -my ($self, $remove) = @_; -$self = tied(%$self) || $self; -my @missing; -foreach my $key (sort(keys(%{$self->{data}}))) - { - if (! -e $key) - { - push(@missing, $key); - delete($self->{data}{$key}) if ($remove); - } - } -return(@missing); -} - -sub packlist_file($) -{ -my ($self) = @_; -$self = tied(%$self) || $self; -return($self->{packfile}); -} - -1; - -__END__ - -=head1 NAME - -ExtUtils::Packlist - manage .packlist files - -=head1 SYNOPSIS - - use ExtUtils::Packlist; - my ($pl) = ExtUtils::Packlist->new('.packlist'); - $pl->read('/an/old/.packlist'); - my @missing_files = $pl->validate(); - $pl->write('/a/new/.packlist'); - - $pl->{'/some/file/name'}++; - or - $pl->{'/some/other/file/name'} = { type => 'file', - from => '/some/file' }; - -=head1 DESCRIPTION - -ExtUtils::Packlist provides a standard way to manage .packlist files. -Functions are provided to read and write .packlist files. The original -.packlist format is a simple list of absolute pathnames, one per line. In -addition, this package supports an extended format, where as well as a filename -each line may contain a list of attributes in the form of a space separated -list of key=value pairs. This is used by the installperl script to -differentiate between files and links, for example. - -=head1 USAGE - -The hash reference returned by the new() function can be used to examine and -modify the contents of the .packlist. Items may be added/deleted from the -.packlist by modifying the hash. If the value associated with a hash key is a -scalar, the entry written to the .packlist by any subsequent write() will be a -simple filename. If the value is a hash, the entry written will be the -filename followed by the key=value pairs from the hash. Reading back the -.packlist will recreate the original entries. - -=head1 FUNCTIONS - -=over 4 - -=item new() - -This takes an optional parameter, the name of a .packlist. If the file exists, -it will be opened and the contents of the file will be read. The new() method -returns a reference to a hash. This hash holds an entry for each line in the -.packlist. In the case of old-style .packlists, the value associated with each -key is undef. In the case of new-style .packlists, the value associated with -each key is a hash containing the key=value pairs following the filename in the -.packlist. - -=item read() - -This takes an optional parameter, the name of the .packlist to be read. If -no file is specified, the .packlist specified to new() will be read. If the -.packlist does not exist, Carp::croak will be called. - -=item write() - -This takes an optional parameter, the name of the .packlist to be written. If -no file is specified, the .packlist specified to new() will be overwritten. - -=item validate() - -This checks that every file listed in the .packlist actually exists. If an -argument which evaluates to true is given, any missing files will be removed -from the internal hash. The return value is a list of the missing files, which -will be empty if they all exist. - -=item packlist_file() - -This returns the name of the associated .packlist file - -=back - -=head1 EXAMPLE - -Here's C, a little utility to cleanly remove an installed module. - - #!/usr/local/bin/perl -w - - use strict; - use IO::Dir; - use ExtUtils::Packlist; - use ExtUtils::Installed; - - sub emptydir($) { - my ($dir) = @_; - my $dh = IO::Dir->new($dir) || return(0); - my @count = $dh->read(); - $dh->close(); - return(@count == 2 ? 1 : 0); - } - - # Find all the installed packages - print("Finding all installed modules...\n"); - my $installed = ExtUtils::Installed->new(); - - foreach my $module (grep(!/^Perl$/, $installed->modules())) { - my $version = $installed->version($module) || "???"; - print("Found module $module Version $version\n"); - print("Do you want to delete $module? [n] "); - my $r = ; chomp($r); - if ($r && $r =~ /^y/i) { - # Remove all the files - foreach my $file (sort($installed->files($module))) { - print("rm $file\n"); - unlink($file); - } - my $pf = $installed->packlist($module)->packlist_file(); - print("rm $pf\n"); - unlink($pf); - foreach my $dir (sort($installed->directory_tree($module))) { - if (emptydir($dir)) { - print("rmdir $dir\n"); - rmdir($dir); - } - } - } - } - -=head1 AUTHOR - -Alan Burlison - -=cut diff --git a/bundled/ExtUtils-Manifest/ExtUtils/MANIFEST.SKIP b/bundled/ExtUtils-Manifest/ExtUtils/MANIFEST.SKIP deleted file mode 100644 index 65592fb..0000000 --- a/bundled/ExtUtils-Manifest/ExtUtils/MANIFEST.SKIP +++ /dev/null @@ -1,63 +0,0 @@ -# Avoid version control files. -\bRCS\b -\bCVS\b -\bSCCS\b -,v$ -\B\.svn\b -\B\.git\b -\B\.gitignore\b -\b_darcs\b -\B\.cvsignore$ - -# Avoid VMS specific MakeMaker generated files -\bDescrip.MMS$ -\bDESCRIP.MMS$ -\bdescrip.mms$ - -# Avoid Makemaker generated and utility files. -\bMANIFEST\.bak -\bMakefile$ -\bblib/ -\bMakeMaker-\d -\bpm_to_blib\.ts$ -\bpm_to_blib$ -\bblibdirs\.ts$ # 6.18 through 6.25 generated this -\b_eumm/ # 7.05_05 and above - -# Avoid Module::Build generated and utility files. -\bBuild$ -\b_build/ -\bBuild.bat$ -\bBuild.COM$ -\bBUILD.COM$ -\bbuild.com$ - -# and Module::Build::Tiny generated files -\b_build_params$ - -# Avoid temp and backup files. -~$ -\.old$ -\#$ -\b\.# -\.bak$ -\.tmp$ -\.# -\.rej$ -\..*\.sw.?$ - -# Avoid OS-specific files/dirs -# Mac OSX metadata -\B\.DS_Store -# Mac OSX SMB mount metadata files -\B\._ - -# Avoid Devel::Cover and Devel::CoverX::Covered files. -\bcover_db\b -\bcovered\b - -# Avoid prove files -\B\.prove$ - -# Avoid MYMETA files -^MYMETA\. diff --git a/bundled/ExtUtils-Manifest/ExtUtils/Manifest.pm b/bundled/ExtUtils-Manifest/ExtUtils/Manifest.pm deleted file mode 100644 index 4163c93..0000000 --- a/bundled/ExtUtils-Manifest/ExtUtils/Manifest.pm +++ /dev/null @@ -1,911 +0,0 @@ -package ExtUtils::Manifest; - -require Exporter; -use Config; -use File::Basename; -use File::Copy 'copy'; -use File::Find; -use File::Spec 0.8; -use Carp; -use strict; -use warnings; - -our $VERSION = '1.70'; -our @ISA = ('Exporter'); -our @EXPORT_OK = qw(mkmanifest - manicheck filecheck fullcheck skipcheck - manifind maniread manicopy maniadd - maniskip - ); - -our $Is_MacOS = $^O eq 'MacOS'; -our $Is_VMS = $^O eq 'VMS'; -our $Is_VMS_mode = 0; -our $Is_VMS_lc = 0; -our $Is_VMS_nodot = 0; # No dots in dir names or double dots in files - -if ($Is_VMS) { - require VMS::Filespec if $Is_VMS; - my $vms_unix_rpt; - my $vms_efs; - my $vms_case; - - $Is_VMS_mode = 1; - $Is_VMS_lc = 1; - $Is_VMS_nodot = 1; - if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { - $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); - $vms_efs = VMS::Feature::current("efs_charset"); - $vms_case = VMS::Feature::current("efs_case_preserve"); - } else { - my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; - my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; - my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; - $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; - $vms_efs = $efs_charset =~ /^[ET1]/i; - $vms_case = $efs_case =~ /^[ET1]/i; - } - $Is_VMS_lc = 0 if ($vms_case); - $Is_VMS_mode = 0 if ($vms_unix_rpt); - $Is_VMS_nodot = 0 if ($vms_efs); -} - -our $Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; -our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? - $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; -our $Quiet = 0; -our $MANIFEST = 'MANIFEST'; - -our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); - - -=head1 NAME - -ExtUtils::Manifest - utilities to write and check a MANIFEST file - -=head1 VERSION - -version 1.70 - -=head1 SYNOPSIS - - use ExtUtils::Manifest qw(...funcs to import...); - - mkmanifest(); - - my @missing_files = manicheck; - my @skipped = skipcheck; - my @extra_files = filecheck; - my($missing, $extra) = fullcheck; - - my $found = manifind(); - - my $manifest = maniread(); - - manicopy($read,$target); - - maniadd({$file => $comment, ...}); - - -=head1 DESCRIPTION - -=head2 Functions - -ExtUtils::Manifest exports no functions by default. The following are -exported on request - -=over 4 - -=item mkmanifest - - mkmanifest(); - -Writes all files in and below the current directory to your F. -It works similar to the result of the Unix command - - find . > MANIFEST - -All files that match any regular expression in a file F -(if it exists) are ignored. - -Any existing F file will be saved as F. - -=cut - -sub _sort { - return sort { lc $a cmp lc $b } @_; -} - -sub mkmanifest { - my $manimiss = 0; - my $read = (-r 'MANIFEST' && maniread()) or $manimiss++; - $read = {} if $manimiss; - local *M; - my $bakbase = $MANIFEST; - $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots - rename $MANIFEST, "$bakbase.bak" unless $manimiss; - open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!"; - binmode M, ':raw'; - my $skip = maniskip(); - my $found = manifind(); - my($key,$val,$file,%all); - %all = (%$found, %$read); - $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') . - 'This list of files' - if $manimiss; # add new MANIFEST to known file list - foreach $file (_sort keys %all) { - if ($skip->($file)) { - # Policy: only remove files if they're listed in MANIFEST.SKIP. - # Don't remove files just because they don't exist. - warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file}; - next; - } - if ($Verbose){ - warn "Added to $MANIFEST: $file\n" unless exists $read->{$file}; - } - my $text = $all{$file}; - $file = _unmacify($file); - my $tabs = (5 - (length($file)+1)/8); - $tabs = 1 if $tabs < 1; - $tabs = 0 unless $text; - if ($file =~ /\s/) { - $file =~ s/([\\'])/\\$1/g; - $file = "'$file'"; - } - print M $file, "\t" x $tabs, $text, "\n"; - } - close M; -} - -# Geez, shouldn't this use File::Spec or File::Basename or something? -# Why so careful about dependencies? -sub clean_up_filename { - my $filename = shift; - $filename =~ s|^\./||; - $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS; - if ( $Is_VMS ) { - $filename =~ s/\.$//; # trim trailing dot - $filename = VMS::Filespec::unixify($filename); # unescape spaces, etc. - if( $Is_VMS_lc ) { - $filename = lc($filename); - $filename = uc($filename) if $filename =~ /^MANIFEST(\.SKIP)?$/i; - } - } - return $filename; -} - - -=item manifind - - my $found = manifind(); - -returns a hash reference. The keys of the hash are the files found -below the current directory. - -=cut - -sub manifind { - my $p = shift || {}; - my $found = {}; - - my $wanted = sub { - my $name = clean_up_filename($File::Find::name); - warn "Debug: diskfile $name\n" if $Debug; - return if -d $_; - $found->{$name} = ""; - }; - - # We have to use "$File::Find::dir/$_" in preprocess, because - # $File::Find::name is unavailable. - # Also, it's okay to use / here, because MANIFEST files use Unix-style - # paths. - find({wanted => $wanted, follow_fast => 1}, - $Is_MacOS ? ":" : "."); - - return $found; -} - - -=item manicheck - - my @missing_files = manicheck(); - -checks if all the files within a C in the current directory -really do exist. If C and the tree below the current -directory are in sync it silently returns an empty list. -Otherwise it returns a list of files which are listed in the -C but missing from the directory, and by default also -outputs these names to STDERR. - -=cut - -sub manicheck { - return _check_files(); -} - - -=item filecheck - - my @extra_files = filecheck(); - -finds files below the current directory that are not mentioned in the -C file. An optional file C will be -consulted. Any file matching a regular expression in such a file will -not be reported as missing in the C file. The list of any -extraneous files found is returned, and by default also reported to -STDERR. - -=cut - -sub filecheck { - return _check_manifest(); -} - - -=item fullcheck - - my($missing, $extra) = fullcheck(); - -does both a manicheck() and a filecheck(), returning then as two array -refs. - -=cut - -sub fullcheck { - return [_check_files()], [_check_manifest()]; -} - - -=item skipcheck - - my @skipped = skipcheck(); - -lists all the files that are skipped due to your C -file. - -=cut - -sub skipcheck { - my($p) = @_; - my $found = manifind(); - my $matches = maniskip(); - - my @skipped = (); - foreach my $file (_sort keys %$found){ - if (&$matches($file)){ - warn "Skipping $file\n" unless $Quiet; - push @skipped, $file; - next; - } - } - - return @skipped; -} - - -sub _check_files { - my $p = shift; - my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0); - my $read = maniread() || {}; - my $found = manifind($p); - - my(@missfile) = (); - foreach my $file (_sort keys %$read){ - warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; - if ($dosnames){ - $file = lc $file; - $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge; - $file =~ s=((\w|-)+)=substr ($1,0,8)=ge; - } - unless ( exists $found->{$file} ) { - warn "No such file: $file\n" unless $Quiet; - push @missfile, $file; - } - } - - return @missfile; -} - - -sub _check_manifest { - my($p) = @_; - my $read = maniread() || {}; - my $found = manifind($p); - my $skip = maniskip(); - - my @missentry = (); - foreach my $file (_sort keys %$found){ - next if $skip->($file); - warn "Debug: manicheck checking from disk $file\n" if $Debug; - unless ( exists $read->{$file} ) { - my $canon = $Is_MacOS ? "\t" . _unmacify($file) : ''; - warn "Not in $MANIFEST: $file$canon\n" unless $Quiet; - push @missentry, $file; - } - } - - return @missentry; -} - - -=item maniread - - my $manifest = maniread(); - my $manifest = maniread($manifest_file); - -reads a named C file (defaults to C in the current -directory) and returns a HASH reference with files being the keys and -comments being the values of the HASH. Blank lines and lines which -start with C<#> in the C file are discarded. - -=cut - -sub maniread { - my ($mfile) = @_; - $mfile ||= $MANIFEST; - my $read = {}; - local *M; - unless (open M, "< $mfile"){ - warn "Problem opening $mfile: $!"; - return $read; - } - local $_; - while (){ - chomp; - next if /^\s*#/; - - my($file, $comment); - - # filename may contain spaces if enclosed in '' - # (in which case, \\ and \' are escapes) - if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) { - $file =~ s/\\([\\'])/$1/g; - } - else { - ($file, $comment) = /^(\S+)\s*(.*)/; - } - next unless $file; - - if ($Is_MacOS) { - $file = _macify($file); - $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge; - } - elsif ($Is_VMS_mode) { - require File::Basename; - my($base,$dir) = File::Basename::fileparse($file); - # Resolve illegal file specifications in the same way as tar - if ($Is_VMS_nodot) { - $dir =~ tr/./_/; - my(@pieces) = split(/\./,$base); - if (@pieces > 2) - { $base = shift(@pieces) . '.' . join('_',@pieces); } - my $okfile = "$dir$base"; - warn "Debug: Illegal name $file changed to $okfile\n" if $Debug; - $file = $okfile; - } - if( $Is_VMS_lc ) { - $file = lc($file); - $file = uc($file) if $file =~ /^MANIFEST(\.SKIP)?$/i; - } - } - - $read->{$file} = $comment; - } - close M; - $read; -} - -=item maniskip - - my $skipchk = maniskip(); - my $skipchk = maniskip($manifest_skip_file); - - if ($skipchk->($file)) { .. } - -reads a named C file (defaults to C in -the current directory) and returns a CODE reference that tests whether -a given filename should be skipped. - -=cut - -# returns an anonymous sub that decides if an argument matches -sub maniskip { - my @skip ; - my $mfile = shift || "$MANIFEST.SKIP"; - _check_mskip_directives($mfile) if -f $mfile; - local(*M, $_); - open M, "< $mfile" or open M, "< $DEFAULT_MSKIP" or return sub {0}; - while (){ - chomp; - s/\r//; - $_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$}; - #my $comment = $3; - my $filename = $2; - if ( defined($1) ) { - $filename = $1; - $filename =~ s/\\(['\\])/$1/g; - } - next if (not defined($filename) or not $filename); - push @skip, _macify($filename); - } - close M; - return sub {0} unless (scalar @skip > 0); - - my $opts = $Is_VMS_mode ? '(?i)' : ''; - - # Make sure each entry is isolated in its own parentheses, in case - # any of them contain alternations - my $regex = join '|', map "(?:$_)", @skip; - - return sub { $_[0] =~ qr{$opts$regex} }; -} - -# checks for the special directives -# #!include_default -# #!include /path/to/some/manifest.skip -# in a custom MANIFEST.SKIP for, for including -# the content of, respectively, the default MANIFEST.SKIP -# and an external manifest.skip file -sub _check_mskip_directives { - my $mfile = shift; - local (*M, $_); - my @lines = (); - my $flag = 0; - unless (open M, "< $mfile") { - warn "Problem opening $mfile: $!"; - return; - } - while () { - if (/^#!include_default\s*$/) { - if (my @default = _include_mskip_file()) { - push @lines, @default; - warn "Debug: Including default MANIFEST.SKIP\n" if $Debug; - $flag++; - } - next; - } - if (/^#!include\s+(.*)\s*$/) { - my $external_file = $1; - if (my @external = _include_mskip_file($external_file)) { - push @lines, @external; - warn "Debug: Including external $external_file\n" if $Debug; - $flag++; - } - next; - } - push @lines, $_; - } - close M; - return unless $flag; - my $bakbase = $mfile; - $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots - rename $mfile, "$bakbase.bak"; - warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug; - unless (open M, "> $mfile") { - warn "Problem opening $mfile: $!"; - return; - } - binmode M, ':raw'; - print M $_ for (@lines); - close M; - return; -} - -# returns an array containing the lines of an external -# manifest.skip file, if given, or $DEFAULT_MSKIP -sub _include_mskip_file { - my $mskip = shift || $DEFAULT_MSKIP; - unless (-f $mskip) { - warn qq{Included file "$mskip" not found - skipping}; - return; - } - local (*M, $_); - unless (open M, "< $mskip") { - warn "Problem opening $mskip: $!"; - return; - } - my @lines = (); - push @lines, "\n#!start included $mskip\n"; - push @lines, $_ while ; - close M; - push @lines, "#!end included $mskip\n\n"; - return @lines; -} - -=item manicopy - - manicopy(\%src, $dest_dir); - manicopy(\%src, $dest_dir, $how); - -Copies the files that are the keys in %src to the $dest_dir. %src is -typically returned by the maniread() function. - - manicopy( maniread(), $dest_dir ); - -This function is useful for producing a directory tree identical to the -intended distribution tree. - -$how can be used to specify a different methods of "copying". Valid -values are C, which actually copies the files, C which creates -hard links, and C which mostly links the files but copies any -symbolic link to make a tree without any symbolic link. C is the -default. - -=cut - -sub manicopy { - my($read,$target,$how)=@_; - croak "manicopy() called without target argument" unless defined $target; - $how ||= 'cp'; - require File::Path; - require File::Basename; - - $target = VMS::Filespec::unixify($target) if $Is_VMS_mode; - File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); - foreach my $file (keys %$read){ - if ($Is_MacOS) { - if ($file =~ m!:!) { - my $dir = _maccat($target, $file); - $dir =~ s/[^:]+$//; - File::Path::mkpath($dir,1,0755); - } - cp_if_diff($file, _maccat($target, $file), $how); - } else { - $file = VMS::Filespec::unixify($file) if $Is_VMS_mode; - if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? - my $dir = File::Basename::dirname($file); - $dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode; - File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); - } - cp_if_diff($file, "$target/$file", $how); - } - } -} - -sub cp_if_diff { - my($from, $to, $how)=@_; - if (! -f $from) { - carp "$from not found"; - return; - } - my($diff) = 0; - local(*F,*T); - open(F,"< $from\0") or die "Can't read $from: $!\n"; - if (open(T,"< $to\0")) { - local $_; - while () { $diff++,last if $_ ne ; } - $diff++ unless eof(T); - close T; - } - else { $diff++; } - close F; - if ($diff) { - if (-e $to) { - unlink($to) or confess "unlink $to: $!"; - } - STRICT_SWITCH: { - best($from,$to), last STRICT_SWITCH if $how eq 'best'; - cp($from,$to), last STRICT_SWITCH if $how eq 'cp'; - ln($from,$to), last STRICT_SWITCH if $how eq 'ln'; - croak("ExtUtils::Manifest::cp_if_diff " . - "called with illegal how argument [$how]. " . - "Legal values are 'best', 'cp', and 'ln'."); - } - } -} - -sub cp { - my ($srcFile, $dstFile) = @_; - my ($access,$mod) = (stat $srcFile)[8,9]; - - copy($srcFile,$dstFile); - utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; - _manicopy_chmod($srcFile, $dstFile); -} - - -sub ln { - my ($srcFile, $dstFile) = @_; - # Fix-me - VMS can support links. - return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); - link($srcFile, $dstFile); - - unless( _manicopy_chmod($srcFile, $dstFile) ) { - unlink $dstFile; - return; - } - 1; -} - -# 1) Strip off all group and world permissions. -# 2) Let everyone read it. -# 3) If the owner can execute it, everyone can. -sub _manicopy_chmod { - my($srcFile, $dstFile) = @_; - - my $perm = 0444 | (stat $srcFile)[2] & 0700; - chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile ); -} - -# Files that are often modified in the distdir. Don't hard link them. -my @Exceptions = qw(MANIFEST META.yml SIGNATURE); -sub best { - my ($srcFile, $dstFile) = @_; - - my $is_exception = grep $srcFile =~ /$_/, @Exceptions; - if ($is_exception or !$Config{d_link} or -l $srcFile) { - cp($srcFile, $dstFile); - } else { - ln($srcFile, $dstFile) or cp($srcFile, $dstFile); - } -} - -sub _macify { - my($file) = @_; - - return $file unless $Is_MacOS; - - $file =~ s|^\./||; - if ($file =~ m|/|) { - $file =~ s|/+|:|g; - $file = ":$file"; - } - - $file; -} - -sub _maccat { - my($f1, $f2) = @_; - - return "$f1/$f2" unless $Is_MacOS; - - $f1 .= ":$f2"; - $f1 =~ s/([^:]:):/$1/g; - return $f1; -} - -sub _unmacify { - my($file) = @_; - - return $file unless $Is_MacOS; - - $file =~ s|^:||; - $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge; - $file =~ y|:|/|; - - $file; -} - - -=item maniadd - - maniadd({ $file => $comment, ...}); - -Adds an entry to an existing F unless its already there. - -$file will be normalized (ie. Unixified). B - -=cut - -sub maniadd { - my($additions) = shift; - - _normalize($additions); - _fix_manifest($MANIFEST); - - my $manifest = maniread(); - my @needed = grep { !exists $manifest->{$_} } keys %$additions; - return 1 unless @needed; - - open(MANIFEST, ">>$MANIFEST") or - die "maniadd() could not open $MANIFEST: $!"; - binmode MANIFEST, ':raw'; - - foreach my $file (_sort @needed) { - my $comment = $additions->{$file} || ''; - if ($file =~ /\s/) { - $file =~ s/([\\'])/\\$1/g; - $file = "'$file'"; - } - printf MANIFEST "%-40s %s\n", $file, $comment; - } - close MANIFEST or die "Error closing $MANIFEST: $!"; - - return 1; -} - - -# Make sure this MANIFEST is consistently written with native -# newlines and has a terminal newline. -sub _fix_manifest { - my $manifest_file = shift; - - open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!"; - local $/; - my @manifest = split /(\015\012|\012|\015)/, , -1; - close MANIFEST; - my $must_rewrite = ""; - if ($manifest[-1] eq ""){ - # sane case: last line had a terminal newline - pop @manifest; - for (my $i=1; $i<=$#manifest; $i+=2) { - unless ($manifest[$i] eq "\n") { - $must_rewrite = "not a newline at pos $i"; - last; - } - } - } else { - $must_rewrite = "last line without newline"; - } - - if ( $must_rewrite ) { - 1 while unlink $MANIFEST; # avoid multiple versions on VMS - open MANIFEST, ">", $MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!"; - binmode MANIFEST, ':raw'; - for (my $i=0; $i<=$#manifest; $i+=2) { - print MANIFEST "$manifest[$i]\n"; - } - close MANIFEST or die "could not write $MANIFEST: $!"; - } -} - - -# UNIMPLEMENTED -sub _normalize { - return; -} - - -=back - -=head2 MANIFEST - -A list of files in the distribution, one file per line. The MANIFEST -always uses Unix filepath conventions even if you're not on Unix. This -means F style not F. - -Anything between white space and an end of line within a C -file is considered to be a comment. Any line beginning with # is also -a comment. Beginning with ExtUtils::Manifest 1.52, a filename may -contain whitespace characters if it is enclosed in single quotes; single -quotes or backslashes in that filename must be backslash-escaped. - - # this a comment - some/file - some/other/file comment about some/file - 'some/third file' comment - - -=head2 MANIFEST.SKIP - -The file MANIFEST.SKIP may contain regular expressions of files that -should be ignored by mkmanifest() and filecheck(). The regular -expressions should appear one on each line. Blank lines and lines -which start with C<#> are skipped. Use C<\#> if you need a regular -expression to start with a C<#>. - -For example: - - # Version control files and dirs. - \bRCS\b - \bCVS\b - ,v$ - \B\.svn\b - - # Makemaker generated files and dirs. - ^MANIFEST\. - ^Makefile$ - ^blib/ - ^MakeMaker-\d - - # Temp, old and emacs backup files. - ~$ - \.old$ - ^#.*#$ - ^\.# - -If no MANIFEST.SKIP file is found, a default set of skips will be -used, similar to the example above. If you want nothing skipped, -simply make an empty MANIFEST.SKIP file. - -In one's own MANIFEST.SKIP file, certain directives -can be used to include the contents of other MANIFEST.SKIP -files. At present two such directives are recognized. - -=over 4 - -=item #!include_default - -This inserts the contents of the default MANIFEST.SKIP file - -=item #!include /Path/to/another/manifest.skip - -This inserts the contents of the specified external file - -=back - -The included contents will be inserted into the MANIFEST.SKIP -file in between I<#!start included /path/to/manifest.skip> -and I<#!end included /path/to/manifest.skip> markers. -The original MANIFEST.SKIP is saved as MANIFEST.SKIP.bak. - -=head2 EXPORT_OK - -C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>, -C<&maniread>, and C<&manicopy> are exportable. - -=head2 GLOBAL VARIABLES - -C<$ExtUtils::Manifest::MANIFEST> defaults to C. Changing it -results in both a different C and a different -C file. This is useful if you want to maintain -different distributions for different audiences (say a user version -and a developer version including RCS). - -C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, -all functions act silently. - -C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value, -or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be -produced. - -=head1 DIAGNOSTICS - -All diagnostic output is sent to C. - -=over 4 - -=item C I - -is reported if a file is found which is not in C. - -=item C I - -is reported if a file is skipped due to an entry in C. - -=item C I - -is reported if a file mentioned in a C file does not -exist. - -=item C I<$!> - -is reported if C could not be opened. - -=item C I - -is reported by mkmanifest() if $Verbose is set and a file is added -to MANIFEST. $Verbose is set to 1 by default. - -=back - -=head1 ENVIRONMENT - -=over 4 - -=item B - -Turns on debugging - -=back - -=head1 SEE ALSO - -L which has handy targets for most of the functionality. - -=head1 AUTHOR - -Andreas Koenig C - -Currently maintained by the Perl Toolchain Gang. - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 1996- by Andreas Koenig. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut - -1; diff --git a/bundled/File-Temp/File/Temp.pm b/bundled/File-Temp/File/Temp.pm deleted file mode 100644 index a2d4ae0..0000000 --- a/bundled/File-Temp/File/Temp.pm +++ /dev/null @@ -1,2452 +0,0 @@ -package File::Temp; - -=head1 NAME - -File::Temp - return name and handle of a temporary file safely - -=begin __INTERNALS - -=head1 PORTABILITY - -This section is at the top in order to provide easier access to -porters. It is not expected to be rendered by a standard pod -formatting tool. Please skip straight to the SYNOPSIS section if you -are not trying to port this module to a new platform. - -This module is designed to be portable across operating systems and it -currently supports Unix, VMS, DOS, OS/2, Windows and Mac OS -(Classic). When porting to a new OS there are generally three main -issues that have to be solved: - -=over 4 - -=item * - -Can the OS unlink an open file? If it can not then the -C<_can_unlink_opened_file> method should be modified. - -=item * - -Are the return values from C reliable? By default all the -return values from C are compared when unlinking a temporary -file using the filename and the handle. Operating systems other than -unix do not always have valid entries in all fields. If C fails -then the C comparison should be modified accordingly. - -=item * - -Security. Systems that can not support a test for the sticky bit -on a directory can not use the MEDIUM and HIGH security tests. -The C<_can_do_level> method should be modified accordingly. - -=back - -=end __INTERNALS - -=head1 SYNOPSIS - - use File::Temp qw/ tempfile tempdir /; - - $fh = tempfile(); - ($fh, $filename) = tempfile(); - - ($fh, $filename) = tempfile( $template, DIR => $dir); - ($fh, $filename) = tempfile( $template, SUFFIX => '.dat'); - ($fh, $filename) = tempfile( $template, TMPDIR => 1 ); - - binmode( $fh, ":utf8" ); - - $dir = tempdir( CLEANUP => 1 ); - ($fh, $filename) = tempfile( DIR => $dir ); - -Object interface: - - require File::Temp; - use File::Temp (); - use File::Temp qw/ :seekable /; - - $fh = File::Temp->new(); - $fname = $fh->filename; - - $fh = File::Temp->new(TEMPLATE => $template); - $fname = $fh->filename; - - $tmp = File::Temp->new( UNLINK => 0, SUFFIX => '.dat' ); - print $tmp "Some data\n"; - print "Filename is $tmp\n"; - $tmp->seek( 0, SEEK_END ); - -The following interfaces are provided for compatibility with -existing APIs. They should not be used in new code. - -MkTemp family: - - use File::Temp qw/ :mktemp /; - - ($fh, $file) = mkstemp( "tmpfileXXXXX" ); - ($fh, $file) = mkstemps( "tmpfileXXXXXX", $suffix); - - $tmpdir = mkdtemp( $template ); - - $unopened_file = mktemp( $template ); - -POSIX functions: - - use File::Temp qw/ :POSIX /; - - $file = tmpnam(); - $fh = tmpfile(); - - ($fh, $file) = tmpnam(); - -Compatibility functions: - - $unopened_file = File::Temp::tempnam( $dir, $pfx ); - -=head1 DESCRIPTION - -C can be used to create and open temporary files in a safe -way. There is both a function interface and an object-oriented -interface. The File::Temp constructor or the tempfile() function can -be used to return the name and the open filehandle of a temporary -file. The tempdir() function can be used to create a temporary -directory. - -The security aspect of temporary file creation is emphasized such that -a filehandle and filename are returned together. This helps guarantee -that a race condition can not occur where the temporary file is -created by another process between checking for the existence of the -file and its opening. Additional security levels are provided to -check, for example, that the sticky bit is set on world writable -directories. See L<"safe_level"> for more information. - -For compatibility with popular C library functions, Perl implementations of -the mkstemp() family of functions are provided. These are, mkstemp(), -mkstemps(), mkdtemp() and mktemp(). - -Additionally, implementations of the standard L -tmpnam() and tmpfile() functions are provided if required. - -Implementations of mktemp(), tmpnam(), and tempnam() are provided, -but should be used with caution since they return only a filename -that was valid when function was called, so cannot guarantee -that the file will not exist by the time the caller opens the filename. - -Filehandles returned by these functions support the seekable methods. - -=cut - -# 5.6.0 gives us S_IWOTH, S_IWGRP, our and auto-vivifying filehandls -# People would like a version on 5.004 so give them what they want :-) -use 5.004; -use strict; -use Carp; -use File::Spec 0.8; -use File::Path qw/ rmtree /; -use Fcntl 1.03; -use IO::Seekable; # For SEEK_* -use Errno; -require VMS::Stdio if $^O eq 'VMS'; - -# pre-emptively load Carp::Heavy. If we don't when we run out of file -# handles and attempt to call croak() we get an error message telling -# us that Carp::Heavy won't load rather than an error telling us we -# have run out of file handles. We either preload croak() or we -# switch the calls to croak from _gettemp() to use die. -eval { require Carp::Heavy; }; - -# Need the Symbol package if we are running older perl -require Symbol if $] < 5.006; - -### For the OO interface -use base qw/ IO::Handle IO::Seekable /; -use overload '""' => "STRINGIFY", fallback => 1; - -# use 'our' on v5.6.0 -use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); - -$DEBUG = 0; -$KEEP_ALL = 0; - -# We are exporting functions - -use base qw/Exporter/; - -# Export list - to allow fine tuning of export table - -@EXPORT_OK = qw{ - tempfile - tempdir - tmpnam - tmpfile - mktemp - mkstemp - mkstemps - mkdtemp - unlink0 - cleanup - SEEK_SET - SEEK_CUR - SEEK_END - }; - -# Groups of functions for export - -%EXPORT_TAGS = ( - 'POSIX' => [qw/ tmpnam tmpfile /], - 'mktemp' => [qw/ mktemp mkstemp mkstemps mkdtemp/], - 'seekable' => [qw/ SEEK_SET SEEK_CUR SEEK_END /], - ); - -# add contents of these tags to @EXPORT -Exporter::export_tags('POSIX','mktemp','seekable'); - -# Version number - -$VERSION = '0.22'; - -# This is a list of characters that can be used in random filenames - -my @CHARS = (qw/ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z - a b c d e f g h i j k l m n o p q r s t u v w x y z - 0 1 2 3 4 5 6 7 8 9 _ - /); - -# Maximum number of tries to make a temp file before failing - -use constant MAX_TRIES => 1000; - -# Minimum number of X characters that should be in a template -use constant MINX => 4; - -# Default template when no template supplied - -use constant TEMPXXX => 'X' x 10; - -# Constants for the security level - -use constant STANDARD => 0; -use constant MEDIUM => 1; -use constant HIGH => 2; - -# OPENFLAGS. If we defined the flag to use with Sysopen here this gives -# us an optimisation when many temporary files are requested - -my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; -my $LOCKFLAG; - -unless ($^O eq 'MacOS') { - for my $oflag (qw/ NOFOLLOW BINARY LARGEFILE NOINHERIT /) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - no strict 'refs'; - $OPENFLAGS |= $bit if eval { - # Make sure that redefined die handlers do not cause problems - # e.g. CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; - } - # Special case O_EXLOCK - $LOCKFLAG = eval { - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - &Fcntl::O_EXLOCK(); - }; -} - -# On some systems the O_TEMPORARY flag can be used to tell the OS -# to automatically remove the file when it is closed. This is fine -# in most cases but not if tempfile is called with UNLINK=>0 and -# the filename is requested -- in the case where the filename is to -# be passed to another routine. This happens on windows. We overcome -# this by using a second open flags variable - -my $OPENTEMPFLAGS = $OPENFLAGS; -unless ($^O eq 'MacOS') { - for my $oflag (qw/ TEMPORARY /) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - local($@); - no strict 'refs'; - $OPENTEMPFLAGS |= $bit if eval { - # Make sure that redefined die handlers do not cause problems - # e.g. CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; - } -} - -# Private hash tracking which files have been created by each process id via the OO interface -my %FILES_CREATED_BY_OBJECT; - -# INTERNAL ROUTINES - not to be used outside of package - -# Generic routine for getting a temporary filename -# modelled on OpenBSD _gettemp() in mktemp.c - -# The template must contain X's that are to be replaced -# with the random values - -# Arguments: - -# TEMPLATE - string containing the XXXXX's that is converted -# to a random filename and opened if required - -# Optionally, a hash can also be supplied containing specific options -# "open" => if true open the temp file, else just return the name -# default is 0 -# "mkdir"=> if true, we are creating a temp directory rather than tempfile -# default is 0 -# "suffixlen" => number of characters at end of PATH to be ignored. -# default is 0. -# "unlink_on_close" => indicates that, if possible, the OS should remove -# the file as soon as it is closed. Usually indicates -# use of the O_TEMPORARY flag to sysopen. -# Usually irrelevant on unix -# "use_exlock" => Indicates that O_EXLOCK should be used. Default is true. - -# Optionally a reference to a scalar can be passed into the function -# On error this will be used to store the reason for the error -# "ErrStr" => \$errstr - -# "open" and "mkdir" can not both be true -# "unlink_on_close" is not used when "mkdir" is true. - -# The default options are equivalent to mktemp(). - -# Returns: -# filehandle - open file handle (if called with doopen=1, else undef) -# temp name - name of the temp file or directory - -# For example: -# ($fh, $name) = _gettemp($template, "open" => 1); - -# for the current version, failures are associated with -# stored in an error string and returned to give the reason whilst debugging -# This routine is not called by any external function -sub _gettemp { - - croak 'Usage: ($fh, $name) = _gettemp($template, OPTIONS);' - unless scalar(@_) >= 1; - - # the internal error string - expect it to be overridden - # Need this in case the caller decides not to supply us a value - # need an anonymous scalar - my $tempErrStr; - - # Default options - my %options = ( - "open" => 0, - "mkdir" => 0, - "suffixlen" => 0, - "unlink_on_close" => 0, - "use_exlock" => 1, - "ErrStr" => \$tempErrStr, - ); - - # Read the template - my $template = shift; - if (ref($template)) { - # Use a warning here since we have not yet merged ErrStr - carp "File::Temp::_gettemp: template must not be a reference"; - return (); - } - - # Check that the number of entries on stack are even - if (scalar(@_) % 2 != 0) { - # Use a warning here since we have not yet merged ErrStr - carp "File::Temp::_gettemp: Must have even number of options"; - return (); - } - - # Read the options and merge with defaults - %options = (%options, @_) if @_; - - # Make sure the error string is set to undef - ${$options{ErrStr}} = undef; - - # Can not open the file and make a directory in a single call - if ($options{"open"} && $options{"mkdir"}) { - ${$options{ErrStr}} = "doopen and domkdir can not both be true\n"; - return (); - } - - # Find the start of the end of the Xs (position of last X) - # Substr starts from 0 - my $start = length($template) - 1 - $options{"suffixlen"}; - - # Check that we have at least MINX x X (e.g. 'XXXX") at the end of the string - # (taking suffixlen into account). Any fewer is insecure. - - # Do it using substr - no reason to use a pattern match since - # we know where we are looking and what we are looking for - - if (substr($template, $start - MINX + 1, MINX) ne 'X' x MINX) { - ${$options{ErrStr}} = "The template must end with at least ". - MINX . " 'X' characters\n"; - return (); - } - - # Replace all the X at the end of the substring with a - # random character or just all the XX at the end of a full string. - # Do it as an if, since the suffix adjusts which section to replace - # and suffixlen=0 returns nothing if used in the substr directly - # and generate a full path from the template - - my $path = _replace_XX($template, $options{"suffixlen"}); - - - # Split the path into constituent parts - eventually we need to check - # whether the directory exists - # We need to know whether we are making a temp directory - # or a tempfile - - my ($volume, $directories, $file); - my $parent; # parent directory - if ($options{"mkdir"}) { - # There is no filename at the end - ($volume, $directories, $file) = File::Spec->splitpath( $path, 1); - - # The parent is then $directories without the last directory - # Split the directory and put it back together again - my @dirs = File::Spec->splitdir($directories); - - # If @dirs only has one entry (i.e. the directory template) that means - # we are in the current directory - if ($#dirs == 0) { - $parent = File::Spec->curdir; - } else { - - if ($^O eq 'VMS') { # need volume to avoid relative dir spec - $parent = File::Spec->catdir($volume, @dirs[0..$#dirs-1]); - $parent = 'sys$disk:[]' if $parent eq ''; - } else { - - # Put it back together without the last one - $parent = File::Spec->catdir(@dirs[0..$#dirs-1]); - - # ...and attach the volume (no filename) - $parent = File::Spec->catpath($volume, $parent, ''); - } - - } - - } else { - - # Get rid of the last filename (use File::Basename for this?) - ($volume, $directories, $file) = File::Spec->splitpath( $path ); - - # Join up without the file part - $parent = File::Spec->catpath($volume,$directories,''); - - # If $parent is empty replace with curdir - $parent = File::Spec->curdir - unless $directories ne ''; - - } - - # Check that the parent directories exist - # Do this even for the case where we are simply returning a name - # not a file -- no point returning a name that includes a directory - # that does not exist or is not writable - - unless (-e $parent) { - ${$options{ErrStr}} = "Parent directory ($parent) does not exist"; - return (); - } - unless (-d $parent) { - ${$options{ErrStr}} = "Parent directory ($parent) is not a directory"; - return (); - } - - # Check the stickiness of the directory and chown giveaway if required - # If the directory is world writable the sticky bit - # must be set - - if (File::Temp->safe_level == MEDIUM) { - my $safeerr; - unless (_is_safe($parent,\$safeerr)) { - ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; - return (); - } - } elsif (File::Temp->safe_level == HIGH) { - my $safeerr; - unless (_is_verysafe($parent, \$safeerr)) { - ${$options{ErrStr}} = "Parent directory ($parent) is not safe ($safeerr)"; - return (); - } - } - - - # Now try MAX_TRIES time to open the file - for (my $i = 0; $i < MAX_TRIES; $i++) { - - # Try to open the file if requested - if ($options{"open"}) { - my $fh; - - # If we are running before perl5.6.0 we can not auto-vivify - if ($] < 5.006) { - $fh = &Symbol::gensym; - } - - # Try to make sure this will be marked close-on-exec - # XXX: Win32 doesn't respect this, nor the proper fcntl, - # but may have O_NOINHERIT. This may or may not be in Fcntl. - local $^F = 2; - - # Attempt to open the file - my $open_success = undef; - if ( $^O eq 'VMS' and $options{"unlink_on_close"} && !$KEEP_ALL) { - # make it auto delete on close by setting FAB$V_DLT bit - $fh = VMS::Stdio::vmssysopen($path, $OPENFLAGS, 0600, 'fop=dlt'); - $open_success = $fh; - } else { - my $flags = ( ($options{"unlink_on_close"} && !$KEEP_ALL) ? - $OPENTEMPFLAGS : - $OPENFLAGS ); - $flags |= $LOCKFLAG if (defined $LOCKFLAG && $options{use_exlock}); - $open_success = sysopen($fh, $path, $flags, 0600); - } - if ( $open_success ) { - - # in case of odd umask force rw - chmod(0600, $path); - - # Opened successfully - return file handle and name - return ($fh, $path); - - } else { - - # Error opening file - abort with error - # if the reason was anything but EEXIST - unless ($!{EEXIST}) { - ${$options{ErrStr}} = "Could not create temp file $path: $!"; - return (); - } - - # Loop round for another try - - } - } elsif ($options{"mkdir"}) { - - # Open the temp directory - if (mkdir( $path, 0700)) { - # in case of odd umask - chmod(0700, $path); - - return undef, $path; - } else { - - # Abort with error if the reason for failure was anything - # except EEXIST - unless ($!{EEXIST}) { - ${$options{ErrStr}} = "Could not create directory $path: $!"; - return (); - } - - # Loop round for another try - - } - - } else { - - # Return true if the file can not be found - # Directory has been checked previously - - return (undef, $path) unless -e $path; - - # Try again until MAX_TRIES - - } - - # Did not successfully open the tempfile/dir - # so try again with a different set of random letters - # No point in trying to increment unless we have only - # 1 X say and the randomness could come up with the same - # file MAX_TRIES in a row. - - # Store current attempt - in principal this implies that the - # 3rd time around the open attempt that the first temp file - # name could be generated again. Probably should store each - # attempt and make sure that none are repeated - - my $original = $path; - my $counter = 0; # Stop infinite loop - my $MAX_GUESS = 50; - - do { - - # Generate new name from original template - $path = _replace_XX($template, $options{"suffixlen"}); - - $counter++; - - } until ($path ne $original || $counter > $MAX_GUESS); - - # Check for out of control looping - if ($counter > $MAX_GUESS) { - ${$options{ErrStr}} = "Tried to get a new temp name different to the previous value $MAX_GUESS times.\nSomething wrong with template?? ($template)"; - return (); - } - - } - - # If we get here, we have run out of tries - ${ $options{ErrStr} } = "Have exceeded the maximum number of attempts (" - . MAX_TRIES . ") to open temp file/dir"; - - return (); - -} - -# Internal routine to replace the XXXX... with random characters -# This has to be done by _gettemp() every time it fails to -# open a temp file/dir - -# Arguments: $template (the template with XXX), -# $ignore (number of characters at end to ignore) - -# Returns: modified template - -sub _replace_XX { - - croak 'Usage: _replace_XX($template, $ignore)' - unless scalar(@_) == 2; - - my ($path, $ignore) = @_; - - # Do it as an if, since the suffix adjusts which section to replace - # and suffixlen=0 returns nothing if used in the substr directly - # Alternatively, could simply set $ignore to length($path)-1 - # Don't want to always use substr when not required though. - my $end = ( $] >= 5.006 ? "\\z" : "\\Z" ); - - if ($ignore) { - substr($path, 0, - $ignore) =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; - } else { - $path =~ s/X(?=X*$end)/$CHARS[ int( rand( @CHARS ) ) ]/ge; - } - return $path; -} - -# Internal routine to force a temp file to be writable after -# it is created so that we can unlink it. Windows seems to occassionally -# force a file to be readonly when written to certain temp locations -sub _force_writable { - my $file = shift; - chmod 0600, $file; -} - - -# internal routine to check to see if the directory is safe -# First checks to see if the directory is not owned by the -# current user or root. Then checks to see if anyone else -# can write to the directory and if so, checks to see if -# it has the sticky bit set - -# Will not work on systems that do not support sticky bit - -#Args: directory path to check -# Optionally: reference to scalar to contain error message -# Returns true if the path is safe and false otherwise. -# Returns undef if can not even run stat() on the path - -# This routine based on version written by Tom Christiansen - -# Presumably, by the time we actually attempt to create the -# file or directory in this directory, it may not be safe -# anymore... Have to run _is_safe directly after the open. - -sub _is_safe { - - my $path = shift; - my $err_ref = shift; - - # Stat path - my @info = stat($path); - unless (scalar(@info)) { - $$err_ref = "stat(path) returned no values"; - return 0; - } - ; - return 1 if $^O eq 'VMS'; # owner delete control at file level - - # Check to see whether owner is neither superuser (or a system uid) nor me - # Use the effective uid from the $> variable - # UID is in [4] - if ($info[4] > File::Temp->top_system_uid() && $info[4] != $>) { - - Carp::cluck(sprintf "uid=$info[4] topuid=%s euid=$> path='$path'", - File::Temp->top_system_uid()); - - $$err_ref = "Directory owned neither by root nor the current user" - if ref($err_ref); - return 0; - } - - # check whether group or other can write file - # use 066 to detect either reading or writing - # use 022 to check writability - # Do it with S_IWOTH and S_IWGRP for portability (maybe) - # mode is in info[2] - if (($info[2] & &Fcntl::S_IWGRP) || # Is group writable? - ($info[2] & &Fcntl::S_IWOTH) ) { # Is world writable? - # Must be a directory - unless (-d $path) { - $$err_ref = "Path ($path) is not a directory" - if ref($err_ref); - return 0; - } - # Must have sticky bit set - unless (-k $path) { - $$err_ref = "Sticky bit not set on $path when dir is group|world writable" - if ref($err_ref); - return 0; - } - } - - return 1; -} - -# Internal routine to check whether a directory is safe -# for temp files. Safer than _is_safe since it checks for -# the possibility of chown giveaway and if that is a possibility -# checks each directory in the path to see if it is safe (with _is_safe) - -# If _PC_CHOWN_RESTRICTED is not set, does the full test of each -# directory anyway. - -# Takes optional second arg as scalar ref to error reason - -sub _is_verysafe { - - # Need POSIX - but only want to bother if really necessary due to overhead - require POSIX; - - my $path = shift; - print "_is_verysafe testing $path\n" if $DEBUG; - return 1 if $^O eq 'VMS'; # owner delete control at file level - - my $err_ref = shift; - - # Should Get the value of _PC_CHOWN_RESTRICTED if it is defined - # and If it is not there do the extensive test - local($@); - my $chown_restricted; - $chown_restricted = &POSIX::_PC_CHOWN_RESTRICTED() - if eval { &POSIX::_PC_CHOWN_RESTRICTED(); 1}; - - # If chown_resticted is set to some value we should test it - if (defined $chown_restricted) { - - # Return if the current directory is safe - return _is_safe($path,$err_ref) if POSIX::sysconf( $chown_restricted ); - - } - - # To reach this point either, the _PC_CHOWN_RESTRICTED symbol - # was not avialable or the symbol was there but chown giveaway - # is allowed. Either way, we now have to test the entire tree for - # safety. - - # Convert path to an absolute directory if required - unless (File::Spec->file_name_is_absolute($path)) { - $path = File::Spec->rel2abs($path); - } - - # Split directory into components - assume no file - my ($volume, $directories, undef) = File::Spec->splitpath( $path, 1); - - # Slightly less efficient than having a function in File::Spec - # to chop off the end of a directory or even a function that - # can handle ../ in a directory tree - # Sometimes splitdir() returns a blank at the end - # so we will probably check the bottom directory twice in some cases - my @dirs = File::Spec->splitdir($directories); - - # Concatenate one less directory each time around - foreach my $pos (0.. $#dirs) { - # Get a directory name - my $dir = File::Spec->catpath($volume, - File::Spec->catdir(@dirs[0.. $#dirs - $pos]), - '' - ); - - print "TESTING DIR $dir\n" if $DEBUG; - - # Check the directory - return 0 unless _is_safe($dir,$err_ref); - - } - - return 1; -} - - - -# internal routine to determine whether unlink works on this -# platform for files that are currently open. -# Returns true if we can, false otherwise. - -# Currently WinNT, OS/2 and VMS can not unlink an opened file -# On VMS this is because the O_EXCL flag is used to open the -# temporary file. Currently I do not know enough about the issues -# on VMS to decide whether O_EXCL is a requirement. - -sub _can_unlink_opened_file { - - if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { - return 0; - } else { - return 1; - } - -} - -# internal routine to decide which security levels are allowed -# see safe_level() for more information on this - -# Controls whether the supplied security level is allowed - -# $cando = _can_do_level( $level ) - -sub _can_do_level { - - # Get security level - my $level = shift; - - # Always have to be able to do STANDARD - return 1 if $level == STANDARD; - - # Currently, the systems that can do HIGH or MEDIUM are identical - if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS' || $^O eq 'mpeix') { - return 0; - } else { - return 1; - } - -} - -# This routine sets up a deferred unlinking of a specified -# filename and filehandle. It is used in the following cases: -# - Called by unlink0 if an opened file can not be unlinked -# - Called by tempfile() if files are to be removed on shutdown -# - Called by tempdir() if directories are to be removed on shutdown - -# Arguments: -# _deferred_unlink( $fh, $fname, $isdir ); -# -# - filehandle (so that it can be expclicitly closed if open -# - filename (the thing we want to remove) -# - isdir (flag to indicate that we are being given a directory) -# [and hence no filehandle] - -# Status is not referred to since all the magic is done with an END block - -{ - # Will set up two lexical variables to contain all the files to be - # removed. One array for files, another for directories They will - # only exist in this block. - - # This means we only have to set up a single END block to remove - # all files. - - # in order to prevent child processes inadvertently deleting the parent - # temp files we use a hash to store the temp files and directories - # created by a particular process id. - - # %files_to_unlink contains values that are references to an array of - # array references containing the filehandle and filename associated with - # the temp file. - my (%files_to_unlink, %dirs_to_unlink); - - # Set up an end block to use these arrays - END { - local($., $@, $!, $^E, $?); - cleanup(); - } - - # Cleanup function. Always triggered on END but can be invoked - # manually. - sub cleanup { - if (!$KEEP_ALL) { - # Files - my @files = (exists $files_to_unlink{$$} ? - @{ $files_to_unlink{$$} } : () ); - foreach my $file (@files) { - # close the filehandle without checking its state - # in order to make real sure that this is closed - # if its already closed then I dont care about the answer - # probably a better way to do this - close($file->[0]); # file handle is [0] - - if (-f $file->[1]) { # file name is [1] - _force_writable( $file->[1] ); # for windows - unlink $file->[1] or warn "Error removing ".$file->[1]; - } - } - # Dirs - my @dirs = (exists $dirs_to_unlink{$$} ? - @{ $dirs_to_unlink{$$} } : () ); - foreach my $dir (@dirs) { - if (-d $dir) { - # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. We protect that and turn it - # into a warning. We do this because this occurs during - # cleanup and so can not be caught by the user. - eval { rmtree($dir, $DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - } - - # clear the arrays - @{ $files_to_unlink{$$} } = () - if exists $files_to_unlink{$$}; - @{ $dirs_to_unlink{$$} } = () - if exists $dirs_to_unlink{$$}; - } - } - - - # This is the sub called to register a file for deferred unlinking - # This could simply store the input parameters and defer everything - # until the END block. For now we do a bit of checking at this - # point in order to make sure that (1) we have a file/dir to delete - # and (2) we have been called with the correct arguments. - sub _deferred_unlink { - - croak 'Usage: _deferred_unlink($fh, $fname, $isdir)' - unless scalar(@_) == 3; - - my ($fh, $fname, $isdir) = @_; - - warn "Setting up deferred removal of $fname\n" - if $DEBUG; - - # If we have a directory, check that it is a directory - if ($isdir) { - - if (-d $fname) { - - # Directory exists so store it - # first on VMS turn []foo into [.foo] for rmtree - $fname = VMS::Filespec::vmspath($fname) if $^O eq 'VMS'; - $dirs_to_unlink{$$} = [] - unless exists $dirs_to_unlink{$$}; - push (@{ $dirs_to_unlink{$$} }, $fname); - - } else { - carp "Request to remove directory $fname could not be completed since it does not exist!\n" if $^W; - } - - } else { - - if (-f $fname) { - - # file exists so store handle and name for later removal - $files_to_unlink{$$} = [] - unless exists $files_to_unlink{$$}; - push(@{ $files_to_unlink{$$} }, [$fh, $fname]); - - } else { - carp "Request to remove file $fname could not be completed since it is not there!\n" if $^W; - } - - } - - } - - -} - -=head1 OBJECT-ORIENTED INTERFACE - -This is the primary interface for interacting with -C. Using the OO interface a temporary file can be created -when the object is constructed and the file can be removed when the -object is no longer required. - -Note that there is no method to obtain the filehandle from the -C object. The object itself acts as a filehandle. Also, -the object is configured such that it stringifies to the name of the -temporary file, and can be compared to a filename directly. The object -isa C and isa C so all those methods are -available. - -=over 4 - -=item B - -Create a temporary file object. - - my $tmp = File::Temp->new(); - -by default the object is constructed as if C -was called without options, but with the additional behaviour -that the temporary file is removed by the object destructor -if UNLINK is set to true (the default). - -Supported arguments are the same as for C: UNLINK -(defaulting to true), DIR, EXLOCK and SUFFIX. Additionally, the filename -template is specified using the TEMPLATE option. The OPEN option -is not supported (the file is always opened). - - $tmp = File::Temp->new( TEMPLATE => 'tempXXXXX', - DIR => 'mydir', - SUFFIX => '.dat'); - -Arguments are case insensitive. - -Can call croak() if an error occurs. - -=cut - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - - # read arguments and convert keys to upper case - my %args = @_; - %args = map { uc($_), $args{$_} } keys %args; - - # see if they are unlinking (defaulting to yes) - my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); - delete $args{UNLINK}; - - # template (store it in an array so that it will - # disappear from the arg list of tempfile) - my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); - delete $args{TEMPLATE}; - - # Protect OPEN - delete $args{OPEN}; - - # Open the file and retain file handle and file name - my ($fh, $path) = tempfile( @template, %args ); - - print "Tmp: $fh - $path\n" if $DEBUG; - - # Store the filename in the scalar slot - ${*$fh} = $path; - - # Cache the filename by pid so that the destructor can decide whether to remove it - $FILES_CREATED_BY_OBJECT{$$}{$path} = 1; - - # Store unlink information in hash slot (plus other constructor info) - %{*$fh} = %args; - - # create the object - bless $fh, $class; - - # final method-based configuration - $fh->unlink_on_destroy( $unlink ); - - return $fh; -} - -=item B - -Create a temporary directory using an object oriented interface. - - $dir = File::Temp->newdir(); - -By default the directory is deleted when the object goes out of scope. - -Supports the same options as the C function. Note that directories -created with this method default to CLEANUP => 1. - - $dir = File::Temp->newdir( $template, %options ); - -=cut - -sub newdir { - my $self = shift; - - # need to handle args as in tempdir because we have to force CLEANUP - # default without passing CLEANUP to tempdir - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); - my %options = @_; - my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 ); - - delete $options{CLEANUP}; - - my $tempdir; - if (defined $template) { - $tempdir = tempdir( $template, %options ); - } else { - $tempdir = tempdir( %options ); - } - return bless { DIRNAME => $tempdir, - CLEANUP => $cleanup, - LAUNCHPID => $$, - }, "File::Temp::Dir"; -} - -=item B - -Return the name of the temporary file associated with this object -(if the object was created using the "new" constructor). - - $filename = $tmp->filename; - -This method is called automatically when the object is used as -a string. - -=cut - -sub filename { - my $self = shift; - return ${*$self}; -} - -sub STRINGIFY { - my $self = shift; - return $self->filename; -} - -=item B - -Return the name of the temporary directory associated with this -object (if the object was created using the "newdir" constructor). - - $dirname = $tmpdir->dirname; - -This method is called automatically when the object is used in string context. - -=item B - -Control whether the file is unlinked when the object goes out of scope. -The file is removed if this value is true and $KEEP_ALL is not. - - $fh->unlink_on_destroy( 1 ); - -Default is for the file to be removed. - -=cut - -sub unlink_on_destroy { - my $self = shift; - if (@_) { - ${*$self}{UNLINK} = shift; - } - return ${*$self}{UNLINK}; -} - -=item B - -When the object goes out of scope, the destructor is called. This -destructor will attempt to unlink the file (using C) -if the constructor was called with UNLINK set to 1 (the default state -if UNLINK is not specified). - -No error is given if the unlink fails. - -If the object has been passed to a child process during a fork, the -file will be deleted when the object goes out of scope in the parent. - -For a temporary directory object the directory will be removed -unless the CLEANUP argument was used in the constructor (and set to -false) or C was modified after creation. - -If the global variable $KEEP_ALL is true, the file or directory -will not be removed. - -=cut - -sub DESTROY { - local($., $@, $!, $^E, $?); - my $self = shift; - - # Make sure we always remove the file from the global hash - # on destruction. This prevents the hash from growing uncontrollably - # and post-destruction there is no reason to know about the file. - my $file = $self->filename; - my $was_created_by_proc; - if (exists $FILES_CREATED_BY_OBJECT{$$}{$file}) { - $was_created_by_proc = 1; - delete $FILES_CREATED_BY_OBJECT{$$}{$file}; - } - - if (${*$self}{UNLINK} && !$KEEP_ALL) { - print "# ---------> Unlinking $self\n" if $DEBUG; - - # only delete if this process created it - return unless $was_created_by_proc; - - # The unlink1 may fail if the file has been closed - # by the caller. This leaves us with the decision - # of whether to refuse to remove the file or simply - # do an unlink without test. Seems to be silly - # to do this when we are trying to be careful - # about security - _force_writable( $file ); # for windows - unlink1( $self, $file ) - or unlink($file); - } -} - -=back - -=head1 FUNCTIONS - -This section describes the recommended interface for generating -temporary files and directories. - -=over 4 - -=item B - -This is the basic function to generate temporary files. -The behaviour of the file can be changed using various options: - - $fh = tempfile(); - ($fh, $filename) = tempfile(); - -Create a temporary file in the directory specified for temporary -files, as specified by the tmpdir() function in L. - - ($fh, $filename) = tempfile($template); - -Create a temporary file in the current directory using the supplied -template. Trailing `X' characters are replaced with random letters to -generate the filename. At least four `X' characters must be present -at the end of the template. - - ($fh, $filename) = tempfile($template, SUFFIX => $suffix) - -Same as previously, except that a suffix is added to the template -after the `X' translation. Useful for ensuring that a temporary -filename has a particular extension when needed by other applications. -But see the WARNING at the end. - - ($fh, $filename) = tempfile($template, DIR => $dir); - -Translates the template as before except that a directory name -is specified. - - ($fh, $filename) = tempfile($template, TMPDIR => 1); - -Equivalent to specifying a DIR of "File::Spec->tmpdir", writing the file -into the same temporary directory as would be used if no template was -specified at all. - - ($fh, $filename) = tempfile($template, UNLINK => 1); - -Return the filename and filehandle as before except that the file is -automatically removed when the program exits (dependent on -$KEEP_ALL). Default is for the file to be removed if a file handle is -requested and to be kept if the filename is requested. In a scalar -context (where no filename is returned) the file is always deleted -either (depending on the operating system) on exit or when it is -closed (unless $KEEP_ALL is true when the temp file is created). - -Use the object-oriented interface if fine-grained control of when -a file is removed is required. - -If the template is not specified, a template is always -automatically generated. This temporary file is placed in tmpdir() -(L) unless a directory is specified explicitly with the -DIR option. - - $fh = tempfile( DIR => $dir ); - -If called in scalar context, only the filehandle is returned and the -file will automatically be deleted when closed on operating systems -that support this (see the description of tmpfile() elsewhere in this -document). This is the preferred mode of operation, as if you only -have a filehandle, you can never create a race condition by fumbling -with the filename. On systems that can not unlink an open file or can -not mark a file as temporary when it is opened (for example, Windows -NT uses the C flag) the file is marked for deletion when -the program ends (equivalent to setting UNLINK to 1). The C -flag is ignored if present. - - (undef, $filename) = tempfile($template, OPEN => 0); - -This will return the filename based on the template but -will not open this file. Cannot be used in conjunction with -UNLINK set to true. Default is to always open the file -to protect from possible race conditions. A warning is issued -if warnings are turned on. Consider using the tmpnam() -and mktemp() functions described elsewhere in this document -if opening the file is not required. - -If the operating system supports it (for example BSD derived systems), the -filehandle will be opened with O_EXLOCK (open with exclusive file lock). -This can sometimes cause problems if the intention is to pass the filename -to another system that expects to take an exclusive lock itself (such as -DBD::SQLite) whilst ensuring that the tempfile is not reused. In this -situation the "EXLOCK" option can be passed to tempfile. By default EXLOCK -will be true (this retains compatibility with earlier releases). - - ($fh, $filename) = tempfile($template, EXLOCK => 0); - -Options can be combined as required. - -Will croak() if there is an error. - -=cut - -sub tempfile { - - # Can not check for argument count since we can have any - # number of args - - # Default options - my %options = ( - "DIR" => undef, # Directory prefix - "SUFFIX" => '', # Template suffix - "UNLINK" => 0, # Do not unlink file on exit - "OPEN" => 1, # Open file - "TMPDIR" => 0, # Place tempfile in tempdir if template specified - "EXLOCK" => 1, # Open file with O_EXLOCK - ); - - # Check to see whether we have an odd or even number of arguments - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); - - # Read the options and merge with defaults - %options = (%options, @_) if @_; - - # First decision is whether or not to open the file - if (! $options{"OPEN"}) { - - warn "tempfile(): temporary filename requested but not opened.\nPossibly unsafe, consider using tempfile() with OPEN set to true\n" - if $^W; - - } - - if ($options{"DIR"} and $^O eq 'VMS') { - - # on VMS turn []foo into [.foo] for concatenation - $options{"DIR"} = VMS::Filespec::vmspath($options{"DIR"}); - } - - # Construct the template - - # Have a choice of trying to work around the mkstemp/mktemp/tmpnam etc - # functions or simply constructing a template and using _gettemp() - # explicitly. Go for the latter - - # First generate a template if not defined and prefix the directory - # If no template must prefix the temp directory - if (defined $template) { - # End up with current directory if neither DIR not TMPDIR are set - if ($options{"DIR"}) { - - $template = File::Spec->catfile($options{"DIR"}, $template); - - } elsif ($options{TMPDIR}) { - - $template = File::Spec->catfile(File::Spec->tmpdir, $template ); - - } - - } else { - - if ($options{"DIR"}) { - - $template = File::Spec->catfile($options{"DIR"}, TEMPXXX); - - } else { - - $template = File::Spec->catfile(File::Spec->tmpdir, TEMPXXX); - - } - - } - - # Now add a suffix - $template .= $options{"SUFFIX"}; - - # Determine whether we should tell _gettemp to unlink the file - # On unix this is irrelevant and can be worked out after the file is - # opened (simply by unlinking the open filehandle). On Windows or VMS - # we have to indicate temporary-ness when we open the file. In general - # we only want a true temporary file if we are returning just the - # filehandle - if the user wants the filename they probably do not - # want the file to disappear as soon as they close it (which may be - # important if they want a child process to use the file) - # For this reason, tie unlink_on_close to the return context regardless - # of OS. - my $unlink_on_close = ( wantarray ? 0 : 1); - - # Create the file - my ($fh, $path, $errstr); - croak "Error in tempfile() using $template: $errstr" - unless (($fh, $path) = _gettemp($template, - "open" => $options{'OPEN'}, - "mkdir"=> 0 , - "unlink_on_close" => $unlink_on_close, - "suffixlen" => length($options{'SUFFIX'}), - "ErrStr" => \$errstr, - "use_exlock" => $options{EXLOCK}, - ) ); - - # Set up an exit handler that can do whatever is right for the - # system. This removes files at exit when requested explicitly or when - # system is asked to unlink_on_close but is unable to do so because - # of OS limitations. - # The latter should be achieved by using a tied filehandle. - # Do not check return status since this is all done with END blocks. - _deferred_unlink($fh, $path, 0) if $options{"UNLINK"}; - - # Return - if (wantarray()) { - - if ($options{'OPEN'}) { - return ($fh, $path); - } else { - return (undef, $path); - } - - } else { - - # Unlink the file. It is up to unlink0 to decide what to do with - # this (whether to unlink now or to defer until later) - unlink0($fh, $path) or croak "Error unlinking file $path using unlink0"; - - # Return just the filehandle. - return $fh; - } - - -} - -=item B - -This is the recommended interface for creation of temporary -directories. By default the directory will not be removed on exit -(that is, it won't be temporary; this behaviour can not be changed -because of issues with backwards compatibility). To enable removal -either use the CLEANUP option which will trigger removal on program -exit, or consider using the "newdir" method in the object interface which -will allow the directory to be cleaned up when the object goes out of -scope. - -The behaviour of the function depends on the arguments: - - $tempdir = tempdir(); - -Create a directory in tmpdir() (see L). - - $tempdir = tempdir( $template ); - -Create a directory from the supplied template. This template is -similar to that described for tempfile(). `X' characters at the end -of the template are replaced with random letters to construct the -directory name. At least four `X' characters must be in the template. - - $tempdir = tempdir ( DIR => $dir ); - -Specifies the directory to use for the temporary directory. -The temporary directory name is derived from an internal template. - - $tempdir = tempdir ( $template, DIR => $dir ); - -Prepend the supplied directory name to the template. The template -should not include parent directory specifications itself. Any parent -directory specifications are removed from the template before -prepending the supplied directory. - - $tempdir = tempdir ( $template, TMPDIR => 1 ); - -Using the supplied template, create the temporary directory in -a standard location for temporary files. Equivalent to doing - - $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); - -but shorter. Parent directory specifications are stripped from the -template itself. The C option is ignored if C is set -explicitly. Additionally, C is implied if neither a template -nor a directory are supplied. - - $tempdir = tempdir( $template, CLEANUP => 1); - -Create a temporary directory using the supplied template, but -attempt to remove it (and all files inside it) when the program -exits. Note that an attempt will be made to remove all files from -the directory even if they were not created by this module (otherwise -why ask to clean it up?). The directory removal is made with -the rmtree() function from the L module. -Of course, if the template is not specified, the temporary directory -will be created in tmpdir() and will also be removed at program exit. - -Will croak() if there is an error. - -=cut - -# ' - -sub tempdir { - - # Can not check for argument count since we can have any - # number of args - - # Default options - my %options = ( - "CLEANUP" => 0, # Remove directory on exit - "DIR" => '', # Root directory - "TMPDIR" => 0, # Use tempdir with template - ); - - # Check to see whether we have an odd or even number of arguments - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); - - # Read the options and merge with defaults - %options = (%options, @_) if @_; - - # Modify or generate the template - - # Deal with the DIR and TMPDIR options - if (defined $template) { - - # Need to strip directory path if using DIR or TMPDIR - if ($options{'TMPDIR'} || $options{'DIR'}) { - - # Strip parent directory from the filename - # - # There is no filename at the end - $template = VMS::Filespec::vmspath($template) if $^O eq 'VMS'; - my ($volume, $directories, undef) = File::Spec->splitpath( $template, 1); - - # Last directory is then our template - $template = (File::Spec->splitdir($directories))[-1]; - - # Prepend the supplied directory or temp dir - if ($options{"DIR"}) { - - $template = File::Spec->catdir($options{"DIR"}, $template); - - } elsif ($options{TMPDIR}) { - - # Prepend tmpdir - $template = File::Spec->catdir(File::Spec->tmpdir, $template); - - } - - } - - } else { - - if ($options{"DIR"}) { - - $template = File::Spec->catdir($options{"DIR"}, TEMPXXX); - - } else { - - $template = File::Spec->catdir(File::Spec->tmpdir, TEMPXXX); - - } - - } - - # Create the directory - my $tempdir; - my $suffixlen = 0; - if ($^O eq 'VMS') { # dir names can end in delimiters - $template =~ m/([\.\]:>]+)$/; - $suffixlen = length($1); - } - if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { - # dir name has a trailing ':' - ++$suffixlen; - } - - my $errstr; - croak "Error in tempdir() using $template: $errstr" - unless ((undef, $tempdir) = _gettemp($template, - "open" => 0, - "mkdir"=> 1 , - "suffixlen" => $suffixlen, - "ErrStr" => \$errstr, - ) ); - - # Install exit handler; must be dynamic to get lexical - if ( $options{'CLEANUP'} && -d $tempdir) { - _deferred_unlink(undef, $tempdir, 1); - } - - # Return the dir name - return $tempdir; - -} - -=back - -=head1 MKTEMP FUNCTIONS - -The following functions are Perl implementations of the -mktemp() family of temp file generation system calls. - -=over 4 - -=item B - -Given a template, returns a filehandle to the temporary file and the name -of the file. - - ($fh, $name) = mkstemp( $template ); - -In scalar context, just the filehandle is returned. - -The template may be any filename with some number of X's appended -to it, for example F. The trailing X's are replaced -with unique alphanumeric combinations. - -Will croak() if there is an error. - -=cut - - - -sub mkstemp { - - croak "Usage: mkstemp(template)" - if scalar(@_) != 1; - - my $template = shift; - - my ($fh, $path, $errstr); - croak "Error in mkstemp using $template: $errstr" - unless (($fh, $path) = _gettemp($template, - "open" => 1, - "mkdir"=> 0 , - "suffixlen" => 0, - "ErrStr" => \$errstr, - ) ); - - if (wantarray()) { - return ($fh, $path); - } else { - return $fh; - } - -} - - -=item B - -Similar to mkstemp(), except that an extra argument can be supplied -with a suffix to be appended to the template. - - ($fh, $name) = mkstemps( $template, $suffix ); - -For example a template of C and suffix of C<.dat> -would generate a file similar to F. - -Returns just the filehandle alone when called in scalar context. - -Will croak() if there is an error. - -=cut - -sub mkstemps { - - croak "Usage: mkstemps(template, suffix)" - if scalar(@_) != 2; - - - my $template = shift; - my $suffix = shift; - - $template .= $suffix; - - my ($fh, $path, $errstr); - croak "Error in mkstemps using $template: $errstr" - unless (($fh, $path) = _gettemp($template, - "open" => 1, - "mkdir"=> 0 , - "suffixlen" => length($suffix), - "ErrStr" => \$errstr, - ) ); - - if (wantarray()) { - return ($fh, $path); - } else { - return $fh; - } - -} - -=item B - -Create a directory from a template. The template must end in -X's that are replaced by the routine. - - $tmpdir_name = mkdtemp($template); - -Returns the name of the temporary directory created. - -Directory must be removed by the caller. - -Will croak() if there is an error. - -=cut - -#' # for emacs - -sub mkdtemp { - - croak "Usage: mkdtemp(template)" - if scalar(@_) != 1; - - my $template = shift; - my $suffixlen = 0; - if ($^O eq 'VMS') { # dir names can end in delimiters - $template =~ m/([\.\]:>]+)$/; - $suffixlen = length($1); - } - if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { - # dir name has a trailing ':' - ++$suffixlen; - } - my ($junk, $tmpdir, $errstr); - croak "Error creating temp directory from template $template\: $errstr" - unless (($junk, $tmpdir) = _gettemp($template, - "open" => 0, - "mkdir"=> 1 , - "suffixlen" => $suffixlen, - "ErrStr" => \$errstr, - ) ); - - return $tmpdir; - -} - -=item B - -Returns a valid temporary filename but does not guarantee -that the file will not be opened by someone else. - - $unopened_file = mktemp($template); - -Template is the same as that required by mkstemp(). - -Will croak() if there is an error. - -=cut - -sub mktemp { - - croak "Usage: mktemp(template)" - if scalar(@_) != 1; - - my $template = shift; - - my ($tmpname, $junk, $errstr); - croak "Error getting name to temp file from template $template: $errstr" - unless (($junk, $tmpname) = _gettemp($template, - "open" => 0, - "mkdir"=> 0 , - "suffixlen" => 0, - "ErrStr" => \$errstr, - ) ); - - return $tmpname; -} - -=back - -=head1 POSIX FUNCTIONS - -This section describes the re-implementation of the tmpnam() -and tmpfile() functions described in L -using the mkstemp() from this module. - -Unlike the L implementations, the directory used -for the temporary file is not specified in a system include -file (C) but simply depends on the choice of tmpdir() -returned by L. On some implementations this -location can be set using the C environment variable, which -may not be secure. -If this is a problem, simply use mkstemp() and specify a template. - -=over 4 - -=item B - -When called in scalar context, returns the full name (including path) -of a temporary file (uses mktemp()). The only check is that the file does -not already exist, but there is no guarantee that that condition will -continue to apply. - - $file = tmpnam(); - -When called in list context, a filehandle to the open file and -a filename are returned. This is achieved by calling mkstemp() -after constructing a suitable template. - - ($fh, $file) = tmpnam(); - -If possible, this form should be used to prevent possible -race conditions. - -See L for information on the choice of temporary -directory for a particular operating system. - -Will croak() if there is an error. - -=cut - -sub tmpnam { - - # Retrieve the temporary directory name - my $tmpdir = File::Spec->tmpdir; - - croak "Error temporary directory is not writable" - if $tmpdir eq ''; - - # Use a ten character template and append to tmpdir - my $template = File::Spec->catfile($tmpdir, TEMPXXX); - - if (wantarray() ) { - return mkstemp($template); - } else { - return mktemp($template); - } - -} - -=item B - -Returns the filehandle of a temporary file. - - $fh = tmpfile(); - -The file is removed when the filehandle is closed or when the program -exits. No access to the filename is provided. - -If the temporary file can not be created undef is returned. -Currently this command will probably not work when the temporary -directory is on an NFS file system. - -Will croak() if there is an error. - -=cut - -sub tmpfile { - - # Simply call tmpnam() in a list context - my ($fh, $file) = tmpnam(); - - # Make sure file is removed when filehandle is closed - # This will fail on NFS - unlink0($fh, $file) - or return undef; - - return $fh; - -} - -=back - -=head1 ADDITIONAL FUNCTIONS - -These functions are provided for backwards compatibility -with common tempfile generation C library functions. - -They are not exported and must be addressed using the full package -name. - -=over 4 - -=item B - -Return the name of a temporary file in the specified directory -using a prefix. The file is guaranteed not to exist at the time -the function was called, but such guarantees are good for one -clock tick only. Always use the proper form of C -with C if you must open such a filename. - - $filename = File::Temp::tempnam( $dir, $prefix ); - -Equivalent to running mktemp() with $dir/$prefixXXXXXXXX -(using unix file convention as an example) - -Because this function uses mktemp(), it can suffer from race conditions. - -Will croak() if there is an error. - -=cut - -sub tempnam { - - croak 'Usage tempnam($dir, $prefix)' unless scalar(@_) == 2; - - my ($dir, $prefix) = @_; - - # Add a string to the prefix - $prefix .= 'XXXXXXXX'; - - # Concatenate the directory to the file - my $template = File::Spec->catfile($dir, $prefix); - - return mktemp($template); - -} - -=back - -=head1 UTILITY FUNCTIONS - -Useful functions for dealing with the filehandle and filename. - -=over 4 - -=item B - -Given an open filehandle and the associated filename, make a safe -unlink. This is achieved by first checking that the filename and -filehandle initially point to the same file and that the number of -links to the file is 1 (all fields returned by stat() are compared). -Then the filename is unlinked and the filehandle checked once again to -verify that the number of links on that file is now 0. This is the -closest you can come to making sure that the filename unlinked was the -same as the file whose descriptor you hold. - - unlink0($fh, $path) - or die "Error unlinking file $path safely"; - -Returns false on error but croaks() if there is a security -anomaly. The filehandle is not closed since on some occasions this is -not required. - -On some platforms, for example Windows NT, it is not possible to -unlink an open file (the file must be closed first). On those -platforms, the actual unlinking is deferred until the program ends and -good status is returned. A check is still performed to make sure that -the filehandle and filename are pointing to the same thing (but not at -the time the end block is executed since the deferred removal may not -have access to the filehandle). - -Additionally, on Windows NT not all the fields returned by stat() can -be compared. For example, the C and C fields seem to be -different. Also, it seems that the size of the file returned by stat() -does not always agree, with C being more accurate than -C, presumably because of caching issues even when -using autoflush (this is usually overcome by waiting a while after -writing to the tempfile before attempting to C it). - -Finally, on NFS file systems the link count of the file handle does -not always go to zero immediately after unlinking. Currently, this -command is expected to fail on NFS disks. - -This function is disabled if the global variable $KEEP_ALL is true -and an unlink on open file is supported. If the unlink is to be deferred -to the END block, the file is still registered for removal. - -This function should not be called if you are using the object oriented -interface since the it will interfere with the object destructor deleting -the file. - -=cut - -sub unlink0 { - - croak 'Usage: unlink0(filehandle, filename)' - unless scalar(@_) == 2; - - # Read args - my ($fh, $path) = @_; - - cmpstat($fh, $path) or return 0; - - # attempt remove the file (does not work on some platforms) - if (_can_unlink_opened_file()) { - - # return early (Without unlink) if we have been instructed to retain files. - return 1 if $KEEP_ALL; - - # XXX: do *not* call this on a directory; possible race - # resulting in recursive removal - croak "unlink0: $path has become a directory!" if -d $path; - unlink($path) or return 0; - - # Stat the filehandle - my @fh = stat $fh; - - print "Link count = $fh[3] \n" if $DEBUG; - - # Make sure that the link count is zero - # - Cygwin provides deferred unlinking, however, - # on Win9x the link count remains 1 - # On NFS the link count may still be 1 but we cant know that - # we are on NFS - return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); - - } else { - _deferred_unlink($fh, $path, 0); - return 1; - } - -} - -=item B - -Compare C of filehandle with C of provided filename. This -can be used to check that the filename and filehandle initially point -to the same file and that the number of links to the file is 1 (all -fields returned by stat() are compared). - - cmpstat($fh, $path) - or die "Error comparing handle with file"; - -Returns false if the stat information differs or if the link count is -greater than 1. Calls croak if there is a security anomaly. - -On certain platforms, for example Windows, not all the fields returned by stat() -can be compared. For example, the C and C fields seem to be -different in Windows. Also, it seems that the size of the file -returned by stat() does not always agree, with C being more -accurate than C, presumably because of caching issues -even when using autoflush (this is usually overcome by waiting a while -after writing to the tempfile before attempting to C it). - -Not exported by default. - -=cut - -sub cmpstat { - - croak 'Usage: cmpstat(filehandle, filename)' - unless scalar(@_) == 2; - - # Read args - my ($fh, $path) = @_; - - warn "Comparing stat\n" - if $DEBUG; - - # Stat the filehandle - which may be closed if someone has manually - # closed the file. Can not turn off warnings without using $^W - # unless we upgrade to 5.006 minimum requirement - my @fh; - { - local ($^W) = 0; - @fh = stat $fh; - } - return unless @fh; - - if ($fh[3] > 1 && $^W) { - carp "unlink0: fstat found too many links; SB=@fh" if $^W; - } - - # Stat the path - my @path = stat $path; - - unless (@path) { - carp "unlink0: $path is gone already" if $^W; - return; - } - - # this is no longer a file, but may be a directory, or worse - unless (-f $path) { - confess "panic: $path is no longer a file: SB=@fh"; - } - - # Do comparison of each member of the array - # On WinNT dev and rdev seem to be different - # depending on whether it is a file or a handle. - # Cannot simply compare all members of the stat return - # Select the ones we can use - my @okstat = (0..$#fh); # Use all by default - if ($^O eq 'MSWin32') { - @okstat = (1,2,3,4,5,7,8,9,10); - } elsif ($^O eq 'os2') { - @okstat = (0, 2..$#fh); - } elsif ($^O eq 'VMS') { # device and file ID are sufficient - @okstat = (0, 1); - } elsif ($^O eq 'dos') { - @okstat = (0,2..7,11..$#fh); - } elsif ($^O eq 'mpeix') { - @okstat = (0..4,8..10); - } - - # Now compare each entry explicitly by number - for (@okstat) { - print "Comparing: $_ : $fh[$_] and $path[$_]\n" if $DEBUG; - # Use eq rather than == since rdev, blksize, and blocks (6, 11, - # and 12) will be '' on platforms that do not support them. This - # is fine since we are only comparing integers. - unless ($fh[$_] eq $path[$_]) { - warn "Did not match $_ element of stat\n" if $DEBUG; - return 0; - } - } - - return 1; -} - -=item B - -Similar to C except after file comparison using cmpstat, the -filehandle is closed prior to attempting to unlink the file. This -allows the file to be removed without using an END block, but does -mean that the post-unlink comparison of the filehandle state provided -by C is not available. - - unlink1($fh, $path) - or die "Error closing and unlinking file"; - -Usually called from the object destructor when using the OO interface. - -Not exported by default. - -This function is disabled if the global variable $KEEP_ALL is true. - -Can call croak() if there is a security anomaly during the stat() -comparison. - -=cut - -sub unlink1 { - croak 'Usage: unlink1(filehandle, filename)' - unless scalar(@_) == 2; - - # Read args - my ($fh, $path) = @_; - - cmpstat($fh, $path) or return 0; - - # Close the file - close( $fh ) or return 0; - - # Make sure the file is writable (for windows) - _force_writable( $path ); - - # return early (without unlink) if we have been instructed to retain files. - return 1 if $KEEP_ALL; - - # remove the file - return unlink($path); -} - -=item B - -Calling this function will cause any temp files or temp directories -that are registered for removal to be removed. This happens automatically -when the process exits but can be triggered manually if the caller is sure -that none of the temp files are required. This method can be registered as -an Apache callback. - -On OSes where temp files are automatically removed when the temp file -is closed, calling this function will have no effect other than to remove -temporary directories (which may include temporary files). - - File::Temp::cleanup(); - -Not exported by default. - -=back - -=head1 PACKAGE VARIABLES - -These functions control the global state of the package. - -=over 4 - -=item B - -Controls the lengths to which the module will go to check the safety of the -temporary file or directory before proceeding. -Options are: - -=over 8 - -=item STANDARD - -Do the basic security measures to ensure the directory exists and is -writable, that temporary files are opened only if they do not already -exist, and that possible race conditions are avoided. Finally the -L function is used to remove files safely. - -=item MEDIUM - -In addition to the STANDARD security, the output directory is checked -to make sure that it is owned either by root or the user running the -program. If the directory is writable by group or by other, it is then -checked to make sure that the sticky bit is set. - -Will not work on platforms that do not support the C<-k> test -for sticky bit. - -=item HIGH - -In addition to the MEDIUM security checks, also check for the -possibility of ``chown() giveaway'' using the L -sysconf() function. If this is a possibility, each directory in the -path is checked in turn for safeness, recursively walking back to the -root directory. - -For platforms that do not support the L -C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is -assumed that ``chown() giveaway'' is possible and the recursive test -is performed. - -=back - -The level can be changed as follows: - - File::Temp->safe_level( File::Temp::HIGH ); - -The level constants are not exported by the module. - -Currently, you must be running at least perl v5.6.0 in order to -run with MEDIUM or HIGH security. This is simply because the -safety tests use functions from L that are not -available in older versions of perl. The problem is that the version -number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though -they are different versions. - -On systems that do not support the HIGH or MEDIUM safety levels -(for example Win NT or OS/2) any attempt to change the level will -be ignored. The decision to ignore rather than raise an exception -allows portable programs to be written with high security in mind -for the systems that can support this without those programs failing -on systems where the extra tests are irrelevant. - -If you really need to see whether the change has been accepted -simply examine the return value of C. - - $newlevel = File::Temp->safe_level( File::Temp::HIGH ); - die "Could not change to high security" - if $newlevel != File::Temp::HIGH; - -=cut - -{ - # protect from using the variable itself - my $LEVEL = STANDARD; - sub safe_level { - my $self = shift; - if (@_) { - my $level = shift; - if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { - carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; - } else { - # Dont allow this on perl 5.005 or earlier - if ($] < 5.006 && $level != STANDARD) { - # Cant do MEDIUM or HIGH checks - croak "Currently requires perl 5.006 or newer to do the safe checks"; - } - # Check that we are allowed to change level - # Silently ignore if we can not. - $LEVEL = $level if _can_do_level($level); - } - } - return $LEVEL; - } -} - -=item TopSystemUID - -This is the highest UID on the current system that refers to a root -UID. This is used to make sure that the temporary directory is -owned by a system UID (C, C, C etc) rather than -simply by root. - -This is required since on many unix systems C is not owned -by root. - -Default is to assume that any UID less than or equal to 10 is a root -UID. - - File::Temp->top_system_uid(10); - my $topid = File::Temp->top_system_uid; - -This value can be adjusted to reduce security checking if required. -The value is only relevant when C is set to MEDIUM or higher. - -=cut - -{ - my $TopSystemUID = 10; - $TopSystemUID = 197108 if $^O eq 'interix'; # "Administrator" - sub top_system_uid { - my $self = shift; - if (@_) { - my $newuid = shift; - croak "top_system_uid: UIDs should be numeric" - unless $newuid =~ /^\d+$/s; - $TopSystemUID = $newuid; - } - return $TopSystemUID; - } -} - -=item B<$KEEP_ALL> - -Controls whether temporary files and directories should be retained -regardless of any instructions in the program to remove them -automatically. This is useful for debugging but should not be used in -production code. - - $File::Temp::KEEP_ALL = 1; - -Default is for files to be removed as requested by the caller. - -In some cases, files will only be retained if this variable is true -when the file is created. This means that you can not create a temporary -file, set this variable and expect the temp file to still be around -when the program exits. - -=item B<$DEBUG> - -Controls whether debugging messages should be enabled. - - $File::Temp::DEBUG = 1; - -Default is for debugging mode to be disabled. - -=back - -=head1 WARNING - -For maximum security, endeavour always to avoid ever looking at, -touching, or even imputing the existence of the filename. You do not -know that that filename is connected to the same file as the handle -you have, and attempts to check this can only trigger more race -conditions. It's far more secure to use the filehandle alone and -dispense with the filename altogether. - -If you need to pass the handle to something that expects a filename -then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary -programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl -programs. You will have to clear the close-on-exec bit on that file -descriptor before passing it to another process. - - use Fcntl qw/F_SETFD F_GETFD/; - fcntl($tmpfh, F_SETFD, 0) - or die "Can't clear close-on-exec flag on temp fh: $!\n"; - -=head2 Temporary files and NFS - -Some problems are associated with using temporary files that reside -on NFS file systems and it is recommended that a local filesystem -is used whenever possible. Some of the security tests will most probably -fail when the temp file is not local. Additionally, be aware that -the performance of I/O operations over NFS will not be as good as for -a local disk. - -=head2 Forking - -In some cases files created by File::Temp are removed from within an -END block. Since END blocks are triggered when a child process exits -(unless C is used by the child) File::Temp takes care -to only remove those temp files created by a particular process ID. This -means that a child will not attempt to remove temp files created by the -parent process. - -If you are forking many processes in parallel that are all creating -temporary files, you may need to reset the random number seed using -srand(EXPR) in each child else all the children will attempt to walk -through the same set of random file names and may well cause -themselves to give up if they exceed the number of retry attempts. - -=head2 Directory removal - -Note that if you have chdir'ed into the temporary directory and it is -subsequently cleaned up (either in the END block or as part of object -destruction), then you will get a warning from File::Path::rmtree(). - -=head2 BINMODE - -The file returned by File::Temp will have been opened in binary mode -if such a mode is available. If that is not correct, use the C -function to change the mode of the filehandle. - -Note that you can modify the encoding of a file opened by File::Temp -also by using C. - -=head1 HISTORY - -Originally began life in May 1999 as an XS interface to the system -mkstemp() function. In March 2000, the OpenBSD mkstemp() code was -translated to Perl for total control of the code's -security checking, to ensure the presence of the function regardless of -operating system and to help with portability. The module was shipped -as a standard part of perl from v5.6.1. - -=head1 SEE ALSO - -L, L, L, L - -See L and L, L for -different implementations of temporary file handling. - -See L for an alternative object-oriented wrapper for -the C function. - -=head1 AUTHOR - -Tim Jenness Etjenness@cpan.orgE - -Copyright (C) 2007-2009 Tim Jenness. -Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and -Astronomy Research Council. All Rights Reserved. This program is free -software; you can redistribute it and/or modify it under the same -terms as Perl itself. - -Original Perl implementation loosely based on the OpenBSD C code for -mkstemp(). Thanks to Tom Christiansen for suggesting that this module -should be written and providing ideas for code improvements and -security enhancements. - -=cut - -package File::Temp::Dir; - -use File::Path qw/ rmtree /; -use strict; -use overload '""' => "STRINGIFY", fallback => 1; - -# private class specifically to support tempdir objects -# created by File::Temp->newdir - -# ostensibly the same method interface as File::Temp but without -# inheriting all the IO::Seekable methods and other cruft - -# Read-only - returns the name of the temp directory - -sub dirname { - my $self = shift; - return $self->{DIRNAME}; -} - -sub STRINGIFY { - my $self = shift; - return $self->dirname; -} - -sub unlink_on_destroy { - my $self = shift; - if (@_) { - $self->{CLEANUP} = shift; - } - return $self->{CLEANUP}; -} - -sub DESTROY { - my $self = shift; - local($., $@, $!, $^E, $?); - if ($self->unlink_on_destroy && - $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { - if (-d $self->{DIRNAME}) { - # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. We protect that and turn it - # into a warning. We do this because this occurs during object - # destruction and so can not be caught by the user. - eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); }; - warn $@ if ($@ && $^W); - } - } -} - - -1; diff --git a/bundled/JSON-PP/JSON/PP.pm b/bundled/JSON-PP/JSON/PP.pm deleted file mode 100644 index c1b4f1b..0000000 --- a/bundled/JSON-PP/JSON/PP.pm +++ /dev/null @@ -1,2799 +0,0 @@ -package JSON::PP; - -# JSON-2.0 - -use 5.005; -use strict; -use base qw(Exporter); -use overload (); - -use Carp (); -use B (); -#use Devel::Peek; - -$JSON::PP::VERSION = '2.27203'; - -@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); - -# instead of hash-access, i tried index-access for speed. -# but this method is not faster than what i expected. so it will be changed. - -use constant P_ASCII => 0; -use constant P_LATIN1 => 1; -use constant P_UTF8 => 2; -use constant P_INDENT => 3; -use constant P_CANONICAL => 4; -use constant P_SPACE_BEFORE => 5; -use constant P_SPACE_AFTER => 6; -use constant P_ALLOW_NONREF => 7; -use constant P_SHRINK => 8; -use constant P_ALLOW_BLESSED => 9; -use constant P_CONVERT_BLESSED => 10; -use constant P_RELAXED => 11; - -use constant P_LOOSE => 12; -use constant P_ALLOW_BIGNUM => 13; -use constant P_ALLOW_BAREKEY => 14; -use constant P_ALLOW_SINGLEQUOTE => 15; -use constant P_ESCAPE_SLASH => 16; -use constant P_AS_NONBLESSED => 17; - -use constant P_ALLOW_UNKNOWN => 18; - -use constant OLD_PERL => $] < 5.008 ? 1 : 0; - -BEGIN { - my @xs_compati_bit_properties = qw( - latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink - allow_blessed convert_blessed relaxed allow_unknown - ); - my @pp_bit_properties = qw( - allow_singlequote allow_bignum loose - allow_barekey escape_slash as_nonblessed - ); - - # Perl version check, Unicode handling is enable? - # Helper module sets @JSON::PP::_properties. - if ($] < 5.008 ) { - my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; - eval qq| require $helper |; - if ($@) { Carp::croak $@; } - } - - for my $name (@xs_compati_bit_properties, @pp_bit_properties) { - my $flag_name = 'P_' . uc($name); - - eval qq/ - sub $name { - my \$enable = defined \$_[1] ? \$_[1] : 1; - - if (\$enable) { - \$_[0]->{PROPS}->[$flag_name] = 1; - } - else { - \$_[0]->{PROPS}->[$flag_name] = 0; - } - - \$_[0]; - } - - sub get_$name { - \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; - } - /; - } - -} - - - -# Functions - -my %encode_allow_method - = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash - allow_blessed convert_blessed indent indent_length allow_bignum - as_nonblessed - /; -my %decode_allow_method - = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum - allow_barekey max_size relaxed/; - - -my $JSON; # cache - -sub encode_json ($) { # encode - ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); -} - - -sub decode_json { # decode - ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); -} - -# Obsoleted - -sub to_json($) { - Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); -} - - -sub from_json($) { - Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); -} - - -# Methods - -sub new { - my $class = shift; - my $self = { - max_depth => 512, - max_size => 0, - indent => 0, - FLAGS => 0, - fallback => sub { encode_error('Invalid value. JSON can only reference.') }, - indent_length => 3, - }; - - bless $self, $class; -} - - -sub encode { - return $_[0]->PP_encode_json($_[1]); -} - - -sub decode { - return $_[0]->PP_decode_json($_[1], 0x00000000); -} - - -sub decode_prefix { - return $_[0]->PP_decode_json($_[1], 0x00000001); -} - - -# accessor - - -# pretty printing - -sub pretty { - my ($self, $v) = @_; - my $enable = defined $v ? $v : 1; - - if ($enable) { # indent_length(3) for JSON::XS compatibility - $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); - } - else { - $self->indent(0)->space_before(0)->space_after(0); - } - - $self; -} - -# etc - -sub max_depth { - my $max = defined $_[1] ? $_[1] : 0x80000000; - $_[0]->{max_depth} = $max; - $_[0]; -} - - -sub get_max_depth { $_[0]->{max_depth}; } - - -sub max_size { - my $max = defined $_[1] ? $_[1] : 0; - $_[0]->{max_size} = $max; - $_[0]; -} - - -sub get_max_size { $_[0]->{max_size}; } - - -sub filter_json_object { - $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; - $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; - $_[0]; -} - -sub filter_json_single_key_object { - if (@_ > 1) { - $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; - } - $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; - $_[0]; -} - -sub indent_length { - if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { - Carp::carp "The acceptable range of indent_length() is 0 to 15."; - } - else { - $_[0]->{indent_length} = $_[1]; - } - $_[0]; -} - -sub get_indent_length { - $_[0]->{indent_length}; -} - -sub sort_by { - $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; - $_[0]; -} - -sub allow_bigint { - Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); -} - -############################### - -### -### Perl => JSON -### - - -{ # Convert - - my $max_depth; - my $indent; - my $ascii; - my $latin1; - my $utf8; - my $space_before; - my $space_after; - my $canonical; - my $allow_blessed; - my $convert_blessed; - - my $indent_length; - my $escape_slash; - my $bignum; - my $as_nonblessed; - - my $depth; - my $indent_count; - my $keysort; - - - sub PP_encode_json { - my $self = shift; - my $obj = shift; - - $indent_count = 0; - $depth = 0; - - my $idx = $self->{PROPS}; - - ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, - $convert_blessed, $escape_slash, $bignum, $as_nonblessed) - = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, - P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; - - ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; - - $keysort = $canonical ? sub { $a cmp $b } : undef; - - if ($self->{sort_by}) { - $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} - : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} - : sub { $a cmp $b }; - } - - encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") - if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); - - my $str = $self->object_to_json($obj); - - $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible - - unless ($ascii or $latin1 or $utf8) { - utf8::upgrade($str); - } - - if ($idx->[ P_SHRINK ]) { - utf8::downgrade($str, 1); - } - - return $str; - } - - - sub object_to_json { - my ($self, $obj) = @_; - my $type = ref($obj); - - if($type eq 'HASH'){ - return $self->hash_to_json($obj); - } - elsif($type eq 'ARRAY'){ - return $self->array_to_json($obj); - } - elsif ($type) { # blessed object? - if (blessed($obj)) { - - return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); - - if ( $convert_blessed and $obj->can('TO_JSON') ) { - my $result = $obj->TO_JSON(); - if ( defined $result and ref( $result ) ) { - if ( refaddr( $obj ) eq refaddr( $result ) ) { - encode_error( sprintf( - "%s::TO_JSON method returned same object as was passed instead of a new one", - ref $obj - ) ); - } - } - - return $self->object_to_json( $result ); - } - - return "$obj" if ( $bignum and _is_bignum($obj) ); - return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. - - encode_error( sprintf("encountered object '%s', but neither allow_blessed " - . "nor convert_blessed settings are enabled", $obj) - ) unless ($allow_blessed); - - return 'null'; - } - else { - return $self->value_to_json($obj); - } - } - else{ - return $self->value_to_json($obj); - } - } - - - sub hash_to_json { - my ($self, $obj) = @_; - my @res; - - encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") - if (++$depth > $max_depth); - - my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); - my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); - - for my $k ( _sort( $obj ) ) { - if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized - push @res, string_to_json( $self, $k ) - . $del - . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); - } - - --$depth; - $self->_down_indent() if ($indent); - - return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; - } - - - sub array_to_json { - my ($self, $obj) = @_; - my @res; - - encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") - if (++$depth > $max_depth); - - my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); - - for my $v (@$obj){ - push @res, $self->object_to_json($v) || $self->value_to_json($v); - } - - --$depth; - $self->_down_indent() if ($indent); - - return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; - } - - - sub value_to_json { - my ($self, $value) = @_; - - return 'null' if(!defined $value); - - my $b_obj = B::svref_2object(\$value); # for round trip problem - my $flags = $b_obj->FLAGS; - - return $value # as is - if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? - - my $type = ref($value); - - if(!$type){ - return string_to_json($self, $value); - } - elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ - return $$value == 1 ? 'true' : 'false'; - } - elsif ($type) { - if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { - return $self->value_to_json("$value"); - } - - if ($type eq 'SCALAR' and defined $$value) { - return $$value eq '1' ? 'true' - : $$value eq '0' ? 'false' - : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' - : encode_error("cannot encode reference to scalar"); - } - - if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { - return 'null'; - } - else { - if ( $type eq 'SCALAR' or $type eq 'REF' ) { - encode_error("cannot encode reference to scalar"); - } - else { - encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); - } - } - - } - else { - return $self->{fallback}->($value) - if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); - return 'null'; - } - - } - - - my %esc = ( - "\n" => '\n', - "\r" => '\r', - "\t" => '\t', - "\f" => '\f', - "\b" => '\b', - "\"" => '\"', - "\\" => '\\\\', - "\'" => '\\\'', - ); - - - sub string_to_json { - my ($self, $arg) = @_; - - $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; - $arg =~ s/\//\\\//g if ($escape_slash); - $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; - - if ($ascii) { - $arg = JSON_PP_encode_ascii($arg); - } - - if ($latin1) { - $arg = JSON_PP_encode_latin1($arg); - } - - if ($utf8) { - utf8::encode($arg); - } - - return '"' . $arg . '"'; - } - - - sub blessed_to_json { - my $reftype = reftype($_[1]) || ''; - if ($reftype eq 'HASH') { - return $_[0]->hash_to_json($_[1]); - } - elsif ($reftype eq 'ARRAY') { - return $_[0]->array_to_json($_[1]); - } - else { - return 'null'; - } - } - - - sub encode_error { - my $error = shift; - Carp::croak "$error"; - } - - - sub _sort { - defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; - } - - - sub _up_indent { - my $self = shift; - my $space = ' ' x $indent_length; - - my ($pre,$post) = ('',''); - - $post = "\n" . $space x $indent_count; - - $indent_count++; - - $pre = "\n" . $space x $indent_count; - - return ($pre,$post); - } - - - sub _down_indent { $indent_count--; } - - - sub PP_encode_box { - { - depth => $depth, - indent_count => $indent_count, - }; - } - -} # Convert - - -sub _encode_ascii { - join('', - map { - $_ <= 127 ? - chr($_) : - $_ <= 65535 ? - sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); - } unpack('U*', $_[0]) - ); -} - - -sub _encode_latin1 { - join('', - map { - $_ <= 255 ? - chr($_) : - $_ <= 65535 ? - sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); - } unpack('U*', $_[0]) - ); -} - - -sub _encode_surrogates { # from perlunicode - my $uni = $_[0] - 0x10000; - return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); -} - - -sub _is_bignum { - $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); -} - - - -# -# JSON => Perl -# - -my $max_intsize; - -BEGIN { - my $checkint = 1111; - for my $d (5..64) { - $checkint .= 1; - my $int = eval qq| $checkint |; - if ($int =~ /[eE]/) { - $max_intsize = $d - 1; - last; - } - } -} - -{ # PARSE - - my %escapes = ( # by Jeremy Muhlich - b => "\x8", - t => "\x9", - n => "\xA", - f => "\xC", - r => "\xD", - '\\' => '\\', - '"' => '"', - '/' => '/', - ); - - my $text; # json data - my $at; # offset - my $ch; # 1chracter - my $len; # text length (changed according to UTF8 or NON UTF8) - # INTERNAL - my $depth; # nest counter - my $encoding; # json text encoding - my $is_valid_utf8; # temp variable - my $utf8_len; # utf8 byte length - # FLAGS - my $utf8; # must be utf8 - my $max_depth; # max nest nubmer of objects and arrays - my $max_size; - my $relaxed; - my $cb_object; - my $cb_sk_object; - - my $F_HOOK; - - my $allow_bigint; # using Math::BigInt - my $singlequote; # loosely quoting - my $loose; # - my $allow_barekey; # bareKey - - # $opt flag - # 0x00000001 .... decode_prefix - # 0x10000000 .... incr_parse - - sub PP_decode_json { - my ($self, $opt); # $opt is an effective flag during this decode_json. - - ($self, $text, $opt) = @_; - - ($at, $ch, $depth) = (0, '', 0); - - if ( !defined $text or ref $text ) { - decode_error("malformed JSON string, neither array, object, number, string or atom"); - } - - my $idx = $self->{PROPS}; - - ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) - = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; - - if ( $utf8 ) { - utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); - } - else { - utf8::upgrade( $text ); - } - - $len = length $text; - - ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) - = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; - - if ($max_size > 1) { - use bytes; - my $bytes = length $text; - decode_error( - sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" - , $bytes, $max_size), 1 - ) if ($bytes > $max_size); - } - - # Currently no effect - # should use regexp - my @octets = unpack('C4', $text); - $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' - : (!$octets[0] and $octets[1]) ? 'UTF-16BE' - : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' - : ( $octets[2] ) ? 'UTF-16LE' - : (!$octets[2] ) ? 'UTF-32LE' - : 'unknown'; - - white(); # remove head white space - - my $valid_start = defined $ch; # Is there a first character for JSON structure? - - my $result = value(); - - return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse - - decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; - - if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { - decode_error( - 'JSON text must be an object or array (but found number, string, true, false or null,' - . ' use allow_nonref to allow this)', 1); - } - - Carp::croak('something wrong.') if $len < $at; # we won't arrive here. - - my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length - - white(); # remove tail white space - - if ( $ch ) { - return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix - decode_error("garbage after JSON object"); - } - - ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; - } - - - sub next_chr { - return $ch = undef if($at >= $len); - $ch = substr($text, $at++, 1); - } - - - sub value { - white(); - return if(!defined $ch); - return object() if($ch eq '{'); - return array() if($ch eq '['); - return string() if($ch eq '"' or ($singlequote and $ch eq "'")); - return number() if($ch =~ /[0-9]/ or $ch eq '-'); - return word(); - } - - sub string { - my ($i, $s, $t, $u); - my $utf16; - my $is_utf8; - - ($is_valid_utf8, $utf8_len) = ('', 0); - - $s = ''; # basically UTF8 flag on - - if($ch eq '"' or ($singlequote and $ch eq "'")){ - my $boundChar = $ch; - - OUTER: while( defined(next_chr()) ){ - - if($ch eq $boundChar){ - next_chr(); - - if ($utf16) { - decode_error("missing low surrogate character in surrogate pair"); - } - - utf8::decode($s) if($is_utf8); - - return $s; - } - elsif($ch eq '\\'){ - next_chr(); - if(exists $escapes{$ch}){ - $s .= $escapes{$ch}; - } - elsif($ch eq 'u'){ # UNICODE handling - my $u = ''; - - for(1..4){ - $ch = next_chr(); - last OUTER if($ch !~ /[0-9a-fA-F]/); - $u .= $ch; - } - - # U+D800 - U+DBFF - if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? - $utf16 = $u; - } - # U+DC00 - U+DFFF - elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? - unless (defined $utf16) { - decode_error("missing high surrogate character in surrogate pair"); - } - $is_utf8 = 1; - $s .= JSON_PP_decode_surrogates($utf16, $u) || next; - $utf16 = undef; - } - else { - if (defined $utf16) { - decode_error("surrogate pair expected"); - } - - if ( ( my $hex = hex( $u ) ) > 127 ) { - $is_utf8 = 1; - $s .= JSON_PP_decode_unicode($u) || next; - } - else { - $s .= chr $hex; - } - } - - } - else{ - unless ($loose) { - $at -= 2; - decode_error('illegal backslash escape sequence in string'); - } - $s .= $ch; - } - } - else{ - - if ( ord $ch > 127 ) { - if ( $utf8 ) { - unless( $ch = is_valid_utf8($ch) ) { - $at -= 1; - decode_error("malformed UTF-8 character in JSON string"); - } - else { - $at += $utf8_len - 1; - } - } - else { - utf8::encode( $ch ); - } - - $is_utf8 = 1; - } - - if (!$loose) { - if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok - $at--; - decode_error('invalid character encountered while parsing JSON string'); - } - } - - $s .= $ch; - } - } - } - - decode_error("unexpected end of string while parsing JSON string"); - } - - - sub white { - while( defined $ch ){ - if($ch le ' '){ - next_chr(); - } - elsif($ch eq '/'){ - next_chr(); - if(defined $ch and $ch eq '/'){ - 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); - } - elsif(defined $ch and $ch eq '*'){ - next_chr(); - while(1){ - if(defined $ch){ - if($ch eq '*'){ - if(defined(next_chr()) and $ch eq '/'){ - next_chr(); - last; - } - } - else{ - next_chr(); - } - } - else{ - decode_error("Unterminated comment"); - } - } - next; - } - else{ - $at--; - decode_error("malformed JSON string, neither array, object, number, string or atom"); - } - } - else{ - if ($relaxed and $ch eq '#') { # correctly? - pos($text) = $at; - $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; - $at = pos($text); - next_chr; - next; - } - - last; - } - } - } - - - sub array { - my $a = $_[0] || []; # you can use this code to use another array ref object. - - decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') - if (++$depth > $max_depth); - - next_chr(); - white(); - - if(defined $ch and $ch eq ']'){ - --$depth; - next_chr(); - return $a; - } - else { - while(defined($ch)){ - push @$a, value(); - - white(); - - if (!defined $ch) { - last; - } - - if($ch eq ']'){ - --$depth; - next_chr(); - return $a; - } - - if($ch ne ','){ - last; - } - - next_chr(); - white(); - - if ($relaxed and $ch eq ']') { - --$depth; - next_chr(); - return $a; - } - - } - } - - decode_error(", or ] expected while parsing array"); - } - - - sub object { - my $o = $_[0] || {}; # you can use this code to use another hash ref object. - my $k; - - decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') - if (++$depth > $max_depth); - next_chr(); - white(); - - if(defined $ch and $ch eq '}'){ - --$depth; - next_chr(); - if ($F_HOOK) { - return _json_object_hook($o); - } - return $o; - } - else { - while (defined $ch) { - $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); - white(); - - if(!defined $ch or $ch ne ':'){ - $at--; - decode_error("':' expected"); - } - - next_chr(); - $o->{$k} = value(); - white(); - - last if (!defined $ch); - - if($ch eq '}'){ - --$depth; - next_chr(); - if ($F_HOOK) { - return _json_object_hook($o); - } - return $o; - } - - if($ch ne ','){ - last; - } - - next_chr(); - white(); - - if ($relaxed and $ch eq '}') { - --$depth; - next_chr(); - if ($F_HOOK) { - return _json_object_hook($o); - } - return $o; - } - - } - - } - - $at--; - decode_error(", or } expected while parsing object/hash"); - } - - - sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition - my $key; - while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ - $key .= $ch; - next_chr(); - } - return $key; - } - - - sub word { - my $word = substr($text,$at-1,4); - - if($word eq 'true'){ - $at += 3; - next_chr; - return $JSON::PP::true; - } - elsif($word eq 'null'){ - $at += 3; - next_chr; - return undef; - } - elsif($word eq 'fals'){ - $at += 3; - if(substr($text,$at,1) eq 'e'){ - $at++; - next_chr; - return $JSON::PP::false; - } - } - - $at--; # for decode_error report - - decode_error("'null' expected") if ($word =~ /^n/); - decode_error("'true' expected") if ($word =~ /^t/); - decode_error("'false' expected") if ($word =~ /^f/); - decode_error("malformed JSON string, neither array, object, number, string or atom"); - } - - - sub number { - my $n = ''; - my $v; - - # According to RFC4627, hex or oct digts are invalid. - if($ch eq '0'){ - my $peek = substr($text,$at,1); - my $hex = $peek =~ /[xX]/; # 0 or 1 - - if($hex){ - decode_error("malformed number (leading zero must not be followed by another digit)"); - ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); - } - else{ # oct - ($n) = ( substr($text, $at) =~ /^([0-7]+)/); - if (defined $n and length $n > 1) { - decode_error("malformed number (leading zero must not be followed by another digit)"); - } - } - - if(defined $n and length($n)){ - if (!$hex and length($n) == 1) { - decode_error("malformed number (leading zero must not be followed by another digit)"); - } - $at += length($n) + $hex; - next_chr; - return $hex ? hex($n) : oct($n); - } - } - - if($ch eq '-'){ - $n = '-'; - next_chr; - if (!defined $ch or $ch !~ /\d/) { - decode_error("malformed number (no digits after initial minus)"); - } - } - - while(defined $ch and $ch =~ /\d/){ - $n .= $ch; - next_chr; - } - - if(defined $ch and $ch eq '.'){ - $n .= '.'; - - next_chr; - if (!defined $ch or $ch !~ /\d/) { - decode_error("malformed number (no digits after decimal point)"); - } - else { - $n .= $ch; - } - - while(defined(next_chr) and $ch =~ /\d/){ - $n .= $ch; - } - } - - if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ - $n .= $ch; - next_chr; - - if(defined($ch) and ($ch eq '+' or $ch eq '-')){ - $n .= $ch; - next_chr; - if (!defined $ch or $ch =~ /\D/) { - decode_error("malformed number (no digits after exp sign)"); - } - $n .= $ch; - } - elsif(defined($ch) and $ch =~ /\d/){ - $n .= $ch; - } - else { - decode_error("malformed number (no digits after exp sign)"); - } - - while(defined(next_chr) and $ch =~ /\d/){ - $n .= $ch; - } - - } - - $v .= $n; - - if ($v !~ /[.eE]/ and length $v > $max_intsize) { - if ($allow_bigint) { # from Adam Sussman - require Math::BigInt; - return Math::BigInt->new($v); - } - else { - return "$v"; - } - } - elsif ($allow_bigint) { - require Math::BigFloat; - return Math::BigFloat->new($v); - } - - return 0+$v; - } - - - sub is_valid_utf8 { - - $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 - : $_[0] =~ /[\xC2-\xDF]/ ? 2 - : $_[0] =~ /[\xE0-\xEF]/ ? 3 - : $_[0] =~ /[\xF0-\xF4]/ ? 4 - : 0 - ; - - return unless $utf8_len; - - my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); - - return ( $is_valid_utf8 =~ /^(?: - [\x00-\x7F] - |[\xC2-\xDF][\x80-\xBF] - |[\xE0][\xA0-\xBF][\x80-\xBF] - |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] - |[\xED][\x80-\x9F][\x80-\xBF] - |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] - |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] - |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] - |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] - )$/x ) ? $is_valid_utf8 : ''; - } - - - sub decode_error { - my $error = shift; - my $no_rep = shift; - my $str = defined $text ? substr($text, $at) : ''; - my $mess = ''; - my $type = $] >= 5.008 ? 'U*' - : $] < 5.006 ? 'C*' - : utf8::is_utf8( $str ) ? 'U*' # 5.6 - : 'C*' - ; - - for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? - $mess .= $c == 0x07 ? '\a' - : $c == 0x09 ? '\t' - : $c == 0x0a ? '\n' - : $c == 0x0d ? '\r' - : $c == 0x0c ? '\f' - : $c < 0x20 ? sprintf('\x{%x}', $c) - : $c == 0x5c ? '\\\\' - : $c < 0x80 ? chr($c) - : sprintf('\x{%x}', $c) - ; - if ( length $mess >= 20 ) { - $mess .= '...'; - last; - } - } - - unless ( length $mess ) { - $mess = '(end of string)'; - } - - Carp::croak ( - $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" - ); - - } - - - sub _json_object_hook { - my $o = $_[0]; - my @ks = keys %{$o}; - - if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { - my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); - if (@val == 1) { - return $val[0]; - } - } - - my @val = $cb_object->($o) if ($cb_object); - if (@val == 0 or @val > 1) { - return $o; - } - else { - return $val[0]; - } - } - - - sub PP_decode_box { - { - text => $text, - at => $at, - ch => $ch, - len => $len, - depth => $depth, - encoding => $encoding, - is_valid_utf8 => $is_valid_utf8, - }; - } - -} # PARSE - - -sub _decode_surrogates { # from perlunicode - my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); - my $un = pack('U*', $uni); - utf8::encode( $un ); - return $un; -} - - -sub _decode_unicode { - my $un = pack('U', hex shift); - utf8::encode( $un ); - return $un; -} - -# -# Setup for various Perl versions (the code from JSON::PP58) -# - -BEGIN { - - unless ( defined &utf8::is_utf8 ) { - require Encode; - *utf8::is_utf8 = *Encode::is_utf8; - } - - if ( $] >= 5.008 ) { - *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; - *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; - *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; - *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; - } - - if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. - package JSON::PP; - require subs; - subs->import('join'); - eval q| - sub join { - return '' if (@_ < 2); - my $j = shift; - my $str = shift; - for (@_) { $str .= $j . $_; } - return $str; - } - |; - } - - - sub JSON::PP::incr_parse { - local $Carp::CarpLevel = 1; - ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); - } - - - sub JSON::PP::incr_skip { - ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; - } - - - sub JSON::PP::incr_reset { - ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; - } - - eval q{ - sub JSON::PP::incr_text : lvalue { - $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; - - if ( $_[0]->{_incr_parser}->{incr_parsing} ) { - Carp::croak("incr_text can not be called when the incremental parser already started parsing"); - } - $_[0]->{_incr_parser}->{incr_text}; - } - } if ( $] >= 5.006 ); - -} # Setup for various Perl versions (the code from JSON::PP58) - - -############################### -# Utilities -# - -BEGIN { - eval 'require Scalar::Util'; - unless($@){ - *JSON::PP::blessed = \&Scalar::Util::blessed; - *JSON::PP::reftype = \&Scalar::Util::reftype; - *JSON::PP::refaddr = \&Scalar::Util::refaddr; - } - else{ # This code is from Sclar::Util. - # warn $@; - eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; - *JSON::PP::blessed = sub { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; - }; - my %tmap = qw( - B::NULL SCALAR - B::HV HASH - B::AV ARRAY - B::CV CODE - B::IO IO - B::GV GLOB - B::REGEXP REGEXP - ); - *JSON::PP::reftype = sub { - my $r = shift; - - return undef unless length(ref($r)); - - my $t = ref(B::svref_2object($r)); - - return - exists $tmap{$t} ? $tmap{$t} - : length(ref($$r)) ? 'REF' - : 'SCALAR'; - }; - *JSON::PP::refaddr = sub { - return undef unless length(ref($_[0])); - - my $addr; - if(defined(my $pkg = blessed($_[0]))) { - $addr .= bless $_[0], 'Scalar::Util::Fake'; - bless $_[0], $pkg; - } - else { - $addr .= $_[0] - } - - $addr =~ /0x(\w+)/; - local $^W; - #no warnings 'portable'; - hex($1); - } - } -} - - -# shamely copied and modified from JSON::XS code. - -$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; -$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; - -sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } - -sub true { $JSON::PP::true } -sub false { $JSON::PP::false } -sub null { undef; } - -############################### - -package JSON::PP::Boolean; - -use overload ( - "0+" => sub { ${$_[0]} }, - "++" => sub { $_[0] = ${$_[0]} + 1 }, - "--" => sub { $_[0] = ${$_[0]} - 1 }, - fallback => 1, -); - - -############################### - -package JSON::PP::IncrParser; - -use strict; - -use constant INCR_M_WS => 0; # initial whitespace skipping -use constant INCR_M_STR => 1; # inside string -use constant INCR_M_BS => 2; # inside backslash -use constant INCR_M_JSON => 3; # outside anything, count nesting -use constant INCR_M_C0 => 4; -use constant INCR_M_C1 => 5; - -$JSON::PP::IncrParser::VERSION = '1.01'; - -my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; - -sub new { - my ( $class ) = @_; - - bless { - incr_nest => 0, - incr_text => undef, - incr_parsing => 0, - incr_p => 0, - }, $class; -} - - -sub incr_parse { - my ( $self, $coder, $text ) = @_; - - $self->{incr_text} = '' unless ( defined $self->{incr_text} ); - - if ( defined $text ) { - if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { - utf8::upgrade( $self->{incr_text} ) ; - utf8::decode( $self->{incr_text} ) ; - } - $self->{incr_text} .= $text; - } - - - my $max_size = $coder->get_max_size; - - if ( defined wantarray ) { - - $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; - - if ( wantarray ) { - my @ret; - - $self->{incr_parsing} = 1; - - do { - push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); - - unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { - $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; - } - - } until ( length $self->{incr_text} >= $self->{incr_p} ); - - $self->{incr_parsing} = 0; - - return @ret; - } - else { # in scalar context - $self->{incr_parsing} = 1; - my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); - $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans - return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. - } - - } - -} - - -sub _incr_parse { - my ( $self, $coder, $text, $skip ) = @_; - my $p = $self->{incr_p}; - my $restore = $p; - - my @obj; - my $len = length $text; - - if ( $self->{incr_mode} == INCR_M_WS ) { - while ( $len > $p ) { - my $s = substr( $text, $p, 1 ); - $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); - $self->{incr_mode} = INCR_M_JSON; - last; - } - } - - while ( $len > $p ) { - my $s = substr( $text, $p++, 1 ); - - if ( $s eq '"' ) { - if (substr( $text, $p - 2, 1 ) eq '\\' ) { - next; - } - - if ( $self->{incr_mode} != INCR_M_STR ) { - $self->{incr_mode} = INCR_M_STR; - } - else { - $self->{incr_mode} = INCR_M_JSON; - unless ( $self->{incr_nest} ) { - last; - } - } - } - - if ( $self->{incr_mode} == INCR_M_JSON ) { - - if ( $s eq '[' or $s eq '{' ) { - if ( ++$self->{incr_nest} > $coder->get_max_depth ) { - Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); - } - } - elsif ( $s eq ']' or $s eq '}' ) { - last if ( --$self->{incr_nest} <= 0 ); - } - elsif ( $s eq '#' ) { - while ( $len > $p ) { - last if substr( $text, $p++, 1 ) eq "\n"; - } - } - - } - - } - - $self->{incr_p} = $p; - - return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); - return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); - - return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); - - local $Carp::CarpLevel = 2; - - $self->{incr_p} = $restore; - $self->{incr_c} = $p; - - my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); - - $self->{incr_text} = substr( $self->{incr_text}, $p ); - $self->{incr_p} = 0; - - return $obj || ''; -} - - -sub incr_text { - if ( $_[0]->{incr_parsing} ) { - Carp::croak("incr_text can not be called when the incremental parser already started parsing"); - } - $_[0]->{incr_text}; -} - - -sub incr_skip { - my $self = shift; - $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); - $self->{incr_p} = 0; -} - - -sub incr_reset { - my $self = shift; - $self->{incr_text} = undef; - $self->{incr_p} = 0; - $self->{incr_mode} = 0; - $self->{incr_nest} = 0; - $self->{incr_parsing} = 0; -} - -############################### - - -1; -__END__ -=pod - -=head1 NAME - -JSON::PP - JSON::XS compatible pure-Perl module. - -=head1 SYNOPSIS - - use JSON::PP; - - # exported functions, they croak on error - # and expect/generate UTF-8 - - $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; - $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; - - # OO-interface - - $coder = JSON::PP->new->ascii->pretty->allow_nonref; - - $json_text = $json->encode( $perl_scalar ); - $perl_scalar = $json->decode( $json_text ); - - $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing - - # Note that JSON version 2.0 and above will automatically use - # JSON::XS or JSON::PP, so you should be able to just: - - use JSON; - - -=head1 VERSION - - 2.27202 - -L 2.27 (~2.30) compatible. - -=head1 NOTE - -JSON::PP had been inculded in JSON distribution (CPAN module). -It was a perl core module in Perl 5.14. - -=head1 DESCRIPTION - -This module is L compatible pure Perl module. -(Perl 5.8 or later is recommended) - -JSON::XS is the fastest and most proper JSON module on CPAN. -It is written by Marc Lehmann in C, so must be compiled and -installed in the used environment. - -JSON::PP is a pure-Perl module and has compatibility to JSON::XS. - - -=head2 FEATURES - -=over - -=item * correct unicode handling - -This module knows how to handle Unicode (depending on Perl version). - -See to L and L. - - -=item * round-trip integrity - -When you serialise a perl data structure using only data types supported -by JSON and Perl, the deserialised data structure is identical on the Perl -level. (e.g. the string "2.0" doesn't suddenly become "2" just because -it looks like a number). There I minor exceptions to this, read the -MAPPING section below to learn about those. - - -=item * strict checking of JSON correctness - -There is no guessing, no generating of illegal JSON texts by default, -and only JSON is accepted as input by default (the latter is a security feature). -But when some options are set, loose chcking features are available. - -=back - -=head1 FUNCTIONAL INTERFACE - -Some documents are copied and modified from L. - -=head2 encode_json - - $json_text = encode_json $perl_scalar - -Converts the given Perl data structure to a UTF-8 encoded, binary string. - -This function call is functionally identical to: - - $json_text = JSON::PP->new->utf8->encode($perl_scalar) - -=head2 decode_json - - $perl_scalar = decode_json $json_text - -The opposite of C: expects an UTF-8 (binary) string and tries -to parse that as an UTF-8 encoded JSON text, returning the resulting -reference. - -This function call is functionally identical to: - - $perl_scalar = JSON::PP->new->utf8->decode($json_text) - -=head2 JSON::PP::is_bool - - $is_boolean = JSON::PP::is_bool($scalar) - -Returns true if the passed scalar represents either JSON::PP::true or -JSON::PP::false, two constants that act like C<1> and C<0> respectively -and are also used to represent JSON C and C in Perl strings. - -=head2 JSON::PP::true - -Returns JSON true value which is blessed object. -It C JSON::PP::Boolean object. - -=head2 JSON::PP::false - -Returns JSON false value which is blessed object. -It C JSON::PP::Boolean object. - -=head2 JSON::PP::null - -Returns C. - -See L, below, for more information on how JSON values are mapped to -Perl. - - -=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER - -This section supposes that your perl vresion is 5.8 or later. - -If you know a JSON text from an outer world - a network, a file content, and so on, -is encoded in UTF-8, you should use C or C module object -with C enable. And the decoded result will contain UNICODE characters. - - # from network - my $json = JSON::PP->new->utf8; - my $json_text = CGI->new->param( 'json_data' ); - my $perl_scalar = $json->decode( $json_text ); - - # from file content - local $/; - open( my $fh, '<', 'json.data' ); - $json_text = <$fh>; - $perl_scalar = decode_json( $json_text ); - -If an outer data is not encoded in UTF-8, firstly you should C it. - - use Encode; - local $/; - open( my $fh, '<', 'json.data' ); - my $encoding = 'cp932'; - my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE - - # or you can write the below code. - # - # open( my $fh, "<:encoding($encoding)", 'json.data' ); - # $unicode_json_text = <$fh>; - -In this case, C<$unicode_json_text> is of course UNICODE string. -So you B use C nor C module object with C enable. -Instead of them, you use C module object with C disable. - - $perl_scalar = $json->utf8(0)->decode( $unicode_json_text ); - -Or C and C: - - $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) ); - # this way is not efficient. - -And now, you want to convert your C<$perl_scalar> into JSON data and -send it to an outer world - a network or a file content, and so on. - -Your data usually contains UNICODE strings and you want the converted data to be encoded -in UTF-8, you should use C or C module object with C enable. - - print encode_json( $perl_scalar ); # to a network? file? or display? - # or - print $json->utf8->encode( $perl_scalar ); - -If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings -for some reason, then its characters are regarded as B for perl -(because it does not concern with your $encoding). -You B use C nor C module object with C enable. -Instead of them, you use C module object with C disable. -Note that the resulted text is a UNICODE string but no problem to print it. - - # $perl_scalar contains $encoding encoded string values - $unicode_json_text = $json->utf8(0)->encode( $perl_scalar ); - # $unicode_json_text consists of characters less than 0x100 - print $unicode_json_text; - -Or C all string values and C: - - $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } ); - # ... do it to each string values, then encode_json - $json_text = encode_json( $perl_scalar ); - -This method is a proper way but probably not efficient. - -See to L, L. - - -=head1 METHODS - -Basically, check to L or L. - -=head2 new - - $json = JSON::PP->new - -Rturns a new JSON::PP object that can be used to de/encode JSON -strings. - -All boolean flags described below are by default I. - -The mutators for flags all return the JSON object again and thus calls can -be chained: - - my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) - => {"a": [1, 2]} - -=head2 ascii - - $json = $json->ascii([$enable]) - - $enabled = $json->get_ascii - -If $enable is true (or missing), then the encode method will not generate characters outside -the code range 0..127. Any Unicode characters outside that range will be escaped using either -a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. -(See to L). - -In Perl 5.005, there is no character having high value (more than 255). -See to L. - -If $enable is false, then the encode method will not escape Unicode characters unless -required by the JSON syntax or other flags. This results in a faster and more compact format. - - JSON::PP->new->ascii(1)->encode([chr 0x10401]) - => ["\ud801\udc01"] - -=head2 latin1 - - $json = $json->latin1([$enable]) - - $enabled = $json->get_latin1 - -If $enable is true (or missing), then the encode method will encode the resulting JSON -text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. - -If $enable is false, then the encode method will not escape Unicode characters -unless required by the JSON syntax or other flags. - - JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] - => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) - -See to L. - -=head2 utf8 - - $json = $json->utf8([$enable]) - - $enabled = $json->get_utf8 - -If $enable is true (or missing), then the encode method will encode the JSON result -into UTF-8, as required by many protocols, while the decode method expects to be handled -an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any -characters outside the range 0..255, they are thus useful for bytewise/binary I/O. - -(In Perl 5.005, any character outside the range 0..255 does not exist. -See to L.) - -In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 -encoding families, as described in RFC4627. - -If $enable is false, then the encode method will return the JSON string as a (non-encoded) -Unicode string, while decode expects thus a Unicode string. Any decoding or encoding -(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. - -Example, output UTF-16BE-encoded JSON: - - use Encode; - $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); - -Example, decode UTF-32LE-encoded JSON: - - use Encode; - $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); - - -=head2 pretty - - $json = $json->pretty([$enable]) - -This enables (or disables) all of the C, C and -C flags in one call to generate the most readable -(or most compact) form possible. - -Equivalent to: - - $json->indent->space_before->space_after - -=head2 indent - - $json = $json->indent([$enable]) - - $enabled = $json->get_indent - -The default indent space length is three. -You can use C to change the length. - -=head2 space_before - - $json = $json->space_before([$enable]) - - $enabled = $json->get_space_before - -If C<$enable> is true (or missing), then the C method will add an extra -optional space before the C<:> separating keys from values in JSON objects. - -If C<$enable> is false, then the C method will not add any extra -space at those places. - -This setting has no effect when decoding JSON texts. - -Example, space_before enabled, space_after and indent disabled: - - {"key" :"value"} - -=head2 space_after - - $json = $json->space_after([$enable]) - - $enabled = $json->get_space_after - -If C<$enable> is true (or missing), then the C method will add an extra -optional space after the C<:> separating keys from values in JSON objects -and extra whitespace after the C<,> separating key-value pairs and array -members. - -If C<$enable> is false, then the C method will not add any extra -space at those places. - -This setting has no effect when decoding JSON texts. - -Example, space_before and indent disabled, space_after enabled: - - {"key": "value"} - -=head2 relaxed - - $json = $json->relaxed([$enable]) - - $enabled = $json->get_relaxed - -If C<$enable> is true (or missing), then C will accept some -extensions to normal JSON syntax (see below). C will not be -affected in anyway. I. I suggest only to use this option to -parse application-specific files written by humans (configuration files, -resource files etc.) - -If C<$enable> is false (the default), then C will only accept -valid JSON texts. - -Currently accepted extensions are: - -=over 4 - -=item * list items can have an end-comma - -JSON I array elements and key-value pairs with commas. This -can be annoying if you write JSON texts manually and want to be able to -quickly append elements, so this extension accepts comma at the end of -such items not just between them: - - [ - 1, - 2, <- this comma not normally allowed - ] - { - "k1": "v1", - "k2": "v2", <- this comma not normally allowed - } - -=item * shell-style '#'-comments - -Whenever JSON allows whitespace, shell-style comments are additionally -allowed. They are terminated by the first carriage-return or line-feed -character, after which more white-space and comments are allowed. - - [ - 1, # this comment not allowed in JSON - # neither this one... - ] - -=back - -=head2 canonical - - $json = $json->canonical([$enable]) - - $enabled = $json->get_canonical - -If C<$enable> is true (or missing), then the C method will output JSON objects -by sorting their keys. This is adding a comparatively high overhead. - -If C<$enable> is false, then the C method will output key-value -pairs in the order Perl stores them (which will likely change between runs -of the same script). - -This option is useful if you want the same data structure to be encoded as -the same JSON text (given the same overall settings). If it is disabled, -the same hash might be encoded differently even if contains the same data, -as key-value pairs have no inherent ordering in Perl. - -This setting has no effect when decoding JSON texts. - -If you want your own sorting routine, you can give a code referece -or a subroutine name to C. See to C. - -=head2 allow_nonref - - $json = $json->allow_nonref([$enable]) - - $enabled = $json->get_allow_nonref - -If C<$enable> is true (or missing), then the C method can convert a -non-reference into its corresponding string, number or null JSON value, -which is an extension to RFC4627. Likewise, C will accept those JSON -values instead of croaking. - -If C<$enable> is false, then the C method will croak if it isn't -passed an arrayref or hashref, as JSON texts must either be an object -or array. Likewise, C will croak if given something that is not a -JSON object or array. - - JSON::PP->new->allow_nonref->encode ("Hello, World!") - => "Hello, World!" - -=head2 allow_unknown - - $json = $json->allow_unknown ([$enable]) - - $enabled = $json->get_allow_unknown - -If $enable is true (or missing), then "encode" will *not* throw an -exception when it encounters values it cannot represent in JSON (for -example, filehandles) but instead will encode a JSON "null" value. -Note that blessed objects are not included here and are handled -separately by c. - -If $enable is false (the default), then "encode" will throw an -exception when it encounters anything it cannot encode as JSON. - -This option does not affect "decode" in any way, and it is -recommended to leave it off unless you know your communications -partner. - -=head2 allow_blessed - - $json = $json->allow_blessed([$enable]) - - $enabled = $json->get_allow_blessed - -If C<$enable> is true (or missing), then the C method will not -barf when it encounters a blessed reference. Instead, the value of the -B option will decide whether C (C -disabled or no C method found) or a representation of the -object (C enabled and C method found) is being -encoded. Has no effect on C. - -If C<$enable> is false (the default), then C will throw an -exception when it encounters a blessed object. - -=head2 convert_blessed - - $json = $json->convert_blessed([$enable]) - - $enabled = $json->get_convert_blessed - -If C<$enable> is true (or missing), then C, upon encountering a -blessed object, will check for the availability of the C method -on the object's class. If found, it will be called in scalar context -and the resulting scalar will be encoded instead of the object. If no -C method is found, the value of C will decide what -to do. - -The C method may safely call die if it wants. If C -returns other blessed objects, those will be handled in the same -way. C must take care of not causing an endless recursion cycle -(== crash) in this case. The name of C was chosen because other -methods called by the Perl core (== not by the user of the object) are -usually in upper case letters and to avoid collisions with the C -function or method. - -This setting does not yet influence C in any way. - -If C<$enable> is false, then the C setting will decide what -to do when a blessed object is found. - -=head2 filter_json_object - - $json = $json->filter_json_object([$coderef]) - -When C<$coderef> is specified, it will be called from C each -time it decodes a JSON object. The only argument passed to the coderef -is a reference to the newly-created hash. If the code references returns -a single scalar (which need not be a reference), this value -(i.e. a copy of that scalar to avoid aliasing) is inserted into the -deserialised data structure. If it returns an empty list -(NOTE: I C, which is a valid scalar), the original deserialised -hash will be inserted. This setting can slow down decoding considerably. - -When C<$coderef> is omitted or undefined, any existing callback will -be removed and C will not change the deserialised hash in any -way. - -Example, convert all JSON objects into the integer 5: - - my $js = JSON::PP->new->filter_json_object (sub { 5 }); - # returns [5] - $js->decode ('[{}]'); # the given subroutine takes a hash reference. - # throw an exception because allow_nonref is not enabled - # so a lone 5 is not allowed. - $js->decode ('{"a":1, "b":2}'); - -=head2 filter_json_single_key_object - - $json = $json->filter_json_single_key_object($key [=> $coderef]) - -Works remotely similar to C, but is only called for -JSON objects having a single key named C<$key>. - -This C<$coderef> is called before the one specified via -C, if any. It gets passed the single value in the JSON -object. If it returns a single value, it will be inserted into the data -structure. If it returns nothing (not even C but the empty list), -the callback from C will be called next, as if no -single-key callback were specified. - -If C<$coderef> is omitted or undefined, the corresponding callback will be -disabled. There can only ever be one callback for a given key. - -As this callback gets called less often then the C -one, decoding speed will not usually suffer as much. Therefore, single-key -objects make excellent targets to serialise Perl objects into, especially -as single-key JSON objects are as close to the type-tagged value concept -as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not -support this in any way, so you need to make sure your data never looks -like a serialised Perl hash. - -Typical names for the single object key are C<__class_whatever__>, or -C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even -things like C<__class_md5sum(classname)__>, to reduce the risk of clashing -with real hashes. - -Example, decode JSON objects of the form C<< { "__widget__" => } >> -into the corresponding C<< $WIDGET{} >> object: - - # return whatever is in $WIDGET{5}: - JSON::PP - ->new - ->filter_json_single_key_object (__widget__ => sub { - $WIDGET{ $_[0] } - }) - ->decode ('{"__widget__": 5') - - # this can be used with a TO_JSON method in some "widget" class - # for serialisation to json: - sub WidgetBase::TO_JSON { - my ($self) = @_; - - unless ($self->{id}) { - $self->{id} = ..get..some..id..; - $WIDGET{$self->{id}} = $self; - } - - { __widget__ => $self->{id} } - } - -=head2 shrink - - $json = $json->shrink([$enable]) - - $enabled = $json->get_shrink - -In JSON::XS, this flag resizes strings generated by either -C or C to their minimum size possible. -It will also try to downgrade any strings to octet-form if possible. - -In JSON::PP, it is noop about resizing strings but tries -C to the returned string by C. -See to L. - -See to L - -=head2 max_depth - - $json = $json->max_depth([$maximum_nesting_depth]) - - $max_depth = $json->get_max_depth - -Sets the maximum nesting level (default C<512>) accepted while encoding -or decoding. If a higher nesting level is detected in JSON text or a Perl -data structure, then the encoder and decoder will stop and croak at that -point. - -Nesting level is defined by number of hash- or arrayrefs that the encoder -needs to traverse to reach a given point or the number of C<{> or C<[> -characters without their matching closing parenthesis crossed to reach a -given character in a string. - -If no argument is given, the highest possible setting will be used, which -is rarely useful. - -See L for more info on why this is useful. - -When a large value (100 or more) was set and it de/encodes a deep nested object/text, -it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase. - -=head2 max_size - - $json = $json->max_size([$maximum_string_size]) - - $max_size = $json->get_max_size - -Set the maximum length a JSON text may have (in bytes) where decoding is -being attempted. The default is C<0>, meaning no limit. When C -is called on a string that is longer then this many bytes, it will not -attempt to decode the string but throw an exception. This setting has no -effect on C (yet). - -If no argument is given, the limit check will be deactivated (same as when -C<0> is specified). - -See L for more info on why this is useful. - -=head2 encode - - $json_text = $json->encode($perl_scalar) - -Converts the given Perl data structure (a simple scalar or a reference -to a hash or array) to its JSON representation. Simple scalars will be -converted into JSON string or number sequences, while references to arrays -become JSON arrays and references to hashes become JSON objects. Undefined -Perl values (e.g. C) become JSON C values. -References to the integers C<0> and C<1> are converted into C and C. - -=head2 decode - - $perl_scalar = $json->decode($json_text) - -The opposite of C: expects a JSON text and tries to parse it, -returning the resulting simple scalar or reference. Croaks on error. - -JSON numbers and strings become simple Perl scalars. JSON arrays become -Perl arrayrefs and JSON objects become Perl hashrefs. C becomes -C<1> (C), C becomes C<0> (C) and -C becomes C. - -=head2 decode_prefix - - ($perl_scalar, $characters) = $json->decode_prefix($json_text) - -This works like the C method, but instead of raising an exception -when there is trailing garbage after the first JSON object, it will -silently stop parsing there and return the number of characters consumed -so far. - - JSON->new->decode_prefix ("[1] the tail") - => ([], 3) - -=head1 INCREMENTAL PARSING - -Most of this section are copied and modified from L. - -In some cases, there is the need for incremental parsing of JSON texts. -This module does allow you to parse a JSON stream incrementally. -It does so by accumulating text until it has a full JSON object, which -it then can decode. This process is similar to using C -to see if a full JSON object is available, but is much more efficient -(and can be implemented with a minimum of method calls). - -This module will only attempt to parse the JSON text once it is sure it -has enough text to get a decisive result, using a very simple but -truly incremental parser. This means that it sometimes won't stop as -early as the full parser, for example, it doesn't detect parenthese -mismatches. The only thing it guarantees is that it starts decoding as -soon as a syntactically valid JSON text has been seen. This means you need -to set resource limits (e.g. C) to ensure the parser will stop -parsing in the presence if syntax errors. - -The following methods implement this incremental parser. - -=head2 incr_parse - - $json->incr_parse( [$string] ) # void context - - $obj_or_undef = $json->incr_parse( [$string] ) # scalar context - - @obj_or_empty = $json->incr_parse( [$string] ) # list context - -This is the central parsing function. It can both append new text and -extract objects from the stream accumulated so far (both of these -functions are optional). - -If C<$string> is given, then this string is appended to the already -existing JSON fragment stored in the C<$json> object. - -After that, if the function is called in void context, it will simply -return without doing anything further. This can be used to add more text -in as many chunks as you want. - -If the method is called in scalar context, then it will try to extract -exactly I JSON object. If that is successful, it will return this -object, otherwise it will return C. If there is a parse error, -this method will croak just as C would do (one can then use -C to skip the errornous part). This is the most common way of -using the method. - -And finally, in list context, it will try to extract as many objects -from the stream as it can find and return them, or the empty list -otherwise. For this to work, there must be no separators between the JSON -objects or arrays, instead they must be concatenated back-to-back. If -an error occurs, an exception will be raised as in the scalar context -case. Note that in this case, any previously-parsed JSON texts will be -lost. - -Example: Parse some JSON arrays/objects in a given string and return them. - - my @objs = JSON->new->incr_parse ("[5][7][1,2]"); - -=head2 incr_text - - $lvalue_string = $json->incr_text - -This method returns the currently stored JSON fragment as an lvalue, that -is, you can manipulate it. This I works when a preceding call to -C in I successfully returned an object. Under -all other circumstances you must not call this function (I mean it. -although in simple tests it might actually work, it I fail under -real world conditions). As a special exception, you can also call this -method before having parsed anything. - -This function is useful in two cases: a) finding the trailing text after a -JSON object or b) parsing multiple JSON objects separated by non-JSON text -(such as commas). - - $json->incr_text =~ s/\s*,\s*//; - -In Perl 5.005, C attribute is not available. -You must write codes like the below: - - $string = $json->incr_text; - $string =~ s/\s*,\s*//; - $json->incr_text( $string ); - -=head2 incr_skip - - $json->incr_skip - -This will reset the state of the incremental parser and will remove the -parsed text from the input buffer. This is useful after C -died, in which case the input buffer and incremental parser state is left -unchanged, to skip the text parsed so far and to reset the parse state. - -=head2 incr_reset - - $json->incr_reset - -This completely resets the incremental parser, that is, after this call, -it will be as if the parser had never parsed anything. - -This is useful if you want ot repeatedly parse JSON objects and want to -ignore any trailing data, which means you have to reset the parser after -each successful decode. - -See to L for examples. - - -=head1 JSON::PP OWN METHODS - -=head2 allow_singlequote - - $json = $json->allow_singlequote([$enable]) - -If C<$enable> is true (or missing), then C will accept -JSON strings quoted by single quotations that are invalid JSON -format. - - $json->allow_singlequote->decode({"foo":'bar'}); - $json->allow_singlequote->decode({'foo':"bar"}); - $json->allow_singlequote->decode({'foo':'bar'}); - -As same as the C option, this option may be used to parse -application-specific files written by humans. - - -=head2 allow_barekey - - $json = $json->allow_barekey([$enable]) - -If C<$enable> is true (or missing), then C will accept -bare keys of JSON object that are invalid JSON format. - -As same as the C option, this option may be used to parse -application-specific files written by humans. - - $json->allow_barekey->decode('{foo:"bar"}'); - -=head2 allow_bignum - - $json = $json->allow_bignum([$enable]) - -If C<$enable> is true (or missing), then C will convert -the big integer Perl cannot handle as integer into a L -object and convert a floating number (any) into a L. - -On the contary, C converts C objects and C -objects into JSON numbers with C enable. - - $json->allow_nonref->allow_blessed->allow_bignum; - $bigfloat = $json->decode('2.000000000000000000000000001'); - print $json->encode($bigfloat); - # => 2.000000000000000000000000001 - -See to L aboout the normal conversion of JSON number. - -=head2 loose - - $json = $json->loose([$enable]) - -The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings -and the module doesn't allow to C to these (except for \x2f). -If C<$enable> is true (or missing), then C will accept these -unescaped strings. - - $json->loose->decode(qq|["abc - def"]|); - -See L. - -=head2 escape_slash - - $json = $json->escape_slash([$enable]) - -According to JSON Grammar, I (U+002F) is escaped. But default -JSON::PP (as same as JSON::XS) encodes strings without escaping slash. - -If C<$enable> is true (or missing), then C will escape slashes. - -=head2 indent_length - - $json = $json->indent_length($length) - -JSON::XS indent space length is 3 and cannot be changed. -JSON::PP set the indent space length with the given $length. -The default is 3. The acceptable range is 0 to 15. - -=head2 sort_by - - $json = $json->sort_by($function_name) - $json = $json->sort_by($subroutine_ref) - -If $function_name or $subroutine_ref are set, its sort routine are used -in encoding JSON objects. - - $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); - # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); - - $js = $pc->sort_by('own_sort')->encode($obj); - # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); - - sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } - -As the sorting routine runs in the JSON::PP scope, the given -subroutine name and the special variables C<$a>, C<$b> will begin -'JSON::PP::'. - -If $integer is set, then the effect is same as C on. - -=head1 INTERNAL - -For developers. - -=over - -=item PP_encode_box - -Returns - - { - depth => $depth, - indent_count => $indent_count, - } - - -=item PP_decode_box - -Returns - - { - text => $text, - at => $at, - ch => $ch, - len => $len, - depth => $depth, - encoding => $encoding, - is_valid_utf8 => $is_valid_utf8, - }; - -=back - -=head1 MAPPING - -This section is copied from JSON::XS and modified to C. -JSON::XS and JSON::PP mapping mechanisms are almost equivalent. - -See to L. - -=head2 JSON -> PERL - -=over 4 - -=item object - -A JSON object becomes a reference to a hash in Perl. No ordering of object -keys is preserved (JSON does not preserver object key ordering itself). - -=item array - -A JSON array becomes a reference to an array in Perl. - -=item string - -A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON -are represented by the same codepoints in the Perl string, so no manual -decoding is necessary. - -=item number - -A JSON number becomes either an integer, numeric (floating point) or -string scalar in perl, depending on its range and any fractional parts. On -the Perl level, there is no difference between those as Perl handles all -the conversion details, but an integer may take slightly less memory and -might represent more values exactly than floating point numbers. - -If the number consists of digits only, C will try to represent -it as an integer value. If that fails, it will try to represent it as -a numeric (floating point) value if that is possible without loss of -precision. Otherwise it will preserve the number as a string value (in -which case you lose roundtripping ability, as the JSON number will be -re-encoded toa JSON string). - -Numbers containing a fractional or exponential part will always be -represented as numeric (floating point) values, possibly at a loss of -precision (in which case you might lose perfect roundtripping ability, but -the JSON number will still be re-encoded as a JSON number). - -Note that precision is not accuracy - binary floating point values cannot -represent most decimal fractions exactly, and when converting from and to -floating point, C only guarantees precision up to but not including -the leats significant bit. - -When C is enable, the big integers -and the numeric can be optionally converted into L and -L objects. - -=item true, false - -These JSON atoms become C and C, -respectively. They are overloaded to act almost exactly like the numbers -C<1> and C<0>. You can check wether a scalar is a JSON boolean by using -the C function. - - print JSON::PP::true . "\n"; - => true - print JSON::PP::true + 1; - => 1 - - ok(JSON::true eq '1'); - ok(JSON::true == 1); - -C will install these missing overloading features to the backend modules. - - -=item null - -A JSON null atom becomes C in Perl. - -C returns C. - -=back - - -=head2 PERL -> JSON - -The mapping from Perl to JSON is slightly more difficult, as Perl is a -truly typeless language, so we can only guess which JSON type is meant by -a Perl value. - -=over 4 - -=item hash references - -Perl hash references become JSON objects. As there is no inherent ordering -in hash keys (or JSON objects), they will usually be encoded in a -pseudo-random order that can change between runs of the same program but -stays generally the same within a single run of a program. C -optionally sort the hash keys (determined by the I flag), so -the same datastructure will serialise to the same JSON text (given same -settings and version of JSON::XS), but this incurs a runtime overhead -and is only rarely useful, e.g. when you want to compare some JSON text -against another for equality. - - -=item array references - -Perl array references become JSON arrays. - -=item other references - -Other unblessed references are generally not allowed and will cause an -exception to be thrown, except for references to the integers C<0> and -C<1>, which get turned into C and C atoms in JSON. You can -also use C and C to improve readability. - - to_json [\0,JSON::PP::true] # yields [false,true] - -=item JSON::PP::true, JSON::PP::false, JSON::PP::null - -These special values become JSON true and JSON false values, -respectively. You can also use C<\1> and C<\0> directly if you want. - -JSON::PP::null returns C. - -=item blessed objects - -Blessed objects are not directly representable in JSON. See the -C and C methods on various options on -how to deal with this: basically, you can choose between throwing an -exception, encoding the reference as if it weren't blessed, or provide -your own serialiser method. - -See to L. - -=item simple scalars - -Simple Perl scalars (any scalar that is not a reference) are the most -difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as -JSON C values, scalars that have last been used in a string context -before encoding as JSON strings, and anything else as number value: - - # dump as number - encode_json [2] # yields [2] - encode_json [-3.0e17] # yields [-3e+17] - my $value = 5; encode_json [$value] # yields [5] - - # used as string, so dump as string - print $value; - encode_json [$value] # yields ["5"] - - # undef becomes null - encode_json [undef] # yields [null] - -You can force the type to be a string by stringifying it: - - my $x = 3.1; # some variable containing a number - "$x"; # stringified - $x .= ""; # another, more awkward way to stringify - print $x; # perl does it for you, too, quite often - -You can force the type to be a number by numifying it: - - my $x = "3"; # some variable containing a string - $x += 0; # numify it, ensuring it will be dumped as a number - $x *= 1; # same thing, the choise is yours. - -You can not currently force the type in other, less obscure, ways. - -Note that numerical precision has the same meaning as under Perl (so -binary to decimal conversion follows the same rules as in Perl, which -can differ to other languages). Also, your perl interpreter might expose -extensions to the floating point numbers of your platform, such as -infinities or NaN's - these cannot be represented in JSON, and it is an -error to pass those in. - -=item Big Number - -When C is enable, -C converts C objects and C -objects into JSON numbers. - - -=back - -=head1 UNICODE HANDLING ON PERLS - -If you do not know about Unicode on Perl well, -please check L. - -=head2 Perl 5.8 and later - -Perl can handle Unicode and the JSON::PP de/encode methods also work properly. - - $json->allow_nonref->encode(chr hex 3042); - $json->allow_nonref->encode(chr hex 12345); - -Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively. - - $json->allow_nonref->decode('"\u3042"'); - $json->allow_nonref->decode('"\ud808\udf45"'); - -Returns UTF-8 encoded strings with UTF8 flag, regarded as C and C. - -Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C was broken, -so JSON::PP wraps the C with a subroutine. Thus JSON::PP works slow in the versions. - - -=head2 Perl 5.6 - -Perl can handle Unicode and the JSON::PP de/encode methods also work. - -=head2 Perl 5.005 - -Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. -That means the unicode handling is not available. - -In encoding, - - $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. - $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. - -Returns C and C, as C takes a value more than 255, it treats -as C<$value % 256>, so the above codes are equivalent to : - - $json->allow_nonref->encode(chr 66); - $json->allow_nonref->encode(chr 69); - -In decoding, - - $json->decode('"\u00e3\u0081\u0082"'); - -The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded -japanese character (C). -And if it is represented in Unicode code point, C. - -Next, - - $json->decode('"\u3042"'); - -We ordinary expect the returned value is a Unicode character C. -But here is 5.005 world. This is C<0xE3 0x81 0x82>. - - $json->decode('"\ud808\udf45"'); - -This is not a character C but bytes - C<0xf0 0x92 0x8d 0x85>. - - -=head1 TODO - -=over - -=item speed - -=item memory saving - -=back - - -=head1 SEE ALSO - -Most of the document are copied and modified from JSON::XS doc. - -L - -RFC4627 (L) - -=head1 AUTHOR - -Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE - - -=head1 COPYRIGHT AND LICENSE - -Copyright 2007-2013 by Makamaka Hannyaharamitu - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=cut diff --git a/bundled/JSON-PP/JSON/PP/Boolean.pm b/bundled/JSON-PP/JSON/PP/Boolean.pm deleted file mode 100644 index 0b1fb19..0000000 --- a/bundled/JSON-PP/JSON/PP/Boolean.pm +++ /dev/null @@ -1,26 +0,0 @@ -=head1 NAME - -JSON::PP::Boolean - dummy module providing JSON::PP::Boolean - -=head1 SYNOPSIS - - # do not "use" yourself - -=head1 DESCRIPTION - -This module exists only to provide overload resolution for Storable and similar modules. See -L for more info about this class. - -=cut - -use JSON::PP (); -use strict; - -1; - -=head1 AUTHOR - -This idea is from L written by Marc Lehmann - -=cut - diff --git a/bundled/Parse-CPAN-Meta/Parse/CPAN/Meta.pm b/bundled/Parse-CPAN-Meta/Parse/CPAN/Meta.pm deleted file mode 100644 index 7888d1c..0000000 --- a/bundled/Parse-CPAN-Meta/Parse/CPAN/Meta.pm +++ /dev/null @@ -1,345 +0,0 @@ -use 5.008001; -use strict; -package Parse::CPAN::Meta; -# ABSTRACT: Parse META.yml and META.json CPAN metadata files -our $VERSION = '1.4414'; # VERSION - -use Exporter; -use Carp 'croak'; - -our @ISA = qw/Exporter/; -our @EXPORT_OK = qw/Load LoadFile/; - -sub load_file { - my ($class, $filename) = @_; - - my $meta = _slurp($filename); - - if ($filename =~ /\.ya?ml$/) { - return $class->load_yaml_string($meta); - } - elsif ($filename =~ /\.json$/) { - return $class->load_json_string($meta); - } - else { - $class->load_string($meta); # try to detect yaml/json - } -} - -sub load_string { - my ($class, $string) = @_; - if ( $string =~ /^---/ ) { # looks like YAML - return $class->load_yaml_string($string); - } - elsif ( $string =~ /^\s*\{/ ) { # looks like JSON - return $class->load_json_string($string); - } - else { # maybe doc-marker-free YAML - return $class->load_yaml_string($string); - } -} - -sub load_yaml_string { - my ($class, $string) = @_; - my $backend = $class->yaml_backend(); - my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) }; - croak $@ if $@; - return $data || {}; # in case document was valid but empty -} - -sub load_json_string { - my ($class, $string) = @_; - my $data = eval { $class->json_backend()->new->decode($string) }; - croak $@ if $@; - return $data || {}; -} - -sub yaml_backend { - if (! defined $ENV{PERL_YAML_BACKEND} ) { - _can_load( 'CPAN::Meta::YAML', 0.011 ) - or croak "CPAN::Meta::YAML 0.011 is not available\n"; - return "CPAN::Meta::YAML"; - } - else { - my $backend = $ENV{PERL_YAML_BACKEND}; - _can_load( $backend ) - or croak "Could not load PERL_YAML_BACKEND '$backend'\n"; - $backend->can("Load") - or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n"; - return $backend; - } -} - -sub json_backend { - if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') { - _can_load( 'JSON::PP' => 2.27103 ) - or croak "JSON::PP 2.27103 is not available\n"; - return 'JSON::PP'; - } - else { - _can_load( 'JSON' => 2.5 ) - or croak "JSON 2.5 is required for " . - "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n"; - return "JSON"; - } -} - -sub _slurp { - require Encode; - open my $fh, "<:raw", "$_[0]" ## no critic - or die "can't open $_[0] for reading: $!"; - my $content = do { local $/; <$fh> }; - $content = Encode::decode('UTF-8', $content, Encode::PERLQQ()); - return $content; -} - -sub _can_load { - my ($module, $version) = @_; - (my $file = $module) =~ s{::}{/}g; - $file .= ".pm"; - return 1 if $INC{$file}; - return 0 if exists $INC{$file}; # prior load failed - eval { require $file; 1 } - or return 0; - if ( defined $version ) { - eval { $module->VERSION($version); 1 } - or return 0; - } - return 1; -} - -# Kept for backwards compatibility only -# Create an object from a file -sub LoadFile ($) { - return Load(_slurp(shift)); -} - -# Parse a document from a string. -sub Load ($) { - require CPAN::Meta::YAML; - my $object = eval { CPAN::Meta::YAML::Load(shift) }; - croak $@ if $@; - return $object; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files - -=head1 VERSION - -version 1.4414 - -=head1 SYNOPSIS - - ############################################# - # In your file - - --- - name: My-Distribution - version: 1.23 - resources: - homepage: "http://example.com/dist/My-Distribution" - - - ############################################# - # In your program - - use Parse::CPAN::Meta; - - my $distmeta = Parse::CPAN::Meta->load_file('META.yml'); - - # Reading properties - my $name = $distmeta->{name}; - my $version = $distmeta->{version}; - my $homepage = $distmeta->{resources}{homepage}; - -=head1 DESCRIPTION - -B is a parser for F and F files, using -L and/or L. - -B provides three methods: C, C, -and C. These will read and deserialize CPAN metafiles, and -are described below in detail. - -B provides a legacy API of only two functions, -based on the YAML functions of the same name. Wherever possible, -identical calling semantics are used. These may only be used with YAML sources. - -All error reporting is done with exceptions (die'ing). - -Note that META files are expected to be in UTF-8 encoding, only. When -converted string data, it must first be decoded from UTF-8. - -=begin Pod::Coverage - - - - -=end Pod::Coverage - -=head1 METHODS - -=head2 load_file - - my $metadata_structure = Parse::CPAN::Meta->load_file('META.json'); - - my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml'); - -This method will read the named file and deserialize it to a data structure, -determining whether it should be JSON or YAML based on the filename. -The file will be read using the ":utf8" IO layer. - -=head2 load_yaml_string - - my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string); - -This method deserializes the given string of YAML and returns the first -document in it. (CPAN metadata files should always have only one document.) -If the source was UTF-8 encoded, the string must be decoded before calling -C. - -=head2 load_json_string - - my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string); - -This method deserializes the given string of JSON and the result. -If the source was UTF-8 encoded, the string must be decoded before calling -C. - -=head2 load_string - - my $metadata_structure = Parse::CPAN::Meta->load_string($some_string); - -If you don't know whether a string contains YAML or JSON data, this method -will use some heuristics and guess. If it can't tell, it assumes YAML. - -=head2 yaml_backend - - my $backend = Parse::CPAN::Meta->yaml_backend; - -Returns the module name of the YAML serializer. See L -for details. - -=head2 json_backend - - my $backend = Parse::CPAN::Meta->json_backend; - -Returns the module name of the JSON serializer. This will either -be L or L. Even if C is set, -this will return L as further delegation is handled by -the L module. See L for details. - -=head1 FUNCTIONS - -For maintenance clarity, no functions are exported by default. These functions -are available for backwards compatibility only and are best avoided in favor of -C. - -=head2 Load - - my @yaml = Parse::CPAN::Meta::Load( $string ); - -Parses a string containing a valid YAML stream into a list of Perl data -structures. - -=head2 LoadFile - - my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' ); - -Reads the YAML stream from a file instead of a string. - -=head1 ENVIRONMENT - -=head2 PERL_JSON_BACKEND - -By default, L will be used for deserializing JSON data. If the -C environment variable exists, is true and is not -"JSON::PP", then the L module (version 2.5 or greater) will be loaded and -used to interpret C. If L is not installed or is too -old, an exception will be thrown. - -=head2 PERL_YAML_BACKEND - -By default, L will be used for deserializing YAML data. If -the C environment variable is defined, then it is interpreted -as a module to use for deserialization. The given module must be installed, -must load correctly and must implement the C function or an exception -will be thrown. - -=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/Perl-Toolchain-Gang/Parse-CPAN-Meta.git - -=head1 AUTHORS - -=over 4 - -=item * - -Adam Kennedy - -=item * - -David Golden - -=back - -=head1 CONTRIBUTORS - -=over 4 - -=item * - -Graham Knop - -=item * - -Joshua ben Jore - -=item * - -Neil Bowers - -=item * - -Ricardo Signes - -=item * - -Steffen Mueller - -=back - -=head1 COPYRIGHT AND LICENSE - -This software is copyright (c) 2014 by Adam Kennedy and Contributors. - -This is free software; you can redistribute it and/or modify it under -the same terms as the Perl 5 programming language system itself. - -=cut diff --git a/bundled/README b/bundled/README deleted file mode 100644 index 80c6870..0000000 --- a/bundled/README +++ /dev/null @@ -1,5 +0,0 @@ -This directory contains CPAN modules which ExtUtils-MakeMaker depends on. -They are bundled with ExtUtils-MakeMaker to avoid dependency loops. - -Vendor packages will want to disable this bundling. See README.packaging in the top -level directory for details. diff --git a/bundled/Scalar-List-Utils/List/Util.pm b/bundled/Scalar-List-Utils/List/Util.pm deleted file mode 100644 index aced6b1..0000000 --- a/bundled/Scalar-List-Utils/List/Util.pm +++ /dev/null @@ -1,233 +0,0 @@ -# List::Util.pm -# -# Copyright (c) 1997-2009 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# This module is normally only loaded if the XS module is not available - -package List::Util; - -use strict; -use vars qw(@ISA @EXPORT_OK $VERSION $XS_VERSION $TESTING_PERL_ONLY); -require Exporter; - -@ISA = qw(Exporter); -@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.23"; -$XS_VERSION = $VERSION; -$VERSION = eval $VERSION; - -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}; - eval { - require XSLoader; - XSLoader::load('List::Util', $XS_VERSION); - 1; - } or do { - require DynaLoader; - local @ISA = qw(DynaLoader); - bootstrap List::Util $XS_VERSION; - }; -} unless $TESTING_PERL_ONLY; - - -if (!defined &sum) { - require List::Util::PP; - List::Util::PP->import; -} - -1; - -__END__ - -=head1 NAME - -List::Util - A selection of general-utility list subroutines - -=head1 SYNOPSIS - - use List::Util qw(first max maxstr min minstr reduce shuffle sum); - -=head1 DESCRIPTION - -C contains a selection of subroutines that people have -expressed would be nice to have in the perl core, but the usage would -not really be high enough to warrant the use of a keyword, and the size -so small such that being individual extensions would be wasteful. - -By default C does not export any subroutines. The -subroutines defined are - -=over 4 - -=item first BLOCK LIST - -Similar to C in that it evaluates BLOCK setting C<$_> to each element -of LIST in turn. C returns the first element where the result from -BLOCK is a true value. If BLOCK never returns true or LIST was empty then -C is returned. - - $foo = first { defined($_) } @list # first defined value in @list - $foo = first { $_ > $value } @list # first value in @list which - # is greater than $value - -This function could be implemented using C like this - - $foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list - -for example wanted() could be defined() which would return the first -defined value in @list - -=item max LIST - -Returns the entry in the list with the highest numerical value. If the -list is empty then C is returned. - - $foo = max 1..10 # 10 - $foo = max 3,9,12 # 12 - $foo = max @bar, @baz # whatever - -This function could be implemented using C like this - - $foo = reduce { $a > $b ? $a : $b } 1..10 - -=item maxstr LIST - -Similar to C, but treats all the entries in the list as strings -and returns the highest string as defined by the C operator. -If the list is empty then C is returned. - - $foo = maxstr 'A'..'Z' # 'Z' - $foo = maxstr "hello","world" # "world" - $foo = maxstr @bar, @baz # whatever - -This function could be implemented using C like this - - $foo = reduce { $a gt $b ? $a : $b } 'A'..'Z' - -=item min LIST - -Similar to C but returns the entry in the list with the lowest -numerical value. If the list is empty then C is returned. - - $foo = min 1..10 # 1 - $foo = min 3,9,12 # 3 - $foo = min @bar, @baz # whatever - -This function could be implemented using C like this - - $foo = reduce { $a < $b ? $a : $b } 1..10 - -=item minstr LIST - -Similar to C, but treats all the entries in the list as strings -and returns the lowest string as defined by the C operator. -If the list is empty then C is returned. - - $foo = minstr 'A'..'Z' # 'A' - $foo = minstr "hello","world" # "hello" - $foo = minstr @bar, @baz # whatever - -This function could be implemented using C like this - - $foo = reduce { $a lt $b ? $a : $b } 'A'..'Z' - -=item reduce BLOCK LIST - -Reduces LIST by calling BLOCK, in a scalar context, multiple times, -setting C<$a> and C<$b> each time. The first call will be with C<$a> -and C<$b> set to the first two elements of the list, subsequent -calls will be done by setting C<$a> to the result of the previous -call and C<$b> to the next element in the list. - -Returns the result of the last call to BLOCK. If LIST is empty then -C is returned. If LIST only contains one element then that -element is returned and BLOCK is not executed. - - $foo = reduce { $a < $b ? $a : $b } 1..10 # min - $foo = reduce { $a lt $b ? $a : $b } 'aa'..'zz' # minstr - $foo = reduce { $a + $b } 1 .. 10 # sum - $foo = reduce { $a . $b } @bar # concat - -If your algorithm requires that C produce an identity value, then -make sure that you always pass that identity value as the first argument to prevent -C being returned - - $foo = reduce { $a + $b } 0, @values; # sum with 0 identity value - -=item shuffle LIST - -Returns the elements of LIST in a random order - - @cards = shuffle 0..51 # 0..51 in a random order - -=item sum LIST - -Returns the sum of all the elements in LIST. If LIST is empty then -C is returned. - - $foo = sum 1..10 # 55 - $foo = sum 3,9,12 # 24 - $foo = sum @bar, @baz # whatever - -This function could be implemented using C like this - - $foo = reduce { $a + $b } 1..10 - -If your algorithm requires that C produce an identity of 0, then -make sure that you always pass C<0> as the first argument to prevent -C being returned - - $foo = sum 0, @values; - -=back - -=head1 KNOWN BUGS - -With perl versions prior to 5.005 there are some cases where reduce -will return an incorrect result. This will show up as test 7 of -reduce.t failing. - -=head1 SUGGESTED ADDITIONS - -The following are additions that have been requested, but I have been reluctant -to add due to them being very simple to implement in perl - - # One argument is true - - sub any { $_ && return 1 for @_; 0 } - - # All arguments are true - - sub all { $_ || return 0 for @_; 1 } - - # All arguments are false - - sub none { $_ && return 0 for @_; 1 } - - # One argument is false - - sub notall { $_ || return 1 for @_; 0 } - - # How many elements are true - - sub true { scalar grep { $_ } @_ } - - # How many elements are false - - sub false { scalar grep { !$_ } @_ } - -=head1 SEE ALSO - -L, L - -=head1 COPYRIGHT - -Copyright (c) 1997-2007 Graham Barr . All rights reserved. -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/bundled/Scalar-List-Utils/List/Util/PP.pm b/bundled/Scalar-List-Utils/List/Util/PP.pm deleted file mode 100644 index 2771329..0000000 --- a/bundled/Scalar-List-Utils/List/Util/PP.pm +++ /dev/null @@ -1,83 +0,0 @@ -# List::Util::PP.pm -# -# Copyright (c) 1997-2009 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package List::Util::PP; - -use strict; -use warnings; -use vars qw(@ISA @EXPORT $VERSION $a $b); -require Exporter; - -@ISA = qw(Exporter); -@EXPORT = qw(first min max minstr maxstr reduce sum shuffle); -$VERSION = "1.23"; -$VERSION = eval $VERSION; - -sub reduce (&@) { - my $code = shift; - require Scalar::Util; - my $type = Scalar::Util::reftype($code); - unless($type and $type eq 'CODE') { - require Carp; - Carp::croak("Not a subroutine reference"); - } - no strict 'refs'; - - return shift unless @_ > 1; - - use vars qw($a $b); - - my $caller = caller; - local(*{$caller."::a"}) = \my $a; - local(*{$caller."::b"}) = \my $b; - - $a = shift; - foreach (@_) { - $b = $_; - $a = &{$code}(); - } - - $a; -} - -sub first (&@) { - my $code = shift; - require Scalar::Util; - my $type = Scalar::Util::reftype($code); - unless($type and $type eq 'CODE') { - require Carp; - Carp::croak("Not a subroutine reference"); - } - - foreach (@_) { - return $_ if &{$code}(); - } - - undef; -} - - -sub sum (@) { reduce { $a + $b } @_ } - -sub min (@) { reduce { $a < $b ? $a : $b } @_ } - -sub max (@) { reduce { $a > $b ? $a : $b } @_ } - -sub minstr (@) { reduce { $a lt $b ? $a : $b } @_ } - -sub maxstr (@) { reduce { $a gt $b ? $a : $b } @_ } - -sub shuffle (@) { - my @a=\(@_); - my $n; - my $i=@_; - map { - $n = rand($i--); - (${$a[$n]}, $a[$n] = $a[$i])[0]; - } @_; -} - -1; diff --git a/bundled/Scalar-List-Utils/Scalar/Util.pm b/bundled/Scalar-List-Utils/Scalar/Util.pm deleted file mode 100644 index 24138ca..0000000 --- a/bundled/Scalar-List-Utils/Scalar/Util.pm +++ /dev/null @@ -1,283 +0,0 @@ -# Scalar::Util.pm -# -# Copyright (c) 1997-2007 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. - -package Scalar::Util; - -use strict; -use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL); -require Exporter; -require List::Util; # List::Util loads the XS - -@ISA = qw(Exporter); -@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype); -$VERSION = "1.23"; -$VERSION = eval $VERSION; - -unless (defined &dualvar) { - # Load Pure Perl version if XS not loaded - require Scalar::Util::PP; - Scalar::Util::PP->import; - push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype); -} - -sub export_fail { - if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded - my $pat = join("|", @EXPORT_FAIL); - if (my ($err) = grep { /^($pat)$/ } @_ ) { - require Carp; - Carp::croak("$err is only available with the XS version of Scalar::Util"); - } - } - - if (grep { /^(weaken|isweak)$/ } @_ ) { - require Carp; - Carp::croak("Weak references are not implemented in the version of perl"); - } - - if (grep { /^(isvstring)$/ } @_ ) { - require Carp; - Carp::croak("Vstrings are not implemented in the version of perl"); - } - - @_; -} - -sub openhandle ($) { - my $fh = shift; - my $rt = reftype($fh) || ''; - - return defined(fileno($fh)) ? $fh : undef - if $rt eq 'IO'; - - if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) - $fh = \(my $tmp=$fh); - } - elsif ($rt ne 'GLOB') { - return undef; - } - - (tied(*$fh) or defined(fileno($fh))) - ? $fh : undef; -} - -1; - -__END__ - -=head1 NAME - -Scalar::Util - A selection of general-utility scalar subroutines - -=head1 SYNOPSIS - - use Scalar::Util qw(blessed dualvar isweak readonly refaddr reftype tainted - weaken isvstring looks_like_number set_prototype); - # and other useful utils appearing below - -=head1 DESCRIPTION - -C contains a selection of subroutines that people have -expressed would be nice to have in the perl core, but the usage would -not really be high enough to warrant the use of a keyword, and the size -so small such that being individual extensions would be wasteful. - -By default C does not export any subroutines. The -subroutines defined are - -=over 4 - -=item blessed EXPR - -If EXPR evaluates to a blessed reference the name of the package -that it is blessed into is returned. Otherwise C is returned. - - $scalar = "foo"; - $class = blessed $scalar; # undef - - $ref = []; - $class = blessed $ref; # undef - - $obj = bless [], "Foo"; - $class = blessed $obj; # "Foo" - -=item dualvar NUM, STRING - -Returns a scalar that has the value NUM in a numeric context and the -value STRING in a string context. - - $foo = dualvar 10, "Hello"; - $num = $foo + 2; # 12 - $str = $foo . " world"; # Hello world - -=item isvstring EXPR - -If EXPR is a scalar which was coded as a vstring the result is true. - - $vs = v49.46.48; - $fmt = isvstring($vs) ? "%vd" : "%s"; #true - printf($fmt,$vs); - -=item isweak EXPR - -If EXPR is a scalar which is a weak reference the result is true. - - $ref = \$foo; - $weak = isweak($ref); # false - weaken($ref); - $weak = isweak($ref); # true - -B: Copying a weak reference creates a normal, strong, reference. - - $copy = $ref; - $weak = isweak($copy); # false - -=item looks_like_number EXPR - -Returns true if perl thinks EXPR is a number. See -L. - -=item openhandle FH - -Returns FH if FH may be used as a filehandle and is open, or FH is a tied -handle. Otherwise C is returned. - - $fh = openhandle(*STDIN); # \*STDIN - $fh = openhandle(\*STDIN); # \*STDIN - $fh = openhandle(*NOTOPEN); # undef - $fh = openhandle("scalar"); # undef - -=item readonly SCALAR - -Returns true if SCALAR is readonly. - - sub foo { readonly($_[0]) } - - $readonly = foo($bar); # false - $readonly = foo(0); # true - -=item refaddr EXPR - -If EXPR evaluates to a reference the internal memory address of -the referenced value is returned. Otherwise C is returned. - - $addr = refaddr "string"; # undef - $addr = refaddr \$var; # eg 12345678 - $addr = refaddr []; # eg 23456784 - - $obj = bless {}, "Foo"; - $addr = refaddr $obj; # eg 88123488 - -=item reftype EXPR - -If EXPR evaluates to a reference the type of the variable referenced -is returned. Otherwise C is returned. - - $type = reftype "string"; # undef - $type = reftype \$var; # SCALAR - $type = reftype []; # ARRAY - - $obj = bless {}, "Foo"; - $type = reftype $obj; # HASH - -=item set_prototype CODEREF, PROTOTYPE - -Sets the prototype of the given function, or deletes it if PROTOTYPE is -undef. Returns the CODEREF. - - set_prototype \&foo, '$$'; - -=item tainted EXPR - -Return true if the result of EXPR is tainted - - $taint = tainted("constant"); # false - $taint = tainted($ENV{PWD}); # true if running under -T - -=item weaken REF - -REF will be turned into a weak reference. This means that it will not -hold a reference count on the object it references. Also when the reference -count on that object reaches zero, REF will be set to undef. - -This is useful for keeping copies of references , but you don't want to -prevent the object being DESTROY-ed at its usual time. - - { - my $var; - $ref = \$var; - weaken($ref); # Make $ref a weak reference - } - # $ref is now undef - -Note that if you take a copy of a scalar with a weakened reference, -the copy will be a strong reference. - - my $var; - my $foo = \$var; - weaken($foo); # Make $foo a weak reference - my $bar = $foo; # $bar is now a strong reference - -This may be less obvious in other situations, such as C, for instance -when grepping through a list of weakened references to objects that may have -been destroyed already: - - @object = grep { defined } @object; - -This will indeed remove all references to destroyed objects, but the remaining -references to objects will be strong, causing the remaining objects to never -be destroyed because there is now always a strong reference to them in the -@object array. - -=back - -=head1 DIAGNOSTICS - -Module use may give one of the following errors during import. - -=over - -=item Weak references are not implemented in the version of perl - -The version of perl that you are using does not implement weak references, to use -C or C you will need to use a newer release of perl. - -=item Vstrings are not implemented in the version of perl - -The version of perl that you are using does not implement Vstrings, to use -C you will need to use a newer release of perl. - -=item C is only available with the XS version of Scalar::Util - -C contains both perl and C implementations of many of its functions -so that those without access to a C compiler may still use it. However some of the functions -are only available when a C compiler was available to compile the XS version of the extension. - -At present that list is: weaken, isweak, dualvar, isvstring, set_prototype - -=back - -=head1 KNOWN BUGS - -There is a bug in perl5.6.0 with UV's that are >= 1<<31. This will -show up as tests 8 and 9 of dualvar.t failing - -=head1 SEE ALSO - -L - -=head1 COPYRIGHT - -Copyright (c) 1997-2007 Graham Barr . All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as Perl itself. - -Except weaken and isweak which are - -Copyright (c) 1999 Tuomas J. Lukka . All rights reserved. -This program is free software; you can redistribute it and/or modify it -under the same terms as perl itself. - -=cut diff --git a/bundled/Scalar-List-Utils/Scalar/Util/PP.pm b/bundled/Scalar-List-Utils/Scalar/Util/PP.pm deleted file mode 100644 index 7850e1b..0000000 --- a/bundled/Scalar-List-Utils/Scalar/Util/PP.pm +++ /dev/null @@ -1,108 +0,0 @@ -# Scalar::Util::PP.pm -# -# Copyright (c) 1997-2009 Graham Barr . All rights reserved. -# This program is free software; you can redistribute it and/or -# modify it under the same terms as Perl itself. -# -# This module is normally only loaded if the XS module is not available - -package Scalar::Util::PP; - -use strict; -use warnings; -use vars qw(@ISA @EXPORT $VERSION $recurse); -require Exporter; -use B qw(svref_2object); - -@ISA = qw(Exporter); -@EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number); -$VERSION = "1.23"; -$VERSION = eval $VERSION; - -sub blessed ($) { - return undef unless length(ref($_[0])); - my $b = svref_2object($_[0]); - return undef unless $b->isa('B::PVMG'); - my $s = $b->SvSTASH; - return $s->isa('B::HV') ? $s->NAME : undef; -} - -sub refaddr($) { - return undef unless length(ref($_[0])); - - my $addr; - if(defined(my $pkg = blessed($_[0]))) { - $addr .= bless $_[0], 'Scalar::Util::Fake'; - bless $_[0], $pkg; - } - else { - $addr .= $_[0] - } - - $addr =~ /0x(\w+)/; - local $^W; - no warnings 'portable'; - hex($1); -} - -{ - my %tmap = qw( - B::NULL SCALAR - - B::HV HASH - B::AV ARRAY - B::CV CODE - B::IO IO - B::GV GLOB - B::REGEXP REGEXP - ); - - sub reftype ($) { - my $r = shift; - - return undef unless length(ref($r)); - - my $t = ref(svref_2object($r)); - - return - exists $tmap{$t} ? $tmap{$t} - : length(ref($$r)) ? 'REF' - : 'SCALAR'; - } -} - -sub tainted { - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - local $^W = 0; - no warnings; - eval { kill 0 * $_[0] }; - $@ =~ /^Insecure/; -} - -sub readonly { - return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR"); - - local($@, $SIG{__DIE__}, $SIG{__WARN__}); - my $tmp = $_[0]; - - !eval { $_[0] = $tmp; 1 }; -} - -sub looks_like_number { - local $_ = shift; - - # checks from perlfaq4 - return 0 if !defined($_); - if (ref($_)) { - require overload; - return overload::Overloaded($_) ? defined(0 + $_) : 0; - } - return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer - return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float - return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); - - 0; -} - - -1; diff --git a/lib/ExtUtils/MakeMaker/Locale.pm b/lib/ExtUtils/MakeMaker/Locale.pm deleted file mode 100644 index 6d97df0..0000000 --- a/lib/ExtUtils/MakeMaker/Locale.pm +++ /dev/null @@ -1,373 +0,0 @@ -package ExtUtils::MakeMaker::Locale; - -use strict; -our $VERSION = "7.34"; -$VERSION = eval $VERSION; - -use base 'Exporter'; -our @EXPORT_OK = qw( - decode_argv env - $ENCODING_LOCALE $ENCODING_LOCALE_FS - $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT -); - -use Encode (); -use Encode::Alias (); - -our $ENCODING_LOCALE; -our $ENCODING_LOCALE_FS; -our $ENCODING_CONSOLE_IN; -our $ENCODING_CONSOLE_OUT; - -sub DEBUG () { 0 } - -sub _init { - if ($^O eq "MSWin32") { - unless ($ENCODING_LOCALE) { - # Try to obtain what the Windows ANSI code page is - eval { - unless (defined &GetConsoleCP) { - require Win32; - # manually "import" it since Win32->import refuses - *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; - } - unless (defined &GetConsoleCP) { - require Win32::API; - Win32::API->Import('kernel32', 'int GetConsoleCP()'); - } - if (defined &GetConsoleCP) { - my $cp = GetConsoleCP(); - $ENCODING_LOCALE = "cp$cp" if $cp; - } - }; - } - - unless ($ENCODING_CONSOLE_IN) { - # only test one since set together - unless (defined &GetInputCP) { - eval { - require Win32; - eval { Win32::GetConsoleCP() }; - # manually "import" it since Win32->import refuses - *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; - *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP; - }; - unless (defined &GetInputCP) { - eval { - # try Win32::Console module for codepage to use - require Win32::Console; - *GetInputCP = sub { &Win32::Console::InputCP } - if defined &Win32::Console::InputCP; - *GetOutputCP = sub { &Win32::Console::OutputCP } - if defined &Win32::Console::OutputCP; - }; - } - unless (defined &GetInputCP) { - # final fallback - *GetInputCP = *GetOutputCP = sub { - # another fallback that could work is: - # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP - ((qx(chcp) || '') =~ /^Active code page: (\d+)/) - ? $1 : (); - }; - } - } - my $cp = GetInputCP(); - $ENCODING_CONSOLE_IN = "cp$cp" if $cp; - $cp = GetOutputCP(); - $ENCODING_CONSOLE_OUT = "cp$cp" if $cp; - } - } - - unless ($ENCODING_LOCALE) { - eval { - require I18N::Langinfo; - $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); - - # Workaround of Encode < v2.25. The "646" encoding alias was - # introduced in Encode-2.25, but we don't want to require that version - # quite yet. Should avoid the CPAN testers failure reported from - # openbsd-4.7/perl-5.10.0 combo. - $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646"; - - # https://rt.cpan.org/Ticket/Display.html?id=66373 - $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"; - }; - $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN; - } - - if ($^O eq "darwin") { - $ENCODING_LOCALE_FS ||= "UTF-8"; - } - - # final fallback - $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8"; - $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE; - $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE; - $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN; - - unless (Encode::find_encoding($ENCODING_LOCALE)) { - my $foundit; - if (lc($ENCODING_LOCALE) eq "gb18030") { - eval { - require Encode::HanExtra; - }; - if ($@) { - die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"; - } - $foundit++ if Encode::find_encoding($ENCODING_LOCALE); - } - die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" - unless $foundit; - - } - - # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT; -} - -_init(); -Encode::Alias::define_alias(sub { - no strict 'refs'; - no warnings 'once'; - return ${"ENCODING_" . uc(shift)}; -}, "locale"); - -sub _flush_aliases { - no strict 'refs'; - for my $a (sort keys %Encode::Alias::Alias) { - if (defined ${"ENCODING_" . uc($a)}) { - delete $Encode::Alias::Alias{$a}; - warn "Flushed alias cache for $a" if DEBUG; - } - } -} - -sub reinit { - $ENCODING_LOCALE = shift; - $ENCODING_LOCALE_FS = shift; - $ENCODING_CONSOLE_IN = $ENCODING_LOCALE; - $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE; - _init(); - _flush_aliases(); -} - -sub decode_argv { - die if defined wantarray; - for (@ARGV) { - $_ = Encode::decode(locale => $_, @_); - } -} - -sub env { - my $k = Encode::encode(locale => shift); - my $old = $ENV{$k}; - if (@_) { - my $v = shift; - if (defined $v) { - $ENV{$k} = Encode::encode(locale => $v); - } - else { - delete $ENV{$k}; - } - } - return Encode::decode(locale => $old) if defined wantarray; -} - -1; - -__END__ - -=head1 NAME - -ExtUtils::MakeMaker::Locale - bundled Encode::Locale - -=head1 SYNOPSIS - - use Encode::Locale; - use Encode; - - $string = decode(locale => $bytes); - $bytes = encode(locale => $string); - - if (-t) { - binmode(STDIN, ":encoding(console_in)"); - binmode(STDOUT, ":encoding(console_out)"); - binmode(STDERR, ":encoding(console_out)"); - } - - # Processing file names passed in as arguments - my $uni_filename = decode(locale => $ARGV[0]); - open(my $fh, "<", encode(locale_fs => $uni_filename)) - || die "Can't open '$uni_filename': $!"; - binmode($fh, ":encoding(locale)"); - ... - -=head1 DESCRIPTION - -In many applications it's wise to let Perl use Unicode for the strings it -processes. Most of the interfaces Perl has to the outside world are still byte -based. Programs therefore need to decode byte strings that enter the program -from the outside and encode them again on the way out. - -The POSIX locale system is used to specify both the language conventions -requested by the user and the preferred character set to consume and -output. The C module looks up the charset and encoding (called -a CODESET in the locale jargon) and arranges for the L module to know -this encoding under the name "locale". It means bytes obtained from the -environment can be converted to Unicode strings by calling C<< -Encode::encode(locale => $bytes) >> and converted back again with C<< -Encode::decode(locale => $string) >>. - -Where file systems interfaces pass file names in and out of the program we also -need care. The trend is for operating systems to use a fixed file encoding -that don't actually depend on the locale; and this module determines the most -appropriate encoding for file names. The L module will know this -encoding under the name "locale_fs". For traditional Unix systems this will -be an alias to the same encoding as "locale". - -For programs running in a terminal window (called a "Console" on some systems) -the "locale" encoding is usually a good choice for what to expect as input and -output. Some systems allows us to query the encoding set for the terminal and -C will do that if available and make these encodings known -under the C aliases "console_in" and "console_out". For systems where -we can't determine the terminal encoding these will be aliased as the same -encoding as "locale". The advice is to use "console_in" for input known to -come from the terminal and "console_out" for output to the terminal. - -In addition to arranging for various Encode aliases the following functions and -variables are provided: - -=over - -=item decode_argv( ) - -=item decode_argv( Encode::FB_CROAK ) - -This will decode the command line arguments to perl (the C<@ARGV> array) in-place. - -The function will by default replace characters that can't be decoded by -"\x{FFFD}", the Unicode replacement character. - -Any argument provided is passed as CHECK to underlying Encode::decode() call. -Pass the value C to have the decoding croak if not all the -command line arguments can be decoded. See L -for details on other options for CHECK. - -=item env( $uni_key ) - -=item env( $uni_key => $uni_value ) - -Interface to get/set environment variables. Returns the current value as a -Unicode string. The $uni_key and $uni_value arguments are expected to be -Unicode strings as well. Passing C as $uni_value deletes the -environment variable named $uni_key. - -The returned value will have the characters that can't be decoded replaced by -"\x{FFFD}", the Unicode replacement character. - -There is no interface to request alternative CHECK behavior as for -decode_argv(). If you need that you need to call encode/decode yourself. -For example: - - my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK); - my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK); - -=item reinit( ) - -=item reinit( $encoding ) - -Reinitialize the encodings from the locale. You want to call this function if -you changed anything in the environment that might influence the locale. - -This function will croak if the determined encoding isn't recognized by -the Encode module. - -With argument force $ENCODING_... variables to set to the given value. - -=item $ENCODING_LOCALE - -The encoding name determined to be suitable for the current locale. -L know this encoding as "locale". - -=item $ENCODING_LOCALE_FS - -The encoding name determined to be suitable for file system interfaces -involving file names. -L know this encoding as "locale_fs". - -=item $ENCODING_CONSOLE_IN - -=item $ENCODING_CONSOLE_OUT - -The encodings to be used for reading and writing output to the a console. -L know these encodings as "console_in" and "console_out". - -=back - -=head1 NOTES - -This table summarizes the mapping of the encodings set up -by the C module: - - Encode | | | - Alias | Windows | Mac OS X | POSIX - ------------+---------+--------------+------------ - locale | ANSI | nl_langinfo | nl_langinfo - locale_fs | ANSI | UTF-8 | nl_langinfo - console_in | OEM | nl_langinfo | nl_langinfo - console_out | OEM | nl_langinfo | nl_langinfo - -=head2 Windows - -Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16 -strings) and a byte based API based a character set called ANSI. The -regular Perl interfaces to the OS currently only uses the ANSI APIs. -Unfortunately ANSI is not a single character set. - -The encoding that corresponds to ANSI varies between different editions of -Windows. For many western editions of Windows ANSI corresponds to CP-1252 -which is a character set similar to ISO-8859-1. Conceptually the ANSI -character set is a similar concept to the POSIX locale CODESET so this module -figures out what the ANSI code page is and make this available as -$ENCODING_LOCALE and the "locale" Encoding alias. - -Windows systems also operate with another byte based character set. -It's called the OEM code page. This is the encoding that the Console -takes as input and output. It's common for the OEM code page to -differ from the ANSI code page. - -=head2 Mac OS X - -On Mac OS X the file system encoding is always UTF-8 while the locale -can otherwise be set up as normal for POSIX systems. - -File names on Mac OS X will at the OS-level be converted to -NFD-form. A file created by passing a NFC-filename will come -in NFD-form from readdir(). See L for details -of NFD/NFC. - -Actually, Apple does not follow the Unicode NFD standard since not all -character ranges are decomposed. The claim is that this avoids problems with -round trip conversions from old Mac text encodings. See L for -details. - -=head2 POSIX (Linux and other Unixes) - -File systems might vary in what encoding is to be used for -filenames. Since this module has no way to actually figure out -what the is correct it goes with the best guess which is to -assume filenames are encoding according to the current locale. -Users are advised to always specify UTF-8 as the locale charset. - -=head1 SEE ALSO - -L, L, L - -=head1 AUTHOR - -Copyright 2010 Gisle Aas . - -This library is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -=cut diff --git a/lib/ExtUtils/MakeMaker/version.pm b/lib/ExtUtils/MakeMaker/version.pm deleted file mode 100644 index c59be1e..0000000 --- a/lib/ExtUtils/MakeMaker/version.pm +++ /dev/null @@ -1,56 +0,0 @@ -#--------------------------------------------------------------------------# -# This is a modified copy of version.pm 0.9909, bundled exclusively for -# use by ExtUtils::Makemaker and its dependencies to bootstrap when -# version.pm is not available. It should not be used by ordinary modules. -# -# When loaded, it will try to load version.pm. If that fails, it will load -# ExtUtils::MakeMaker::version::vpp and alias various *version functions -# to functions in that module. It will also override UNIVERSAL::VERSION. -#--------------------------------------------------------------------------# - -package ExtUtils::MakeMaker::version; - -use 5.006001; -use strict; - -use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); - -$VERSION = '7.34'; -$VERSION = eval $VERSION; -$CLASS = 'version'; - -{ - local $SIG{'__DIE__'}; - eval "use version"; - if ( $@ ) { # don't have any version.pm installed - eval "use ExtUtils::MakeMaker::version::vpp"; - die "$@" if ( $@ ); - local $^W; - delete $INC{'version.pm'}; - $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'}; - push @version::ISA, "ExtUtils::MakeMaker::version::vpp"; - $version::VERSION = $VERSION; - *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv; - *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare; - *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION; - *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp; - *version::new = \&ExtUtils::MakeMaker::version::vpp::new; - if ($] >= 5.009000) { - no strict 'refs'; - *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify; - *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify; - *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp; - *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse; - } - require ExtUtils::MakeMaker::version::regex; - *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; - *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; - *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; - *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; - } - elsif ( ! version->can('is_qv') ) { - *version::is_qv = sub { exists $_[0]->{qv} }; - } -} - -1; diff --git a/lib/ExtUtils/MakeMaker/version/regex.pm b/lib/ExtUtils/MakeMaker/version/regex.pm deleted file mode 100644 index f0eb14e..0000000 --- a/lib/ExtUtils/MakeMaker/version/regex.pm +++ /dev/null @@ -1,124 +0,0 @@ -#--------------------------------------------------------------------------# -# This is a modified copy of version.pm 0.9909, bundled exclusively for -# use by ExtUtils::Makemaker and its dependencies to bootstrap when -# version.pm is not available. It should not be used by ordinary modules. -#--------------------------------------------------------------------------# - -package ExtUtils::MakeMaker::version::regex; - -use strict; - -use vars qw($VERSION $CLASS $STRICT $LAX); - -$VERSION = '7.34'; -$VERSION = eval $VERSION; - -#--------------------------------------------------------------------------# -# Version regexp components -#--------------------------------------------------------------------------# - -# Fraction part of a decimal version number. This is a common part of -# both strict and lax decimal versions - -my $FRACTION_PART = qr/\.[0-9]+/; - -# First part of either decimal or dotted-decimal strict version number. -# Unsigned integer with no leading zeroes (except for zero itself) to -# avoid confusion with octal. - -my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; - -# First part of either decimal or dotted-decimal lax version number. -# Unsigned integer, but allowing leading zeros. Always interpreted -# as decimal. However, some forms of the resulting syntax give odd -# results if used as ordinary Perl expressions, due to how perl treats -# octals. E.g. -# version->new("010" ) == 10 -# version->new( 010 ) == 8 -# version->new( 010.2) == 82 # "8" . "2" - -my $LAX_INTEGER_PART = qr/[0-9]+/; - -# Second and subsequent part of a strict dotted-decimal version number. -# Leading zeroes are permitted, and the number is always decimal. -# Limited to three digits to avoid overflow when converting to decimal -# form and also avoid problematic style with excessive leading zeroes. - -my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; - -# Second and subsequent part of a lax dotted-decimal version number. -# Leading zeroes are permitted, and the number is always decimal. No -# limit on the numerical value or number of digits, so there is the -# possibility of overflow when converting to decimal form. - -my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; - -# Alpha suffix part of lax version number syntax. Acts like a -# dotted-decimal part. - -my $LAX_ALPHA_PART = qr/_[0-9]+/; - -#--------------------------------------------------------------------------# -# Strict version regexp definitions -#--------------------------------------------------------------------------# - -# Strict decimal version number. - -my $STRICT_DECIMAL_VERSION = - qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; - -# Strict dotted-decimal version number. Must have both leading "v" and -# at least three parts, to avoid confusion with decimal syntax. - -my $STRICT_DOTTED_DECIMAL_VERSION = - qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; - -# Complete strict version number syntax -- should generally be used -# anchored: qr/ \A $STRICT \z /x - -$STRICT = - qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; - -#--------------------------------------------------------------------------# -# Lax version regexp definitions -#--------------------------------------------------------------------------# - -# Lax decimal version number. Just like the strict one except for -# allowing an alpha suffix or allowing a leading or trailing -# decimal-point - -my $LAX_DECIMAL_VERSION = - qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? - | - $FRACTION_PART $LAX_ALPHA_PART? - /x; - -# Lax dotted-decimal version number. Distinguished by having either -# leading "v" or at least three non-alpha parts. Alpha part is only -# permitted if there are at least two non-alpha parts. Strangely -# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, -# so when there is no "v", the leading part is optional - -my $LAX_DOTTED_DECIMAL_VERSION = - qr/ - v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? - | - $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? - /x; - -# Complete lax version number syntax -- should generally be used -# anchored: qr/ \A $LAX \z /x -# -# The string 'undef' is a special case to make for easier handling -# of return values from ExtUtils::MM->parse_version - -$LAX = - qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; - -#--------------------------------------------------------------------------# - -# Preloaded methods go here. -sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } -sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } - -1; diff --git a/lib/ExtUtils/MakeMaker/version/vpp.pm b/lib/ExtUtils/MakeMaker/version/vpp.pm deleted file mode 100644 index 00b34ff..0000000 --- a/lib/ExtUtils/MakeMaker/version/vpp.pm +++ /dev/null @@ -1,1029 +0,0 @@ -#--------------------------------------------------------------------------# -# This is a modified copy of version.pm 0.9909, bundled exclusively for -# use by ExtUtils::Makemaker and its dependencies to bootstrap when -# version.pm is not available. It should not be used by ordinary modules. -#--------------------------------------------------------------------------# - -package ExtUtils::MakeMaker::charstar; -# a little helper class to emulate C char* semantics in Perl -# so that prescan_version can use the same code as in C - -use overload ( - '""' => \&thischar, - '0+' => \&thischar, - '++' => \&increment, - '--' => \&decrement, - '+' => \&plus, - '-' => \&minus, - '*' => \&multiply, - 'cmp' => \&cmp, - '<=>' => \&spaceship, - 'bool' => \&thischar, - '=' => \&clone, -); - -sub new { - my ($self, $string) = @_; - my $class = ref($self) || $self; - - my $obj = { - string => [split(//,$string)], - current => 0, - }; - return bless $obj, $class; -} - -sub thischar { - my ($self) = @_; - my $last = $#{$self->{string}}; - my $curr = $self->{current}; - if ($curr >= 0 && $curr <= $last) { - return $self->{string}->[$curr]; - } - else { - return ''; - } -} - -sub increment { - my ($self) = @_; - $self->{current}++; -} - -sub decrement { - my ($self) = @_; - $self->{current}--; -} - -sub plus { - my ($self, $offset) = @_; - my $rself = $self->clone; - $rself->{current} += $offset; - return $rself; -} - -sub minus { - my ($self, $offset) = @_; - my $rself = $self->clone; - $rself->{current} -= $offset; - return $rself; -} - -sub multiply { - my ($left, $right, $swapped) = @_; - my $char = $left->thischar(); - return $char * $right; -} - -sub spaceship { - my ($left, $right, $swapped) = @_; - unless (ref($right)) { # not an object already - $right = $left->new($right); - } - return $left->{current} <=> $right->{current}; -} - -sub cmp { - my ($left, $right, $swapped) = @_; - unless (ref($right)) { # not an object already - if (length($right) == 1) { # comparing single character only - return $left->thischar cmp $right; - } - $right = $left->new($right); - } - return $left->currstr cmp $right->currstr; -} - -sub bool { - my ($self) = @_; - my $char = $self->thischar; - return ($char ne ''); -} - -sub clone { - my ($left, $right, $swapped) = @_; - $right = { - string => [@{$left->{string}}], - current => $left->{current}, - }; - return bless $right, ref($left); -} - -sub currstr { - my ($self, $s) = @_; - my $curr = $self->{current}; - my $last = $#{$self->{string}}; - if (defined($s) && $s->{current} < $last) { - $last = $s->{current}; - } - - my $string = join('', @{$self->{string}}[$curr..$last]); - return $string; -} - -package ExtUtils::MakeMaker::version::vpp; - -use 5.006001; -use strict; - -use Config; -use vars qw($VERSION $CLASS @ISA $LAX $STRICT); -$VERSION = '7.34'; -$VERSION = eval $VERSION; -$CLASS = 'ExtUtils::MakeMaker::version::vpp'; - -require ExtUtils::MakeMaker::version::regex; -*ExtUtils::MakeMaker::version::vpp::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; -*ExtUtils::MakeMaker::version::vpp::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; -*LAX = \$ExtUtils::MakeMaker::version::regex::LAX; -*STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; - -use overload ( - '""' => \&stringify, - '0+' => \&numify, - 'cmp' => \&vcmp, - '<=>' => \&vcmp, - 'bool' => \&vbool, - '+' => \&vnoop, - '-' => \&vnoop, - '*' => \&vnoop, - '/' => \&vnoop, - '+=' => \&vnoop, - '-=' => \&vnoop, - '*=' => \&vnoop, - '/=' => \&vnoop, - 'abs' => \&vnoop, -); - -eval "use warnings"; -if ($@) { - eval ' - package - warnings; - sub enabled {return $^W;} - 1; - '; -} - -sub import { - no strict 'refs'; - my ($class) = shift; - - # Set up any derived class - unless ($class eq $CLASS) { - local $^W; - *{$class.'::declare'} = \&{$CLASS.'::declare'}; - *{$class.'::qv'} = \&{$CLASS.'::qv'}; - } - - my %args; - if (@_) { # any remaining terms are arguments - map { $args{$_} = 1 } @_ - } - else { # no parameters at all on use line - %args = - ( - qv => 1, - 'UNIVERSAL::VERSION' => 1, - ); - } - - my $callpkg = caller(); - - if (exists($args{declare})) { - *{$callpkg.'::declare'} = - sub {return $class->declare(shift) } - unless defined(&{$callpkg.'::declare'}); - } - - if (exists($args{qv})) { - *{$callpkg.'::qv'} = - sub {return $class->qv(shift) } - unless defined(&{$callpkg.'::qv'}); - } - - if (exists($args{'UNIVERSAL::VERSION'})) { - local $^W; - *UNIVERSAL::VERSION - = \&{$CLASS.'::_VERSION'}; - } - - if (exists($args{'VERSION'})) { - *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; - } - - if (exists($args{'is_strict'})) { - *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} - unless defined(&{$callpkg.'::is_strict'}); - } - - if (exists($args{'is_lax'})) { - *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} - unless defined(&{$callpkg.'::is_lax'}); - } -} - -my $VERSION_MAX = 0x7FFFFFFF; - -# implement prescan_version as closely to the C version as possible -use constant TRUE => 1; -use constant FALSE => 0; - -sub isDIGIT { - my ($char) = shift->thischar(); - return ($char =~ /\d/); -} - -sub isALPHA { - my ($char) = shift->thischar(); - return ($char =~ /[a-zA-Z]/); -} - -sub isSPACE { - my ($char) = shift->thischar(); - return ($char =~ /\s/); -} - -sub BADVERSION { - my ($s, $errstr, $error) = @_; - if ($errstr) { - $$errstr = $error; - } - return $s; -} - -sub prescan_version { - my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; - my $qv = defined $sqv ? $$sqv : FALSE; - my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; - my $width = defined $swidth ? $$swidth : 3; - my $alpha = defined $salpha ? $$salpha : FALSE; - - my $d = $s; - - if ($qv && isDIGIT($d)) { - goto dotted_decimal_version; - } - - if ($d eq 'v') { # explicit v-string - $d++; - if (isDIGIT($d)) { - $qv = TRUE; - } - else { # degenerate v-string - # requires v1.2.3 - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - -dotted_decimal_version: - if ($strict && $d eq '0' && isDIGIT($d+1)) { - # no leading zeros allowed - return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); - } - - while (isDIGIT($d)) { # integer part - $d++; - } - - if ($d eq '.') - { - $saw_decimal++; - $d++; # decimal point - } - else - { - if ($strict) { - # require v1.2.3 - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - else { - goto version_prescan_finish; - } - } - - { - my $i = 0; - my $j = 0; - while (isDIGIT($d)) { # just keep reading - $i++; - while (isDIGIT($d)) { - $d++; $j++; - # maximum 3 digits between decimal - if ($strict && $j > 3) { - return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); - } - } - if ($d eq '_') { - if ($strict) { - return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); - } - if ( $alpha ) { - return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); - } - $d++; - $alpha = TRUE; - } - elsif ($d eq '.') { - if ($alpha) { - return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); - } - $saw_decimal++; - $d++; - } - elsif (!isDIGIT($d)) { - last; - } - $j = 0; - } - - if ($strict && $i < 2) { - # requires v1.2.3 - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - } - } # end if dotted-decimal - else - { # decimal versions - my $j = 0; - # special $strict case for leading '.' or '0' - if ($strict) { - if ($d eq '.') { - return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); - } - if ($d eq '0' && isDIGIT($d+1)) { - return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); - } - } - - # and we never support negative version numbers - if ($d eq '-') { - return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); - } - - # consume all of the integer part - while (isDIGIT($d)) { - $d++; - } - - # look for a fractional part - if ($d eq '.') { - # we found it, so consume it - $saw_decimal++; - $d++; - } - elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { - if ( $d == $s ) { - # found nothing - return BADVERSION($s,$errstr,"Invalid version format (version required)"); - } - # found just an integer - goto version_prescan_finish; - } - elsif ( $d == $s ) { - # didn't find either integer or period - return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); - } - elsif ($d eq '_') { - # underscore can't come after integer part - if ($strict) { - return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); - } - elsif (isDIGIT($d+1)) { - return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); - } - else { - return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); - } - } - elsif ($d) { - # anything else after integer part is just invalid data - return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); - } - - # scan the fractional part after the decimal point - if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { - # $strict or lax-but-not-the-end - return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); - } - - while (isDIGIT($d)) { - $d++; $j++; - if ($d eq '.' && isDIGIT($d-1)) { - if ($alpha) { - return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); - } - if ($strict) { - return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); - } - $d = $s; # start all over again - $qv = TRUE; - goto dotted_decimal_version; - } - if ($d eq '_') { - if ($strict) { - return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); - } - if ( $alpha ) { - return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); - } - if ( ! isDIGIT($d+1) ) { - return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); - } - $width = $j; - $d++; - $alpha = TRUE; - } - } - } - -version_prescan_finish: - while (isSPACE($d)) { - $d++; - } - - if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { - # trailing non-numeric data - return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); - } - - if (defined $sqv) { - $$sqv = $qv; - } - if (defined $swidth) { - $$swidth = $width; - } - if (defined $ssaw_decimal) { - $$ssaw_decimal = $saw_decimal; - } - if (defined $salpha) { - $$salpha = $alpha; - } - return $d; -} - -sub scan_version { - my ($s, $rv, $qv) = @_; - my $start; - my $pos; - my $last; - my $errstr; - my $saw_decimal = 0; - my $width = 3; - my $alpha = FALSE; - my $vinf = FALSE; - my @av; - - $s = new ExtUtils::MakeMaker::charstar $s; - - while (isSPACE($s)) { # leading whitespace is OK - $s++; - } - - $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, - \$width, \$alpha); - - if ($errstr) { - # 'undef' is a special case and not an error - if ( $s ne 'undef') { - require Carp; - Carp::croak($errstr); - } - } - - $start = $s; - if ($s eq 'v') { - $s++; - } - $pos = $s; - - if ( $qv ) { - $$rv->{qv} = $qv; - } - if ( $alpha ) { - $$rv->{alpha} = $alpha; - } - if ( !$qv && $width < 3 ) { - $$rv->{width} = $width; - } - - while (isDIGIT($pos)) { - $pos++; - } - if (!isALPHA($pos)) { - my $rev; - - for (;;) { - $rev = 0; - { - # this is atoi() that delimits on underscores - my $end = $pos; - my $mult = 1; - my $orev; - - # the following if() will only be true after the decimal - # point of a version originally created with a bare - # floating point number, i.e. not quoted in any way - # - if ( !$qv && $s > $start && $saw_decimal == 1 ) { - $mult *= 100; - while ( $s < $end ) { - $orev = $rev; - $rev += $s * $mult; - $mult /= 10; - if ( (abs($orev) > abs($rev)) - || (abs($rev) > $VERSION_MAX )) { - warn("Integer overflow in version %d", - $VERSION_MAX); - $s = $end - 1; - $rev = $VERSION_MAX; - $vinf = 1; - } - $s++; - if ( $s eq '_' ) { - $s++; - } - } - } - else { - while (--$end >= $s) { - $orev = $rev; - $rev += $end * $mult; - $mult *= 10; - if ( (abs($orev) > abs($rev)) - || (abs($rev) > $VERSION_MAX )) { - warn("Integer overflow in version"); - $end = $s - 1; - $rev = $VERSION_MAX; - $vinf = 1; - } - } - } - } - - # Append revision - push @av, $rev; - if ( $vinf ) { - $s = $last; - last; - } - elsif ( $pos eq '.' ) { - $s = ++$pos; - } - elsif ( $pos eq '_' && isDIGIT($pos+1) ) { - $s = ++$pos; - } - elsif ( $pos eq ',' && isDIGIT($pos+1) ) { - $s = ++$pos; - } - elsif ( isDIGIT($pos) ) { - $s = $pos; - } - else { - $s = $pos; - last; - } - if ( $qv ) { - while ( isDIGIT($pos) ) { - $pos++; - } - } - else { - my $digits = 0; - while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { - if ( $pos ne '_' ) { - $digits++; - } - $pos++; - } - } - } - } - if ( $qv ) { # quoted versions always get at least three terms - my $len = $#av; - # This for loop appears to trigger a compiler bug on OS X, as it - # loops infinitely. Yes, len is negative. No, it makes no sense. - # Compiler in question is: - # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) - # for ( len = 2 - len; len > 0; len-- ) - # av_push(MUTABLE_AV(sv), newSViv(0)); - # - $len = 2 - $len; - while ($len-- > 0) { - push @av, 0; - } - } - - # need to save off the current version string for later - if ( $vinf ) { - $$rv->{original} = "v.Inf"; - $$rv->{vinf} = 1; - } - elsif ( $s > $start ) { - $$rv->{original} = $start->currstr($s); - if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { - # need to insert a v to be consistent - $$rv->{original} = 'v' . $$rv->{original}; - } - } - else { - $$rv->{original} = '0'; - push(@av, 0); - } - - # And finally, store the AV in the hash - $$rv->{version} = \@av; - - # fix RT#19517 - special case 'undef' as string - if ($s eq 'undef') { - $s += 5; - } - - return $s; -} - -sub new { - my $class = shift; - unless (defined $class or $#_ > 1) { - require Carp; - Carp::croak('Usage: version::new(class, version)'); - } - - my $self = bless ({}, ref ($class) || $class); - my $qv = FALSE; - - if ( $#_ == 1 ) { # must be CVS-style - $qv = TRUE; - } - my $value = pop; # always going to be the last element - - if ( ref($value) && eval('$value->isa("version")') ) { - # Can copy the elements directly - $self->{version} = [ @{$value->{version} } ]; - $self->{qv} = 1 if $value->{qv}; - $self->{alpha} = 1 if $value->{alpha}; - $self->{original} = ''.$value->{original}; - return $self; - } - - if ( not defined $value or $value =~ /^undef$/ ) { - # RT #19517 - special case for undef comparison - # or someone forgot to pass a value - push @{$self->{version}}, 0; - $self->{original} = "0"; - return ($self); - } - - - if (ref($value) =~ m/ARRAY|HASH/) { - require Carp; - Carp::croak("Invalid version format (non-numeric data)"); - } - - $value = _un_vstring($value); - - if ($Config{d_setlocale} && eval { require POSIX } ) { - require locale; - my $currlocale = POSIX::setlocale(&POSIX::LC_ALL); - - # if the current locale uses commas for decimal points, we - # just replace commas with decimal places, rather than changing - # locales - if ( POSIX::localeconv()->{decimal_point} eq ',' ) { - $value =~ tr/,/./; - } - } - - # exponential notation - if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { - $value = sprintf("%.9f",$value); - $value =~ s/(0+)$//; # trim trailing zeros - } - - my $s = scan_version($value, \$self, $qv); - - if ($s) { # must be something left over - warn("Version string '%s' contains invalid data; " - ."ignoring: '%s'", $value, $s); - } - - return ($self); -} - -*parse = \&new; - -sub numify { - my ($self) = @_; - unless (_verify($self)) { - require Carp; - Carp::croak("Invalid version object"); - } - my $width = $self->{width} || 3; - my $alpha = $self->{alpha} || ""; - my $len = $#{$self->{version}}; - my $digit = $self->{version}[0]; - my $string = sprintf("%d.", $digit ); - - for ( my $i = 1 ; $i < $len ; $i++ ) { - $digit = $self->{version}[$i]; - if ( $width < 3 ) { - my $denom = 10**(3-$width); - my $quot = int($digit/$denom); - my $rem = $digit - ($quot * $denom); - $string .= sprintf("%0".$width."d_%d", $quot, $rem); - } - else { - $string .= sprintf("%03d", $digit); - } - } - - if ( $len > 0 ) { - $digit = $self->{version}[$len]; - if ( $alpha && $width == 3 ) { - $string .= "_"; - } - $string .= sprintf("%0".$width."d", $digit); - } - else # $len = 0 - { - $string .= sprintf("000"); - } - - return $string; -} - -sub normal { - my ($self) = @_; - unless (_verify($self)) { - require Carp; - Carp::croak("Invalid version object"); - } - my $alpha = $self->{alpha} || ""; - my $len = $#{$self->{version}}; - my $digit = $self->{version}[0]; - my $string = sprintf("v%d", $digit ); - - for ( my $i = 1 ; $i < $len ; $i++ ) { - $digit = $self->{version}[$i]; - $string .= sprintf(".%d", $digit); - } - - if ( $len > 0 ) { - $digit = $self->{version}[$len]; - if ( $alpha ) { - $string .= sprintf("_%0d", $digit); - } - else { - $string .= sprintf(".%0d", $digit); - } - } - - if ( $len <= 2 ) { - for ( $len = 2 - $len; $len != 0; $len-- ) { - $string .= sprintf(".%0d", 0); - } - } - - return $string; -} - -sub stringify { - my ($self) = @_; - unless (_verify($self)) { - require Carp; - Carp::croak("Invalid version object"); - } - return exists $self->{original} - ? $self->{original} - : exists $self->{qv} - ? $self->normal - : $self->numify; -} - -sub vcmp { - require UNIVERSAL; - my ($left,$right,$swap) = @_; - my $class = ref($left); - unless ( UNIVERSAL::isa($right, $class) ) { - $right = $class->new($right); - } - - if ( $swap ) { - ($left, $right) = ($right, $left); - } - unless (_verify($left)) { - require Carp; - Carp::croak("Invalid version object"); - } - unless (_verify($right)) { - require Carp; - Carp::croak("Invalid version format"); - } - my $l = $#{$left->{version}}; - my $r = $#{$right->{version}}; - my $m = $l < $r ? $l : $r; - my $lalpha = $left->is_alpha; - my $ralpha = $right->is_alpha; - my $retval = 0; - my $i = 0; - while ( $i <= $m && $retval == 0 ) { - $retval = $left->{version}[$i] <=> $right->{version}[$i]; - $i++; - } - - # tiebreaker for alpha with identical terms - if ( $retval == 0 - && $l == $r - && $left->{version}[$m] == $right->{version}[$m] - && ( $lalpha || $ralpha ) ) { - - if ( $lalpha && !$ralpha ) { - $retval = -1; - } - elsif ( $ralpha && !$lalpha) { - $retval = +1; - } - } - - # possible match except for trailing 0's - if ( $retval == 0 && $l != $r ) { - if ( $l < $r ) { - while ( $i <= $r && $retval == 0 ) { - if ( $right->{version}[$i] != 0 ) { - $retval = -1; # not a match after all - } - $i++; - } - } - else { - while ( $i <= $l && $retval == 0 ) { - if ( $left->{version}[$i] != 0 ) { - $retval = +1; # not a match after all - } - $i++; - } - } - } - - return $retval; -} - -sub vbool { - my ($self) = @_; - return vcmp($self,$self->new("0"),1); -} - -sub vnoop { - require Carp; - Carp::croak("operation not supported with version object"); -} - -sub is_alpha { - my ($self) = @_; - return (exists $self->{alpha}); -} - -sub qv { - my $value = shift; - my $class = $CLASS; - if (@_) { - $class = ref($value) || $value; - $value = shift; - } - - $value = _un_vstring($value); - $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; - my $obj = $CLASS->new($value); - return bless $obj, $class; -} - -*declare = \&qv; - -sub is_qv { - my ($self) = @_; - return (exists $self->{qv}); -} - - -sub _verify { - my ($self) = @_; - if ( ref($self) - && eval { exists $self->{version} } - && ref($self->{version}) eq 'ARRAY' - ) { - return 1; - } - else { - return 0; - } -} - -sub _is_non_alphanumeric { - my $s = shift; - $s = new ExtUtils::MakeMaker::charstar $s; - while ($s) { - return 0 if isSPACE($s); # early out - return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); - $s++; - } - return 0; -} - -sub _un_vstring { - my $value = shift; - # may be a v-string - if ( length($value) >= 3 && $value !~ /[._]/ - && _is_non_alphanumeric($value)) { - my $tvalue; - if ( $] ge 5.008_001 ) { - $tvalue = _find_magic_vstring($value); - $value = $tvalue if length $tvalue; - } - elsif ( $] ge 5.006_000 ) { - $tvalue = sprintf("v%vd",$value); - if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) { - # must be a v-string - $value = $tvalue; - } - } - } - return $value; -} - -sub _find_magic_vstring { - my $value = shift; - my $tvalue = ''; - require B; - my $sv = B::svref_2object(\$value); - my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; - while ( $magic ) { - if ( $magic->TYPE eq 'V' ) { - $tvalue = $magic->PTR; - $tvalue =~ s/^v?(.+)$/v$1/; - last; - } - else { - $magic = $magic->MOREMAGIC; - } - } - return $tvalue; -} - -sub _VERSION { - my ($obj, $req) = @_; - my $class = ref($obj) || $obj; - - no strict 'refs'; - if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { - # file but no package - require Carp; - Carp::croak( "$class defines neither package nor VERSION" - ."--version check failed"); - } - - my $version = eval "\$$class\::VERSION"; - if ( defined $version ) { - local $^W if $] <= 5.008; - $version = ExtUtils::MakeMaker::version::vpp->new($version); - } - - if ( defined $req ) { - unless ( defined $version ) { - require Carp; - my $msg = $] < 5.006 - ? "$class version $req required--this is only version " - : "$class does not define \$$class\::VERSION" - ."--version check failed"; - - if ( $ENV{VERSION_DEBUG} ) { - Carp::confess($msg); - } - else { - Carp::croak($msg); - } - } - - $req = ExtUtils::MakeMaker::version::vpp->new($req); - - if ( $req > $version ) { - require Carp; - if ( $req->is_qv ) { - Carp::croak( - sprintf ("%s version %s required--". - "this is only version %s", $class, - $req->normal, $version->normal) - ); - } - else { - Carp::croak( - sprintf ("%s version %s required--". - "this is only version %s", $class, - $req->stringify, $version->stringify) - ); - } - } - } - - return defined $version ? $version->stringify : undef; -} - -1; #this line is important and will help the module return a true value diff --git a/t/lib/Test/Builder.pm b/t/lib/Test/Builder.pm deleted file mode 100644 index 847a26c..0000000 --- a/t/lib/Test/Builder.pm +++ /dev/null @@ -1,2659 +0,0 @@ -package Test::Builder; - -use 5.006; -use strict; -use warnings; - -our $VERSION = '0.99'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - -BEGIN { - if( $] < 5.008 ) { - require Test::Builder::IO::Scalar; - } -} - - -# Make Test::Builder thread-safe for ithreads. -BEGIN { - use Config; - # Load threads::shared when threads are turned on. - # 5.8.0's threads are so busted we no longer support them. - if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) { - require threads::shared; - - # Hack around YET ANOTHER threads::shared bug. It would - # occasionally forget the contents of the variable when sharing it. - # So we first copy the data, then share, then put our copy back. - *share = sub (\[$@%]) { - my $type = ref $_[0]; - my $data; - - if( $type eq 'HASH' ) { - %$data = %{ $_[0] }; - } - elsif( $type eq 'ARRAY' ) { - @$data = @{ $_[0] }; - } - elsif( $type eq 'SCALAR' ) { - $$data = ${ $_[0] }; - } - else { - die( "Unknown type: " . $type ); - } - - $_[0] = &threads::shared::share( $_[0] ); - - if( $type eq 'HASH' ) { - %{ $_[0] } = %$data; - } - elsif( $type eq 'ARRAY' ) { - @{ $_[0] } = @$data; - } - elsif( $type eq 'SCALAR' ) { - ${ $_[0] } = $$data; - } - else { - die( "Unknown type: " . $type ); - } - - return $_[0]; - }; - } - # 5.8.0's threads::shared is busted when threads are off - # and earlier Perls just don't have that module at all. - else { - *share = sub { return $_[0] }; - *lock = sub { 0 }; - } -} - -=head1 NAME - -Test::Builder - Backend for building test libraries - -=head1 SYNOPSIS - - package My::Test::Module; - use base 'Test::Builder::Module'; - - my $CLASS = __PACKAGE__; - - sub ok { - my($test, $name) = @_; - my $tb = $CLASS->builder; - - $tb->ok($test, $name); - } - - -=head1 DESCRIPTION - -Test::Simple and Test::More have proven to be popular testing modules, -but they're not always flexible enough. Test::Builder provides a -building block upon which to write your own test libraries I. - -=head2 Construction - -=over 4 - -=item B - - my $Test = Test::Builder->new; - -Returns a Test::Builder object representing the current state of the -test. - -Since you only run one test per program C always returns the same -Test::Builder object. No matter how many times you call C, you're -getting the same object. This is called a singleton. This is done so that -multiple modules share such global information as the test counter and -where test output is going. - -If you want a completely new Test::Builder object different from the -singleton, use C. - -=cut - -our $Test = Test::Builder->new; - -sub new { - my($class) = shift; - $Test ||= $class->create; - return $Test; -} - -=item B - - my $Test = Test::Builder->create; - -Ok, so there can be more than one Test::Builder object and this is how -you get it. You might use this instead of C if you're testing -a Test::Builder based module, but otherwise you probably want C. - -B: the implementation is not complete. C, for example, is -still shared amongst B Test::Builder objects, even ones created using -this method. Also, the method name may change in the future. - -=cut - -sub create { - my $class = shift; - - my $self = bless {}, $class; - $self->reset; - - return $self; -} - - -# Copy an object, currently a shallow. -# This does *not* bless the destination. This keeps the destructor from -# firing when we're just storing a copy of the object to restore later. -sub _copy { - my($src, $dest) = @_; - - %$dest = %$src; - _share_keys($dest); - - return; -} - - -=item B - - my $child = $builder->child($name_of_child); - $child->plan( tests => 4 ); - $child->ok(some_code()); - ... - $child->finalize; - -Returns a new instance of C. Any output from this child will -be indented four spaces more than the parent's indentation. When done, the -C method I be called explicitly. - -Trying to create a new child with a previous child still active (i.e., -C not called) will C. - -Trying to run a test when you have an open child will also C and cause -the test suite to fail. - -=cut - -sub child { - my( $self, $name ) = @_; - - if( $self->{Child_Name} ) { - $self->croak("You already have a child named ($self->{Child_Name}) running"); - } - - my $parent_in_todo = $self->in_todo; - - # Clear $TODO for the child. - my $orig_TODO = $self->find_TODO(undef, 1, undef); - - my $class = ref $self; - my $child = $class->create; - - # Add to our indentation - $child->_indent( $self->_indent . ' ' ); - - # Make the child use the same outputs as the parent - for my $method (qw(output failure_output todo_output)) { - $child->$method( $self->$method ); - } - - # Ensure the child understands if they're inside a TODO - if( $parent_in_todo ) { - $child->failure_output( $self->todo_output ); - } - - # This will be reset in finalize. We do this here lest one child failure - # cause all children to fail. - $child->{Child_Error} = $?; - $? = 0; - $child->{Parent} = $self; - $child->{Parent_TODO} = $orig_TODO; - $child->{Name} = $name || "Child of " . $self->name; - $self->{Child_Name} = $child->name; - return $child; -} - - -=item B - - $builder->subtest($name, \&subtests); - -See documentation of C in Test::More. - -=cut - -sub subtest { - my $self = shift; - my($name, $subtests) = @_; - - if ('CODE' ne ref $subtests) { - $self->croak("subtest()'s second argument must be a code ref"); - } - - # Turn the child into the parent so anyone who has stored a copy of - # the Test::Builder singleton will get the child. - my $error; - my $child; - my $parent = {}; - { - # child() calls reset() which sets $Level to 1, so we localize - # $Level first to limit the scope of the reset to the subtest. - local $Test::Builder::Level = $Test::Builder::Level + 1; - - # Store the guts of $self as $parent and turn $child into $self. - $child = $self->child($name); - _copy($self, $parent); - _copy($child, $self); - - my $run_the_subtests = sub { - # Add subtest name for clarification of starting point - $self->note("Subtest: $name"); - $subtests->(); - $self->done_testing unless $self->_plan_handled; - 1; - }; - - if( !eval { $run_the_subtests->() } ) { - $error = $@; - } - } - - # Restore the parent and the copied child. - _copy($self, $child); - _copy($parent, $self); - - # Restore the parent's $TODO - $self->find_TODO(undef, 1, $child->{Parent_TODO}); - - # Die *after* we restore the parent. - die $error if $error and !eval { $error->isa('Test::Builder::Exception') }; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $finalize = $child->finalize; - - $self->BAIL_OUT($child->{Bailed_Out_Reason}) if $child->{Bailed_Out}; - - return $finalize; -} - -=begin _private - -=item B<_plan_handled> - - if ( $Test->_plan_handled ) { ... } - -Returns true if the developer has explicitly handled the plan via: - -=over 4 - -=item * Explicitly setting the number of tests - -=item * Setting 'no_plan' - -=item * Set 'skip_all'. - -=back - -This is currently used in subtests when we implicitly call C<< $Test->done_testing >> -if the developer has not set a plan. - -=end _private - -=cut - -sub _plan_handled { - my $self = shift; - return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All}; -} - - -=item B - - my $ok = $child->finalize; - -When your child is done running tests, you must call C to clean up -and tell the parent your pass/fail status. - -Calling finalize on a child with open children will C. - -If the child falls out of scope before C is called, a failure -diagnostic will be issued and the child is considered to have failed. - -No attempt to call methods on a child after C is called is -guaranteed to succeed. - -Calling this on the root builder is a no-op. - -=cut - -sub finalize { - my $self = shift; - - return unless $self->parent; - if( $self->{Child_Name} ) { - $self->croak("Can't call finalize() with child ($self->{Child_Name}) active"); - } - - local $? = 0; # don't fail if $subtests happened to set $? nonzero - $self->_ending; - - # XXX This will only be necessary for TAP envelopes (we think) - #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" ); - - local $Test::Builder::Level = $Test::Builder::Level + 1; - my $ok = 1; - $self->parent->{Child_Name} = undef; - unless ($self->{Bailed_Out}) { - if ( $self->{Skip_All} ) { - $self->parent->skip($self->{Skip_All}); - } - elsif ( not @{ $self->{Test_Results} } ) { - $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name ); - } - else { - $self->parent->ok( $self->is_passing, $self->name ); - } - } - $? = $self->{Child_Error}; - delete $self->{Parent}; - - return $self->is_passing; -} - -sub _indent { - my $self = shift; - - if( @_ ) { - $self->{Indent} = shift; - } - - return $self->{Indent}; -} - -=item B - - if ( my $parent = $builder->parent ) { - ... - } - -Returns the parent C instance, if any. Only used with child -builders for nested TAP. - -=cut - -sub parent { shift->{Parent} } - -=item B - - diag $builder->name; - -Returns the name of the current builder. Top level builders default to C<$0> -(the name of the executable). Child builders are named via the C -method. If no name is supplied, will be named "Child of $parent->name". - -=cut - -sub name { shift->{Name} } - -sub DESTROY { - my $self = shift; - if ( $self->parent and $$ == $self->{Original_Pid} ) { - my $name = $self->name; - $self->diag(<<"FAIL"); -Child ($name) exited without calling finalize() -FAIL - $self->parent->{In_Destroy} = 1; - $self->parent->ok(0, $name); - } -} - -=item B - - $Test->reset; - -Reinitializes the Test::Builder singleton to its original state. -Mostly useful for tests run in persistent environments where the same -test might be run multiple times in the same process. - -=cut - -our $Level; - -sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my($self) = @_; - - # We leave this a global because it has to be localized and localizing - # hash keys is just asking for pain. Also, it was documented. - $Level = 1; - - $self->{Name} = $0; - $self->is_passing(1); - $self->{Ending} = 0; - $self->{Have_Plan} = 0; - $self->{No_Plan} = 0; - $self->{Have_Output_Plan} = 0; - $self->{Done_Testing} = 0; - - $self->{Original_Pid} = $$; - $self->{Child_Name} = undef; - $self->{Indent} ||= ''; - - $self->{Curr_Test} = 0; - $self->{Test_Results} = &share( [] ); - - $self->{Exported_To} = undef; - $self->{Expected_Tests} = 0; - - $self->{Skip_All} = 0; - - $self->{Use_Nums} = 1; - - $self->{No_Header} = 0; - $self->{No_Ending} = 0; - - $self->{Todo} = undef; - $self->{Todo_Stack} = []; - $self->{Start_Todo} = 0; - $self->{Opened_Testhandles} = 0; - - $self->_share_keys; - $self->_dup_stdhandles; - - return; -} - - -# Shared scalar values are lost when a hash is copied, so we have -# a separate method to restore them. -# Shared references are retained across copies. -sub _share_keys { - my $self = shift; - - share( $self->{Curr_Test} ); - - return; -} - - -=back - -=head2 Setting up tests - -These methods are for setting up tests and declaring how many there -are. You usually only want to call one of these methods. - -=over 4 - -=item B - - $Test->plan('no_plan'); - $Test->plan( skip_all => $reason ); - $Test->plan( tests => $num_tests ); - -A convenient way to set up your tests. Call this and Test::Builder -will print the appropriate headers and take the appropriate actions. - -If you call C, don't call any of the other methods below. - -If a child calls "skip_all" in the plan, a C is -thrown. Trap this error, call C and don't run any more tests on -the child. - - my $child = $Test->child('some child'); - eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 ) ) }; - if ( eval { $@->isa('Test::Builder::Exception') } ) { - $child->finalize; - return; - } - # run your tests - -=cut - -my %plan_cmds = ( - no_plan => \&no_plan, - skip_all => \&skip_all, - tests => \&_plan_tests, -); - -sub plan { - my( $self, $cmd, $arg ) = @_; - - return unless $cmd; - - local $Level = $Level + 1; - - $self->croak("You tried to plan twice") if $self->{Have_Plan}; - - if( my $method = $plan_cmds{$cmd} ) { - local $Level = $Level + 1; - $self->$method($arg); - } - else { - my @args = grep { defined } ( $cmd, $arg ); - $self->croak("plan() doesn't understand @args"); - } - - return 1; -} - - -sub _plan_tests { - my($self, $arg) = @_; - - if($arg) { - local $Level = $Level + 1; - return $self->expected_tests($arg); - } - elsif( !defined $arg ) { - $self->croak("Got an undefined number of tests"); - } - else { - $self->croak("You said to run 0 tests"); - } - - return; -} - -=item B - - my $max = $Test->expected_tests; - $Test->expected_tests($max); - -Gets/sets the number of tests we expect this test to run and prints out -the appropriate headers. - -=cut - -sub expected_tests { - my $self = shift; - my($max) = @_; - - if(@_) { - $self->croak("Number of tests must be a positive integer. You gave it '$max'") - unless $max =~ /^\+?\d+$/; - - $self->{Expected_Tests} = $max; - $self->{Have_Plan} = 1; - - $self->_output_plan($max) unless $self->no_header; - } - return $self->{Expected_Tests}; -} - -=item B - - $Test->no_plan; - -Declares that this test will run an indeterminate number of tests. - -=cut - -sub no_plan { - my($self, $arg) = @_; - - $self->carp("no_plan takes no arguments") if $arg; - - $self->{No_Plan} = 1; - $self->{Have_Plan} = 1; - - return 1; -} - -=begin private - -=item B<_output_plan> - - $tb->_output_plan($max); - $tb->_output_plan($max, $directive); - $tb->_output_plan($max, $directive => $reason); - -Handles displaying the test plan. - -If a C<$directive> and/or C<$reason> are given they will be output with the -plan. So here's what skipping all tests looks like: - - $tb->_output_plan(0, "SKIP", "Because I said so"); - -It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already -output. - -=end private - -=cut - -sub _output_plan { - my($self, $max, $directive, $reason) = @_; - - $self->carp("The plan was already output") if $self->{Have_Output_Plan}; - - my $plan = "1..$max"; - $plan .= " # $directive" if defined $directive; - $plan .= " $reason" if defined $reason; - - $self->_print("$plan\n"); - - $self->{Have_Output_Plan} = 1; - - return; -} - - -=item B - - $Test->done_testing(); - $Test->done_testing($num_tests); - -Declares that you are done testing, no more tests will be run after this point. - -If a plan has not yet been output, it will do so. - -$num_tests is the number of tests you planned to run. If a numbered -plan was already declared, and if this contradicts, a failing test -will be run to reflect the planning mistake. If C was declared, -this will override. - -If C is called twice, the second call will issue a -failing test. - -If C<$num_tests> is omitted, the number of tests run will be used, like -no_plan. - -C is, in effect, used when you'd want to use C, but -safer. You'd use it like so: - - $Test->ok($a == $b); - $Test->done_testing(); - -Or to plan a variable number of tests: - - for my $test (@tests) { - $Test->ok($test); - } - $Test->done_testing(scalar @tests); - -=cut - -sub done_testing { - my($self, $num_tests) = @_; - - # If done_testing() specified the number of tests, shut off no_plan. - if( defined $num_tests ) { - $self->{No_Plan} = 0; - } - else { - $num_tests = $self->current_test; - } - - if( $self->{Done_Testing} ) { - my($file, $line) = @{$self->{Done_Testing}}[1,2]; - $self->ok(0, "done_testing() was already called at $file line $line"); - return; - } - - $self->{Done_Testing} = [caller]; - - if( $self->expected_tests && $num_tests != $self->expected_tests ) { - $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". - "but done_testing() expects $num_tests"); - } - else { - $self->{Expected_Tests} = $num_tests; - } - - $self->_output_plan($num_tests) unless $self->{Have_Output_Plan}; - - $self->{Have_Plan} = 1; - - # The wrong number of tests were run - $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test}; - - # No tests were run - $self->is_passing(0) if $self->{Curr_Test} == 0; - - return 1; -} - - -=item B - - $plan = $Test->has_plan - -Find out whether a plan has been defined. C<$plan> is either C (no plan -has been set), C (indeterminate # of tests) or an integer (the number -of expected tests). - -=cut - -sub has_plan { - my $self = shift; - - return( $self->{Expected_Tests} ) if $self->{Expected_Tests}; - return('no_plan') if $self->{No_Plan}; - return(undef); -} - -=item B - - $Test->skip_all; - $Test->skip_all($reason); - -Skips all the tests, using the given C<$reason>. Exits immediately with 0. - -=cut - -sub skip_all { - my( $self, $reason ) = @_; - - $self->{Skip_All} = $self->parent ? $reason : 1; - - $self->_output_plan(0, "SKIP", $reason) unless $self->no_header; - if ( $self->parent ) { - die bless {} => 'Test::Builder::Exception'; - } - exit(0); -} - -=item B - - my $pack = $Test->exported_to; - $Test->exported_to($pack); - -Tells Test::Builder what package you exported your functions to. - -This method isn't terribly useful since modules which share the same -Test::Builder object might get exported to different packages and only -the last one will be honored. - -=cut - -sub exported_to { - my( $self, $pack ) = @_; - - if( defined $pack ) { - $self->{Exported_To} = $pack; - } - return $self->{Exported_To}; -} - -=back - -=head2 Running tests - -These actually run the tests, analogous to the functions in Test::More. - -They all return true if the test passed, false if the test failed. - -C<$name> is always optional. - -=over 4 - -=item B - - $Test->ok($test, $name); - -Your basic test. Pass if C<$test> is true, fail if $test is false. Just -like Test::Simple's C. - -=cut - -sub ok { - my( $self, $test, $name ) = @_; - - if ( $self->{Child_Name} and not $self->{In_Destroy} ) { - $name = 'unnamed test' unless defined $name; - $self->is_passing(0); - $self->croak("Cannot run test ($name) with active children"); - } - # $test might contain an object which we don't want to accidentally - # store, so we turn it into a boolean. - $test = $test ? 1 : 0; - - lock $self->{Curr_Test}; - $self->{Curr_Test}++; - - # In case $name is a string overloaded object, force it to stringify. - $self->_unoverload_str( \$name ); - - $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/; - You named your test '$name'. You shouldn't use numbers for your test names. - Very confusing. -ERR - - # Capture the value of $TODO for the rest of this ok() call - # so it can more easily be found by other routines. - my $todo = $self->todo(); - my $in_todo = $self->in_todo; - local $self->{Todo} = $todo if $in_todo; - - $self->_unoverload_str( \$todo ); - - my $out; - my $result = &share( {} ); - - unless($test) { - $out .= "not "; - @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 ); - } - else { - @$result{ 'ok', 'actual_ok' } = ( 1, $test ); - } - - $out .= "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - - if( defined $name ) { - $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. - $out .= " - $name"; - $result->{name} = $name; - } - else { - $result->{name} = ''; - } - - if( $self->in_todo ) { - $out .= " # TODO $todo"; - $result->{reason} = $todo; - $result->{type} = 'todo'; - } - else { - $result->{reason} = ''; - $result->{type} = ''; - } - - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result; - $out .= "\n"; - - $self->_print($out); - - unless($test) { - my $msg = $self->in_todo ? "Failed (TODO)" : "Failed"; - $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE}; - - my( undef, $file, $line ) = $self->caller; - if( defined $name ) { - $self->diag(qq[ $msg test '$name'\n]); - $self->diag(qq[ at $file line $line.\n]); - } - else { - $self->diag(qq[ $msg test at $file line $line.\n]); - } - } - - $self->is_passing(0) unless $test || $self->in_todo; - - # Check that we haven't violated the plan - $self->_check_is_passing_plan(); - - return $test ? 1 : 0; -} - - -# Check that we haven't yet violated the plan and set -# is_passing() accordingly -sub _check_is_passing_plan { - my $self = shift; - - my $plan = $self->has_plan; - return unless defined $plan; # no plan yet defined - return unless $plan !~ /\D/; # no numeric plan - $self->is_passing(0) if $plan < $self->{Curr_Test}; -} - - -sub _unoverload { - my $self = shift; - my $type = shift; - - $self->_try(sub { require overload; }, die_on_fail => 1); - - foreach my $thing (@_) { - if( $self->_is_object($$thing) ) { - if( my $string_meth = overload::Method( $$thing, $type ) ) { - $$thing = $$thing->$string_meth(); - } - } - } - - return; -} - -sub _is_object { - my( $self, $thing ) = @_; - - return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0; -} - -sub _unoverload_str { - my $self = shift; - - return $self->_unoverload( q[""], @_ ); -} - -sub _unoverload_num { - my $self = shift; - - $self->_unoverload( '0+', @_ ); - - for my $val (@_) { - next unless $self->_is_dualvar($$val); - $$val = $$val + 0; - } - - return; -} - -# This is a hack to detect a dualvar such as $! -sub _is_dualvar { - my( $self, $val ) = @_; - - # Objects are not dualvars. - return 0 if ref $val; - - no warnings 'numeric'; - my $numval = $val + 0; - return ($numval != 0 and $numval ne $val ? 1 : 0); -} - -=item B - - $Test->is_eq($got, $expected, $name); - -Like Test::More's C. Checks if C<$got eq $expected>. This is the -string version. - -C only ever matches another C. - -=item B - - $Test->is_num($got, $expected, $name); - -Like Test::More's C. Checks if C<$got == $expected>. This is the -numeric version. - -C only ever matches another C. - -=cut - -sub is_eq { - my( $self, $got, $expect, $name ) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $expect ) { - # undef only matches undef and nothing else - my $test = !defined $got && !defined $expect; - - $self->ok( $test, $name ); - $self->_is_diag( $got, 'eq', $expect ) unless $test; - return $test; - } - - return $self->cmp_ok( $got, 'eq', $expect, $name ); -} - -sub is_num { - my( $self, $got, $expect, $name ) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $expect ) { - # undef only matches undef and nothing else - my $test = !defined $got && !defined $expect; - - $self->ok( $test, $name ); - $self->_is_diag( $got, '==', $expect ) unless $test; - return $test; - } - - return $self->cmp_ok( $got, '==', $expect, $name ); -} - -sub _diag_fmt { - my( $self, $type, $val ) = @_; - - if( defined $$val ) { - if( $type eq 'eq' or $type eq 'ne' ) { - # quote and force string context - $$val = "'$$val'"; - } - else { - # force numeric context - $self->_unoverload_num($val); - } - } - else { - $$val = 'undef'; - } - - return; -} - -sub _is_diag { - my( $self, $got, $type, $expect ) = @_; - - $self->_diag_fmt( $type, $_ ) for \$got, \$expect; - - local $Level = $Level + 1; - return $self->diag(<<"DIAGNOSTIC"); - got: $got - expected: $expect -DIAGNOSTIC - -} - -sub _isnt_diag { - my( $self, $got, $type ) = @_; - - $self->_diag_fmt( $type, \$got ); - - local $Level = $Level + 1; - return $self->diag(<<"DIAGNOSTIC"); - got: $got - expected: anything else -DIAGNOSTIC -} - -=item B - - $Test->isnt_eq($got, $dont_expect, $name); - -Like Test::More's C. Checks if C<$got ne $dont_expect>. This is -the string version. - -=item B - - $Test->isnt_num($got, $dont_expect, $name); - -Like Test::More's C. Checks if C<$got ne $dont_expect>. This is -the numeric version. - -=cut - -sub isnt_eq { - my( $self, $got, $dont_expect, $name ) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $dont_expect ) { - # undef only matches undef and nothing else - my $test = defined $got || defined $dont_expect; - - $self->ok( $test, $name ); - $self->_isnt_diag( $got, 'ne' ) unless $test; - return $test; - } - - return $self->cmp_ok( $got, 'ne', $dont_expect, $name ); -} - -sub isnt_num { - my( $self, $got, $dont_expect, $name ) = @_; - local $Level = $Level + 1; - - if( !defined $got || !defined $dont_expect ) { - # undef only matches undef and nothing else - my $test = defined $got || defined $dont_expect; - - $self->ok( $test, $name ); - $self->_isnt_diag( $got, '!=' ) unless $test; - return $test; - } - - return $self->cmp_ok( $got, '!=', $dont_expect, $name ); -} - -=item B - - $Test->like($thing, qr/$regex/, $name); - $Test->like($thing, '/$regex/', $name); - -Like Test::More's C. Checks if $thing matches the given C<$regex>. - -=item B - - $Test->unlike($thing, qr/$regex/, $name); - $Test->unlike($thing, '/$regex/', $name); - -Like Test::More's C. Checks if $thing B the -given C<$regex>. - -=cut - -sub like { - my( $self, $thing, $regex, $name ) = @_; - - local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '=~', $name ); -} - -sub unlike { - my( $self, $thing, $regex, $name ) = @_; - - local $Level = $Level + 1; - return $self->_regex_ok( $thing, $regex, '!~', $name ); -} - -=item B - - $Test->cmp_ok($thing, $type, $that, $name); - -Works just like Test::More's C. - - $Test->cmp_ok($big_num, '!=', $other_big_num); - -=cut - -my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); - -# Bad, these are not comparison operators. Should we include more? -my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); - -sub cmp_ok { - my( $self, $got, $type, $expect, $name ) = @_; - - if ($cmp_ok_bl{$type}) { - $self->croak("$type is not a valid comparison operator in cmp_ok()"); - } - - my $test; - my $error; - { - ## no critic (BuiltinFunctions::ProhibitStringyEval) - - local( $@, $!, $SIG{__DIE__} ); # isolate eval - - my($pack, $file, $line) = $self->caller(); - - # This is so that warnings come out at the caller's level - $test = eval qq[ -#line $line "(eval in cmp_ok) $file" -\$got $type \$expect; -]; - $error = $@; - } - local $Level = $Level + 1; - my $ok = $self->ok( $test, $name ); - - # Treat overloaded objects as numbers if we're asked to do a - # numeric comparison. - my $unoverload - = $numeric_cmps{$type} - ? '_unoverload_num' - : '_unoverload_str'; - - $self->diag(<<"END") if $error; -An error occurred while using $type: ------------------------------------- -$error ------------------------------------- -END - - unless($ok) { - $self->$unoverload( \$got, \$expect ); - - if( $type =~ /^(eq|==)$/ ) { - $self->_is_diag( $got, $type, $expect ); - } - elsif( $type =~ /^(ne|!=)$/ ) { - $self->_isnt_diag( $got, $type ); - } - else { - $self->_cmp_diag( $got, $type, $expect ); - } - } - return $ok; -} - -sub _cmp_diag { - my( $self, $got, $type, $expect ) = @_; - - $got = defined $got ? "'$got'" : 'undef'; - $expect = defined $expect ? "'$expect'" : 'undef'; - - local $Level = $Level + 1; - return $self->diag(<<"DIAGNOSTIC"); - $got - $type - $expect -DIAGNOSTIC -} - -sub _caller_context { - my $self = shift; - - my( $pack, $file, $line ) = $self->caller(1); - - my $code = ''; - $code .= "#line $line $file\n" if defined $file and defined $line; - - return $code; -} - -=back - - -=head2 Other Testing Methods - -These are methods which are used in the course of writing a test but are not themselves tests. - -=over 4 - -=item B - - $Test->BAIL_OUT($reason); - -Indicates to the Test::Harness that things are going so badly all -testing should terminate. This includes running any additional test -scripts. - -It will exit with 255. - -=cut - -sub BAIL_OUT { - my( $self, $reason ) = @_; - - $self->{Bailed_Out} = 1; - - if ($self->parent) { - $self->{Bailed_Out_Reason} = $reason; - $self->no_ending(1); - die bless {} => 'Test::Builder::Exception'; - } - - $self->_print("Bail out! $reason"); - exit 255; -} - -=for deprecated -BAIL_OUT() used to be BAILOUT() - -=cut - -{ - no warnings 'once'; - *BAILOUT = \&BAIL_OUT; -} - -=item B - - $Test->skip; - $Test->skip($why); - -Skips the current test, reporting C<$why>. - -=cut - -sub skip { - my( $self, $why ) = @_; - $why ||= ''; - $self->_unoverload_str( \$why ); - - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; - - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( - { - 'ok' => 1, - actual_ok => 1, - name => '', - type => 'skip', - reason => $why, - } - ); - - my $out = "ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # skip"; - $out .= " $why" if length $why; - $out .= "\n"; - - $self->_print($out); - - return 1; -} - -=item B - - $Test->todo_skip; - $Test->todo_skip($why); - -Like C, only it will declare the test as failing and TODO. Similar -to - - print "not ok $tnum # TODO $why\n"; - -=cut - -sub todo_skip { - my( $self, $why ) = @_; - $why ||= ''; - - lock( $self->{Curr_Test} ); - $self->{Curr_Test}++; - - $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share( - { - 'ok' => 1, - actual_ok => 0, - name => '', - type => 'todo_skip', - reason => $why, - } - ); - - my $out = "not ok"; - $out .= " $self->{Curr_Test}" if $self->use_numbers; - $out .= " # TODO & SKIP $why\n"; - - $self->_print($out); - - return 1; -} - -=begin _unimplemented - -=item B - - $Test->skip_rest; - $Test->skip_rest($reason); - -Like C, only it skips all the rest of the tests you plan to run -and terminates the test. - -If you're running under C, it skips once and terminates the -test. - -=end _unimplemented - -=back - - -=head2 Test building utility methods - -These methods are useful when writing your own test methods. - -=over 4 - -=item B - - $Test->maybe_regex(qr/$regex/); - $Test->maybe_regex('/$regex/'); - -This method used to be useful back when Test::Builder worked on Perls -before 5.6 which didn't have qr//. Now its pretty useless. - -Convenience method for building testing functions that take regular -expressions as arguments. - -Takes a quoted regular expression produced by C, or a string -representing a regular expression. - -Returns a Perl value which may be used instead of the corresponding -regular expression, or C if its argument is not recognised. - -For example, a version of C, sans the useful diagnostic messages, -could be written as: - - sub laconic_like { - my ($self, $thing, $regex, $name) = @_; - my $usable_regex = $self->maybe_regex($regex); - die "expecting regex, found '$regex'\n" - unless $usable_regex; - $self->ok($thing =~ m/$usable_regex/, $name); - } - -=cut - -sub maybe_regex { - my( $self, $regex ) = @_; - my $usable_regex = undef; - - return $usable_regex unless defined $regex; - - my( $re, $opts ); - - # Check for qr/foo/ - if( _is_qr($regex) ) { - $usable_regex = $regex; - } - # Check for '/foo/' or 'm,foo,' - elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or - ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx - ) - { - $usable_regex = length $opts ? "(?$opts)$re" : $re; - } - - return $usable_regex; -} - -sub _is_qr { - my $regex = shift; - - # is_regexp() checks for regexes in a robust manner, say if they're - # blessed. - return re::is_regexp($regex) if defined &re::is_regexp; - return ref $regex eq 'Regexp'; -} - -sub _regex_ok { - my( $self, $thing, $regex, $cmp, $name ) = @_; - - my $ok = 0; - my $usable_regex = $self->maybe_regex($regex); - unless( defined $usable_regex ) { - local $Level = $Level + 1; - $ok = $self->ok( 0, $name ); - $self->diag(" '$regex' doesn't look much like a regex to me."); - return $ok; - } - - { - my $test; - my $context = $self->_caller_context; - - { - ## no critic (BuiltinFunctions::ProhibitStringyEval) - - local( $@, $!, $SIG{__DIE__} ); # isolate eval - - # No point in issuing an uninit warning, they'll see it in the diagnostics - no warnings 'uninitialized'; - - $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; - } - - $test = !$test if $cmp eq '!~'; - - local $Level = $Level + 1; - $ok = $self->ok( $test, $name ); - } - - unless($ok) { - $thing = defined $thing ? "'$thing'" : 'undef'; - my $match = $cmp eq '=~' ? "doesn't match" : "matches"; - - local $Level = $Level + 1; - $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); - %s - %13s '%s' -DIAGNOSTIC - - } - - return $ok; -} - -# I'm not ready to publish this. It doesn't deal with array return -# values from the code or context. - -=begin private - -=item B<_try> - - my $return_from_code = $Test->try(sub { code }); - my($return_from_code, $error) = $Test->try(sub { code }); - -Works like eval BLOCK except it ensures it has no effect on the rest -of the test (ie. C<$@> is not set) nor is effected by outside -interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older -Perls. - -C<$error> is what would normally be in C<$@>. - -It is suggested you use this in place of eval BLOCK. - -=cut - -sub _try { - my( $self, $code, %opts ) = @_; - - my $error; - my $return; - { - local $!; # eval can mess up $! - local $@; # don't set $@ in the test - local $SIG{__DIE__}; # don't trip an outside DIE handler. - $return = eval { $code->() }; - $error = $@; - } - - die $error if $error and $opts{die_on_fail}; - - return wantarray ? ( $return, $error ) : $return; -} - -=end private - - -=item B - - my $is_fh = $Test->is_fh($thing); - -Determines if the given C<$thing> can be used as a filehandle. - -=cut - -sub is_fh { - my $self = shift; - my $maybe_fh = shift; - return 0 unless defined $maybe_fh; - - return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref - return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob - - return eval { $maybe_fh->isa("IO::Handle") } || - eval { tied($maybe_fh)->can('TIEHANDLE') }; -} - -=back - - -=head2 Test style - - -=over 4 - -=item B - - $Test->level($how_high); - -How far up the call stack should C<$Test> look when reporting where the -test failed. - -Defaults to 1. - -Setting L<$Test::Builder::Level> overrides. This is typically useful -localized: - - sub my_ok { - my $test = shift; - - local $Test::Builder::Level = $Test::Builder::Level + 1; - $TB->ok($test); - } - -To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. - -=cut - -sub level { - my( $self, $level ) = @_; - - if( defined $level ) { - $Level = $level; - } - return $Level; -} - -=item B - - $Test->use_numbers($on_or_off); - -Whether or not the test should output numbers. That is, this if true: - - ok 1 - ok 2 - ok 3 - -or this if false - - ok - ok - ok - -Most useful when you can't depend on the test output order, such as -when threads or forking is involved. - -Defaults to on. - -=cut - -sub use_numbers { - my( $self, $use_nums ) = @_; - - if( defined $use_nums ) { - $self->{Use_Nums} = $use_nums; - } - return $self->{Use_Nums}; -} - -=item B - - $Test->no_diag($no_diag); - -If set true no diagnostics will be printed. This includes calls to -C. - -=item B - - $Test->no_ending($no_ending); - -Normally, Test::Builder does some extra diagnostics when the test -ends. It also changes the exit code as described below. - -If this is true, none of that will be done. - -=item B - - $Test->no_header($no_header); - -If set to true, no "1..N" header will be printed. - -=cut - -foreach my $attribute (qw(No_Header No_Ending No_Diag)) { - my $method = lc $attribute; - - my $code = sub { - my( $self, $no ) = @_; - - if( defined $no ) { - $self->{$attribute} = $no; - } - return $self->{$attribute}; - }; - - no strict 'refs'; ## no critic - *{ __PACKAGE__ . '::' . $method } = $code; -} - -=back - -=head2 Output - -Controlling where the test output goes. - -It's ok for your test to change where STDOUT and STDERR point to, -Test::Builder's default output settings will not be affected. - -=over 4 - -=item B - - $Test->diag(@msgs); - -Prints out the given C<@msgs>. Like C, arguments are simply -appended together. - -Normally, it uses the C handle, but if this is for a -TODO test, the C handle is used. - -Output will be indented and marked with a # so as not to interfere -with test output. A newline will be put on the end if there isn't one -already. - -We encourage using this rather than calling print directly. - -Returns false. Why? Because C is often used in conjunction with -a failing test (C) it "passes through" the failure. - - return ok(...) || diag(...); - -=for blame transfer -Mark Fowler - -=cut - -sub diag { - my $self = shift; - - $self->_print_comment( $self->_diag_fh, @_ ); -} - -=item B - - $Test->note(@msgs); - -Like C, but it prints to the C handle so it will not -normally be seen by the user except in verbose mode. - -=cut - -sub note { - my $self = shift; - - $self->_print_comment( $self->output, @_ ); -} - -sub _diag_fh { - my $self = shift; - - local $Level = $Level + 1; - return $self->in_todo ? $self->todo_output : $self->failure_output; -} - -sub _print_comment { - my( $self, $fh, @msgs ) = @_; - - return if $self->no_diag; - return unless @msgs; - - # Prevent printing headers when compiling (i.e. -c) - return if $^C; - - # Smash args together like print does. - # Convert undef to 'undef' so its readable. - my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; - - # Escape the beginning, _print will take care of the rest. - $msg =~ s/^/# /; - - local $Level = $Level + 1; - $self->_print_to_fh( $fh, $msg ); - - return 0; -} - -=item B - - my @dump = $Test->explain(@msgs); - -Will dump the contents of any references in a human readable format. -Handy for things like... - - is_deeply($have, $want) || diag explain $have; - -or - - is_deeply($have, $want) || note explain $have; - -=cut - -sub explain { - my $self = shift; - - return map { - ref $_ - ? do { - $self->_try(sub { require Data::Dumper }, die_on_fail => 1); - - my $dumper = Data::Dumper->new( [$_] ); - $dumper->Indent(1)->Terse(1); - $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); - $dumper->Dump; - } - : $_ - } @_; -} - -=begin _private - -=item B<_print> - - $Test->_print(@msgs); - -Prints to the C filehandle. - -=end _private - -=cut - -sub _print { - my $self = shift; - return $self->_print_to_fh( $self->output, @_ ); -} - -sub _print_to_fh { - my( $self, $fh, @msgs ) = @_; - - # Prevent printing headers when only compiling. Mostly for when - # tests are deparsed with B::Deparse - return if $^C; - - my $msg = join '', @msgs; - my $indent = $self->_indent; - - local( $\, $", $, ) = ( undef, ' ', '' ); - - # Escape each line after the first with a # so we don't - # confuse Test::Harness. - $msg =~ s{\n(?!\z)}{\n$indent# }sg; - - # Stick a newline on the end if it needs it. - $msg .= "\n" unless $msg =~ /\n\z/; - - return print $fh $indent, $msg; -} - -=item B - -=item B - -=item B - - my $filehandle = $Test->output; - $Test->output($filehandle); - $Test->output($filename); - $Test->output(\$scalar); - -These methods control where Test::Builder will print its output. -They take either an open C<$filehandle>, a C<$filename> to open and write to -or a C<$scalar> reference to append to. It will always return a C<$filehandle>. - -B is where normal "ok/not ok" test output goes. - -Defaults to STDOUT. - -B is where diagnostic output on test failures and -C goes. It is normally not read by Test::Harness and instead is -displayed to the user. - -Defaults to STDERR. - -C is used instead of C for the -diagnostics of a failing TODO test. These will not be seen by the -user. - -Defaults to STDOUT. - -=cut - -sub output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Out_FH} = $self->_new_fh($fh); - } - return $self->{Out_FH}; -} - -sub failure_output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Fail_FH} = $self->_new_fh($fh); - } - return $self->{Fail_FH}; -} - -sub todo_output { - my( $self, $fh ) = @_; - - if( defined $fh ) { - $self->{Todo_FH} = $self->_new_fh($fh); - } - return $self->{Todo_FH}; -} - -sub _new_fh { - my $self = shift; - my($file_or_fh) = shift; - - my $fh; - if( $self->is_fh($file_or_fh) ) { - $fh = $file_or_fh; - } - elsif( ref $file_or_fh eq 'SCALAR' ) { - # Scalar refs as filehandles was added in 5.8. - if( $] >= 5.008 ) { - open $fh, ">>", $file_or_fh - or $self->croak("Can't open scalar ref $file_or_fh: $!"); - } - # Emulate scalar ref filehandles with a tie. - else { - $fh = Test::Builder::IO::Scalar->new($file_or_fh) - or $self->croak("Can't tie scalar ref $file_or_fh"); - } - } - else { - open $fh, ">", $file_or_fh - or $self->croak("Can't open test output log $file_or_fh: $!"); - _autoflush($fh); - } - - return $fh; -} - -sub _autoflush { - my($fh) = shift; - my $old_fh = select $fh; - $| = 1; - select $old_fh; - - return; -} - -my( $Testout, $Testerr ); - -sub _dup_stdhandles { - my $self = shift; - - $self->_open_testhandles; - - # Set everything to unbuffered else plain prints to STDOUT will - # come out in the wrong order from our own prints. - _autoflush($Testout); - _autoflush( \*STDOUT ); - _autoflush($Testerr); - _autoflush( \*STDERR ); - - $self->reset_outputs; - - return; -} - -sub _open_testhandles { - my $self = shift; - - return if $self->{Opened_Testhandles}; - - # We dup STDOUT and STDERR so people can change them in their - # test suites while still getting normal test output. - open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!"; - open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!"; - - $self->_copy_io_layers( \*STDOUT, $Testout ); - $self->_copy_io_layers( \*STDERR, $Testerr ); - - $self->{Opened_Testhandles} = 1; - - return; -} - -sub _copy_io_layers { - my( $self, $src, $dst ) = @_; - - $self->_try( - sub { - require PerlIO; - my @src_layers = PerlIO::get_layers($src); - - _apply_layers($dst, @src_layers) if @src_layers; - } - ); - - return; -} - -sub _apply_layers { - my ($fh, @layers) = @_; - my %seen; - my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers; - binmode($fh, join(":", "", "raw", @unique)); -} - - -=item reset_outputs - - $tb->reset_outputs; - -Resets all the output filehandles back to their defaults. - -=cut - -sub reset_outputs { - my $self = shift; - - $self->output ($Testout); - $self->failure_output($Testerr); - $self->todo_output ($Testout); - - return; -} - -=item carp - - $tb->carp(@message); - -Warns with C<@message> but the message will appear to come from the -point where the original test function was called (C<< $tb->caller >>). - -=item croak - - $tb->croak(@message); - -Dies with C<@message> but the message will appear to come from the -point where the original test function was called (C<< $tb->caller >>). - -=cut - -sub _message_at_caller { - my $self = shift; - - local $Level = $Level + 1; - my( $pack, $file, $line ) = $self->caller; - return join( "", @_ ) . " at $file line $line.\n"; -} - -sub carp { - my $self = shift; - return warn $self->_message_at_caller(@_); -} - -sub croak { - my $self = shift; - return die $self->_message_at_caller(@_); -} - - -=back - - -=head2 Test Status and Info - -=over 4 - -=item B - - my $curr_test = $Test->current_test; - $Test->current_test($num); - -Gets/sets the current test number we're on. You usually shouldn't -have to set this. - -If set forward, the details of the missing tests are filled in as 'unknown'. -if set backward, the details of the intervening tests are deleted. You -can erase history if you really want to. - -=cut - -sub current_test { - my( $self, $num ) = @_; - - lock( $self->{Curr_Test} ); - if( defined $num ) { - $self->{Curr_Test} = $num; - - # If the test counter is being pushed forward fill in the details. - my $test_results = $self->{Test_Results}; - if( $num > @$test_results ) { - my $start = @$test_results ? @$test_results : 0; - for( $start .. $num - 1 ) { - $test_results->[$_] = &share( - { - 'ok' => 1, - actual_ok => undef, - reason => 'incrementing test number', - type => 'unknown', - name => undef - } - ); - } - } - # If backward, wipe history. Its their funeral. - elsif( $num < @$test_results ) { - $#{$test_results} = $num - 1; - } - } - return $self->{Curr_Test}; -} - -=item B - - my $ok = $builder->is_passing; - -Indicates if the test suite is currently passing. - -More formally, it will be false if anything has happened which makes -it impossible for the test suite to pass. True otherwise. - -For example, if no tests have run C will be true because -even though a suite with no tests is a failure you can add a passing -test to it and start passing. - -Don't think about it too much. - -=cut - -sub is_passing { - my $self = shift; - - if( @_ ) { - $self->{Is_Passing} = shift; - } - - return $self->{Is_Passing}; -} - - -=item B - - my @tests = $Test->summary; - -A simple summary of the tests so far. True for pass, false for fail. -This is a logical pass/fail, so todos are passes. - -Of course, test #1 is $tests[0], etc... - -=cut - -sub summary { - my($self) = shift; - - return map { $_->{'ok'} } @{ $self->{Test_Results} }; -} - -=item B
- - my @tests = $Test->details; - -Like C, but with a lot more detail. - - $tests[$test_num - 1] = - { 'ok' => is the test considered a pass? - actual_ok => did it literally say 'ok'? - name => name of the test (if any) - type => type of test (if any, see below). - reason => reason for the above (if any) - }; - -'ok' is true if Test::Harness will consider the test to be a pass. - -'actual_ok' is a reflection of whether or not the test literally -printed 'ok' or 'not ok'. This is for examining the result of 'todo' -tests. - -'name' is the name of the test. - -'type' indicates if it was a special test. Normal tests have a type -of ''. Type can be one of the following: - - skip see skip() - todo see todo() - todo_skip see todo_skip() - unknown see below - -Sometimes the Test::Builder test counter is incremented without it -printing any test output, for example, when C is changed. -In these cases, Test::Builder doesn't know the result of the test, so -its type is 'unknown'. These details for these tests are filled in. -They are considered ok, but the name and actual_ok is left C. - -For example "not ok 23 - hole count # TODO insufficient donuts" would -result in this structure: - - $tests[22] = # 23 - 1, since arrays start from 0. - { ok => 1, # logically, the test passed since its todo - actual_ok => 0, # in absolute terms, it failed - name => 'hole count', - type => 'todo', - reason => 'insufficient donuts' - }; - -=cut - -sub details { - my $self = shift; - return @{ $self->{Test_Results} }; -} - -=item B - - my $todo_reason = $Test->todo; - my $todo_reason = $Test->todo($pack); - -If the current tests are considered "TODO" it will return the reason, -if any. This reason can come from a C<$TODO> variable or the last call -to C. - -Since a TODO test does not need a reason, this function can return an -empty string even when inside a TODO block. Use C<< $Test->in_todo >> -to determine if you are currently inside a TODO block. - -C is about finding the right package to look for C<$TODO> in. It's -pretty good at guessing the right package to look at. It first looks for -the caller based on C<$Level + 1>, since C is usually called inside -a test function. As a last resort it will use C. - -Sometimes there is some confusion about where todo() should be looking -for the C<$TODO> variable. If you want to be sure, tell it explicitly -what $pack to use. - -=cut - -sub todo { - my( $self, $pack ) = @_; - - return $self->{Todo} if defined $self->{Todo}; - - local $Level = $Level + 1; - my $todo = $self->find_TODO($pack); - return $todo if defined $todo; - - return ''; -} - -=item B - - my $todo_reason = $Test->find_TODO(); - my $todo_reason = $Test->find_TODO($pack); - -Like C but only returns the value of C<$TODO> ignoring -C. - -Can also be used to set C<$TODO> to a new value while returning the -old value: - - my $old_reason = $Test->find_TODO($pack, 1, $new_reason); - -=cut - -sub find_TODO { - my( $self, $pack, $set, $new_value ) = @_; - - $pack = $pack || $self->caller(1) || $self->exported_to; - return unless $pack; - - no strict 'refs'; ## no critic - my $old_value = ${ $pack . '::TODO' }; - $set and ${ $pack . '::TODO' } = $new_value; - return $old_value; -} - -=item B - - my $in_todo = $Test->in_todo; - -Returns true if the test is currently inside a TODO block. - -=cut - -sub in_todo { - my $self = shift; - - local $Level = $Level + 1; - return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0; -} - -=item B - - $Test->todo_start(); - $Test->todo_start($message); - -This method allows you declare all subsequent tests as TODO tests, up until -the C method has been called. - -The C and C<$TODO> syntax is generally pretty good about figuring out -whether or not we're in a TODO test. However, often we find that this is not -possible to determine (such as when we want to use C<$TODO> but -the tests are being executed in other packages which can't be inferred -beforehand). - -Note that you can use this to nest "todo" tests - - $Test->todo_start('working on this'); - # lots of code - $Test->todo_start('working on that'); - # more code - $Test->todo_end; - $Test->todo_end; - -This is generally not recommended, but large testing systems often have weird -internal needs. - -We've tried to make this also work with the TODO: syntax, but it's not -guaranteed and its use is also discouraged: - - TODO: { - local $TODO = 'We have work to do!'; - $Test->todo_start('working on this'); - # lots of code - $Test->todo_start('working on that'); - # more code - $Test->todo_end; - $Test->todo_end; - } - -Pick one style or another of "TODO" to be on the safe side. - -=cut - -sub todo_start { - my $self = shift; - my $message = @_ ? shift : ''; - - $self->{Start_Todo}++; - if( $self->in_todo ) { - push @{ $self->{Todo_Stack} } => $self->todo; - } - $self->{Todo} = $message; - - return; -} - -=item C - - $Test->todo_end; - -Stops running tests as "TODO" tests. This method is fatal if called without a -preceding C method call. - -=cut - -sub todo_end { - my $self = shift; - - if( !$self->{Start_Todo} ) { - $self->croak('todo_end() called without todo_start()'); - } - - $self->{Start_Todo}--; - - if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) { - $self->{Todo} = pop @{ $self->{Todo_Stack} }; - } - else { - delete $self->{Todo}; - } - - return; -} - -=item B - - my $package = $Test->caller; - my($pack, $file, $line) = $Test->caller; - my($pack, $file, $line) = $Test->caller($height); - -Like the normal C, except it reports according to your C. - -C<$height> will be added to the C. - -If C winds up off the top of the stack it report the highest context. - -=cut - -sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) - my( $self, $height ) = @_; - $height ||= 0; - - my $level = $self->level + $height + 1; - my @caller; - do { - @caller = CORE::caller( $level ); - $level--; - } until @caller; - return wantarray ? @caller : $caller[0]; -} - -=back - -=cut - -=begin _private - -=over 4 - -=item B<_sanity_check> - - $self->_sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - my $self = shift; - - $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' ); - $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} }, - 'Somehow you got a different number of results than tests ran!' ); - - return; -} - -=item B<_whoa> - - $self->_whoa($check, $description); - -A sanity check, similar to C. If the C<$check> is true, something -has gone horribly wrong. It will die with the given C<$description> and -a note to contact the author. - -=cut - -sub _whoa { - my( $self, $check, $desc ) = @_; - if($check) { - local $Level = $Level + 1; - $self->croak(<<"WHOA"); -WHOA! $desc -This should never happen! Please contact the author immediately! -WHOA - } - - return; -} - -=item B<_my_exit> - - _my_exit($exit_num); - -Perl seems to have some trouble with exiting inside an C block. -5.6.1 does some odd things. Instead, this function edits C<$?> -directly. It should B be called from inside an C block. -It doesn't actually exit, that's your job. - -=cut - -sub _my_exit { - $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars) - - return 1; -} - -=back - -=end _private - -=cut - -sub _ending { - my $self = shift; - return if $self->no_ending; - return if $self->{Ending}++; - - my $real_exit_code = $?; - - # Don't bother with an ending if this is a forked copy. Only the parent - # should do the ending. - if( $self->{Original_Pid} != $$ ) { - return; - } - - # Ran tests but never declared a plan or hit done_testing - if( !$self->{Have_Plan} and $self->{Curr_Test} ) { - $self->is_passing(0); - $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); - - if($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - - # But if the tests ran, handle exit code. - my $test_results = $self->{Test_Results}; - if(@$test_results) { - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; - if ($num_failed > 0) { - - my $exit_code = $num_failed <= 254 ? $num_failed : 254; - _my_exit($exit_code) && return; - } - } - _my_exit(254) && return; - } - - # Exit if plan() was never called. This is so "require Test::Simple" - # doesn't puke. - if( !$self->{Have_Plan} ) { - return; - } - - # Don't do an ending if we bailed out. - if( $self->{Bailed_Out} ) { - $self->is_passing(0); - return; - } - # Figure out if we passed or failed and print helpful messages. - my $test_results = $self->{Test_Results}; - if(@$test_results) { - # The plan? We have no plan. - if( $self->{No_Plan} ) { - $self->_output_plan($self->{Curr_Test}) unless $self->no_header; - $self->{Expected_Tests} = $self->{Curr_Test}; - } - - # Auto-extended arrays and elements which aren't explicitly - # filled in with a shared reference will puke under 5.8.0 - # ithreads. So we have to fill them in by hand. :( - my $empty_result = &share( {} ); - for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) { - $test_results->[$idx] = $empty_result - unless defined $test_results->[$idx]; - } - - my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ]; - - my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests}; - - if( $num_extra != 0 ) { - my $s = $self->{Expected_Tests} == 1 ? '' : 's'; - $self->diag(<<"FAIL"); -Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}. -FAIL - $self->is_passing(0); - } - - if($num_failed) { - my $num_tests = $self->{Curr_Test}; - my $s = $num_failed == 1 ? '' : 's'; - - my $qualifier = $num_extra == 0 ? '' : ' run'; - - $self->diag(<<"FAIL"); -Looks like you failed $num_failed test$s of $num_tests$qualifier. -FAIL - $self->is_passing(0); - } - - if($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code just after $self->{Curr_Test}. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - - my $exit_code; - if($num_failed) { - $exit_code = $num_failed <= 254 ? $num_failed : 254; - } - elsif( $num_extra != 0 ) { - $exit_code = 255; - } - else { - $exit_code = 0; - } - - _my_exit($exit_code) && return; - } - elsif( $self->{Skip_All} ) { - _my_exit(0) && return; - } - elsif($real_exit_code) { - $self->diag(<<"FAIL"); -Looks like your test exited with $real_exit_code before it could output anything. -FAIL - $self->is_passing(0); - _my_exit($real_exit_code) && return; - } - else { - $self->diag("No tests run!\n"); - $self->is_passing(0); - _my_exit(255) && return; - } - - $self->is_passing(0); - $self->_whoa( 1, "We fell off the end of _ending()" ); -} - -END { - $Test->_ending if defined $Test; -} - -=head1 EXIT CODES - -If all your tests passed, Test::Builder will exit with zero (which is -normal). If anything failed it will exit with how many failed. If -you run less (or more) tests than you planned, the missing (or extras) -will be considered failures. If no tests were ever run Test::Builder -will throw a warning and exit with 255. If the test died, even after -having successfully completed all its tests, it will still be -considered a failure and will exit with 255. - -So the exit codes are... - - 0 all tests successful - 255 test died or all passed but wrong # of tests run - any other number how many failed (including missing or extras) - -If you fail more than 254 tests, it will be reported as 254. - -=head1 THREADS - -In perl 5.8.1 and later, Test::Builder is thread-safe. The test -number is shared amongst all threads. This means if one thread sets -the test number using C they will all be effected. - -While versions earlier than 5.8.1 had threads they contain too many -bugs to support. - -Test::Builder is only thread-aware if threads.pm is loaded I -Test::Builder. - -=head1 MEMORY - -An informative hash, accessible via C<>, is stored for each -test you perform. So memory usage will scale linearly with each test -run. Although this is not a problem for most test suites, it can -become an issue if you do large (hundred thousands to million) -combinatorics tests in the same run. - -In such cases, you are advised to either split the test file into smaller -ones, or use a reverse approach, doing "normal" (code) compares and -triggering fail() should anything go unexpected. - -Future versions of Test::Builder will have a way to turn history off. - - -=head1 EXAMPLES - -CPAN can provide the best examples. Test::Simple, Test::More, -Test::Exception and Test::Differences all use Test::Builder. - -=head1 SEE ALSO - -Test::Simple, Test::More, Test::Harness - -=head1 AUTHORS - -Original code by chromatic, maintained by Michael G Schwern -Eschwern@pobox.comE - -=head1 COPYRIGHT - -Copyright 2002-2008 by chromatic Echromatic@wgz.orgE and - Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - -1; - diff --git a/t/lib/Test/Builder/IO/Scalar.pm b/t/lib/Test/Builder/IO/Scalar.pm deleted file mode 100644 index 266f713..0000000 --- a/t/lib/Test/Builder/IO/Scalar.pm +++ /dev/null @@ -1,658 +0,0 @@ -package Test::Builder::IO::Scalar; - - -=head1 NAME - -Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder - -=head1 DESCRIPTION - -This is a copy of IO::Scalar which ships with Test::Builder to -support scalar references as filehandles on Perl 5.6. Newer -versions of Perl simply use C<>'s built in support. - -Test::Builder can not have dependencies on other modules without -careful consideration, so its simply been copied into the distribution. - -=head1 COPYRIGHT and LICENSE - -This file came from the "IO-stringy" Perl5 toolkit. - -Copyright (c) 1996 by Eryq. All rights reserved. -Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - - -=cut - -# This is copied code, I don't care. -##no critic - -use Carp; -use strict; -use vars qw($VERSION @ISA); -use IO::Handle; - -use 5.005; - -### The package version, both in 1.23 style *and* usable by MakeMaker: -$VERSION = "2.110"; - -### Inheritance: -@ISA = qw(IO::Handle); - -#============================== - -=head2 Construction - -=over 4 - -=cut - -#------------------------------ - -=item new [ARGS...] - -I -Return a new, unattached scalar handle. -If any arguments are given, they're sent to open(). - -=cut - -sub new { - my $proto = shift; - my $class = ref($proto) || $proto; - my $self = bless \do { local *FH }, $class; - tie *$self, $class, $self; - $self->open(@_); ### open on anonymous by default - $self; -} -sub DESTROY { - shift->close; -} - -#------------------------------ - -=item open [SCALARREF] - -I -Open the scalar handle on a new scalar, pointed to by SCALARREF. -If no SCALARREF is given, a "private" scalar is created to hold -the file data. - -Returns the self object on success, undefined on error. - -=cut - -sub open { - my ($self, $sref) = @_; - - ### Sanity: - defined($sref) or do {my $s = ''; $sref = \$s}; - (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; - - ### Setup: - *$self->{Pos} = 0; ### seek position - *$self->{SR} = $sref; ### scalar reference - $self; -} - -#------------------------------ - -=item opened - -I -Is the scalar handle opened on something? - -=cut - -sub opened { - *{shift()}->{SR}; -} - -#------------------------------ - -=item close - -I -Disassociate the scalar handle from its underlying scalar. -Done automatically on destroy. - -=cut - -sub close { - my $self = shift; - %{*$self} = (); - 1; -} - -=back - -=cut - - - -#============================== - -=head2 Input and output - -=over 4 - -=cut - - -#------------------------------ - -=item flush - -I -No-op, provided for OO compatibility. - -=cut - -sub flush { "0 but true" } - -#------------------------------ - -=item getc - -I -Return the next character, or undef if none remain. - -=cut - -sub getc { - my $self = shift; - - ### Return undef right away if at EOF; else, move pos forward: - return undef if $self->eof; - substr(${*$self->{SR}}, *$self->{Pos}++, 1); -} - -#------------------------------ - -=item getline - -I -Return the next line, or undef on end of string. -Can safely be called in an array context. -Currently, lines are delimited by "\n". - -=cut - -sub getline { - my $self = shift; - - ### Return undef right away if at EOF: - return undef if $self->eof; - - ### Get next line: - my $sr = *$self->{SR}; - my $i = *$self->{Pos}; ### Start matching at this point. - - ### Minimal impact implementation! - ### We do the fast fast thing (no regexps) if using the - ### classic input record separator. - - ### Case 1: $/ is undef: slurp all... - if (!defined($/)) { - *$self->{Pos} = length $$sr; - return substr($$sr, $i); - } - - ### Case 2: $/ is "\n": zoom zoom zoom... - elsif ($/ eq "\012") { - - ### Seek ahead for "\n"... yes, this really is faster than regexps. - my $len = length($$sr); - for (; $i < $len; ++$i) { - last if ord (substr ($$sr, $i, 1)) == 10; - } - - ### Extract the line: - my $line; - if ($i < $len) { ### We found a "\n": - $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); - *$self->{Pos} = $i+1; ### Remember where we finished up. - } - else { ### No "\n"; slurp the remainder: - $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); - *$self->{Pos} = $len; - } - return $line; - } - - ### Case 3: $/ is ref to int. Do fixed-size records. - ### (Thanks to Dominique Quatravaux.) - elsif (ref($/)) { - my $len = length($$sr); - my $i = ${$/} + 0; - my $line = substr ($$sr, *$self->{Pos}, $i); - *$self->{Pos} += $i; - *$self->{Pos} = $len if (*$self->{Pos} > $len); - return $line; - } - - ### Case 4: $/ is either "" (paragraphs) or something weird... - ### This is Graham's general-purpose stuff, which might be - ### a tad slower than Case 2 for typical data, because - ### of the regexps. - else { - pos($$sr) = $i; - - ### If in paragraph mode, skip leading lines (and update i!): - length($/) or - (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); - - ### If we see the separator in the buffer ahead... - if (length($/) - ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! - : $$sr =~ m,\n\n,g ### (a paragraph) - ) { - *$self->{Pos} = pos $$sr; - return substr($$sr, $i, *$self->{Pos}-$i); - } - ### Else if no separator remains, just slurp the rest: - else { - *$self->{Pos} = length $$sr; - return substr($$sr, $i); - } - } -} - -#------------------------------ - -=item getlines - -I -Get all remaining lines. -It will croak() if accidentally called in a scalar context. - -=cut - -sub getlines { - my $self = shift; - wantarray or croak("can't call getlines in scalar context!"); - my ($line, @lines); - push @lines, $line while (defined($line = $self->getline)); - @lines; -} - -#------------------------------ - -=item print ARGS... - -I -Print ARGS to the underlying scalar. - -B this continues to always cause a seek to the end -of the string, but if you perform seek()s and tell()s, it is -still safer to explicitly seek-to-end before subsequent print()s. - -=cut - -sub print { - my $self = shift; - *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); - 1; -} -sub _unsafe_print { - my $self = shift; - my $append = join('', @_) . $\; - ${*$self->{SR}} .= $append; - *$self->{Pos} += length($append); - 1; -} -sub _old_print { - my $self = shift; - ${*$self->{SR}} .= join('', @_) . $\; - *$self->{Pos} = length(${*$self->{SR}}); - 1; -} - - -#------------------------------ - -=item read BUF, NBYTES, [OFFSET] - -I -Read some bytes from the scalar. -Returns the number of bytes actually read, 0 on end-of-file, undef on error. - -=cut - -sub read { - my $self = $_[0]; - my $n = $_[2]; - my $off = $_[3] || 0; - - my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); - $n = length($read); - *$self->{Pos} += $n; - ($off ? substr($_[1], $off) : $_[1]) = $read; - return $n; -} - -#------------------------------ - -=item write BUF, NBYTES, [OFFSET] - -I -Write some bytes to the scalar. - -=cut - -sub write { - my $self = $_[0]; - my $n = $_[2]; - my $off = $_[3] || 0; - - my $data = substr($_[1], $off, $n); - $n = length($data); - $self->print($data); - return $n; -} - -#------------------------------ - -=item sysread BUF, LEN, [OFFSET] - -I -Read some bytes from the scalar. -Returns the number of bytes actually read, 0 on end-of-file, undef on error. - -=cut - -sub sysread { - my $self = shift; - $self->read(@_); -} - -#------------------------------ - -=item syswrite BUF, NBYTES, [OFFSET] - -I -Write some bytes to the scalar. - -=cut - -sub syswrite { - my $self = shift; - $self->write(@_); -} - -=back - -=cut - - -#============================== - -=head2 Seeking/telling and other attributes - -=over 4 - -=cut - - -#------------------------------ - -=item autoflush - -I -No-op, provided for OO compatibility. - -=cut - -sub autoflush {} - -#------------------------------ - -=item binmode - -I -No-op, provided for OO compatibility. - -=cut - -sub binmode {} - -#------------------------------ - -=item clearerr - -I Clear the error and EOF flags. A no-op. - -=cut - -sub clearerr { 1 } - -#------------------------------ - -=item eof - -I Are we at end of file? - -=cut - -sub eof { - my $self = shift; - (*$self->{Pos} >= length(${*$self->{SR}})); -} - -#------------------------------ - -=item seek OFFSET, WHENCE - -I Seek to a given position in the stream. - -=cut - -sub seek { - my ($self, $pos, $whence) = @_; - my $eofpos = length(${*$self->{SR}}); - - ### Seek: - if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET - elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR - elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END - else { croak "bad seek whence ($whence)" } - - ### Fixup: - if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } - if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } - return 1; -} - -#------------------------------ - -=item sysseek OFFSET, WHENCE - -I Identical to C, I - -=cut - -sub sysseek { - my $self = shift; - $self->seek (@_); -} - -#------------------------------ - -=item tell - -I -Return the current position in the stream, as a numeric offset. - -=cut - -sub tell { *{shift()}->{Pos} } - -#------------------------------ - -=item use_RS [YESNO] - -I -B -Obey the current setting of $/, like IO::Handle does? -Default is false in 1.x, but cold-welded true in 2.x and later. - -=cut - -sub use_RS { - my ($self, $yesno) = @_; - carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; - } - -#------------------------------ - -=item setpos POS - -I -Set the current position, using the opaque value returned by C. - -=cut - -sub setpos { shift->seek($_[0],0) } - -#------------------------------ - -=item getpos - -I -Return the current position in the string, as an opaque object. - -=cut - -*getpos = \&tell; - - -#------------------------------ - -=item sref - -I -Return a reference to the underlying scalar. - -=cut - -sub sref { *{shift()}->{SR} } - - -#------------------------------ -# Tied handle methods... -#------------------------------ - -# Conventional tiehandle interface: -sub TIEHANDLE { - ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) - ? $_[1] - : shift->new(@_)); -} -sub GETC { shift->getc(@_) } -sub PRINT { shift->print(@_) } -sub PRINTF { shift->print(sprintf(shift, @_)) } -sub READ { shift->read(@_) } -sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } -sub WRITE { shift->write(@_); } -sub CLOSE { shift->close(@_); } -sub SEEK { shift->seek(@_); } -sub TELL { shift->tell(@_); } -sub EOF { shift->eof(@_); } - -#------------------------------------------------------------ - -1; - -__END__ - - - -=back - -=cut - - -=head1 WARNINGS - -Perl's TIEHANDLE spec was incomplete prior to 5.005_57; -it was missing support for C, C, and C. -Attempting to use these functions with an IO::Scalar will not work -prior to 5.005_57. IO::Scalar will not have the relevant methods -invoked; and even worse, this kind of bug can lie dormant for a while. -If you turn warnings on (via C<$^W> or C), -and you see something like this... - - attempt to seek on unopened filehandle - -...then you are probably trying to use one of these functions -on an IO::Scalar with an old Perl. The remedy is to simply -use the OO version; e.g.: - - $SH->seek(0,0); ### GOOD: will work on any 5.005 - seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond - - -=head1 VERSION - -$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ - - -=head1 AUTHORS - -=head2 Primary Maintainer - -David F. Skoll (F). - -=head2 Principal author - -Eryq (F). -President, ZeeGee Software Inc (F). - - -=head2 Other contributors - -The full set of contributors always includes the folks mentioned -in L. But just the same, special -thanks to the following individuals for their invaluable contributions -(if I've forgotten or misspelled your name, please email me!): - -I -for contributing C. - -I -for suggesting C. - -I -for finding and fixing the bug in C. - -I -for his offset-using read() and write() implementations. - -I -for his patches to massively improve the performance of C -and add C and C. - -I -for stringification and inheritance improvements, -and sundry good ideas. - -I -for the IO::Handle inheritance and automatic tie-ing. - - -=head1 SEE ALSO - -L, which is quite similar but which was designed -more-recently and with an IO::Handle-like interface in mind, -so you could mix OO- and native-filehandle usage without using tied(). - -I as of version 2.x, these classes all work like -their IO::Handle counterparts, so we have comparable -functionality to IO::String. - -=cut - diff --git a/t/lib/Test/Builder/Module.pm b/t/lib/Test/Builder/Module.pm deleted file mode 100644 index 24a9d55..0000000 --- a/t/lib/Test/Builder/Module.pm +++ /dev/null @@ -1,173 +0,0 @@ -package Test::Builder::Module; - -use strict; - -use Test::Builder 0.99; - -require Exporter; -our @ISA = qw(Exporter); - -our $VERSION = '0.99'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - - -=head1 NAME - -Test::Builder::Module - Base class for test modules - -=head1 SYNOPSIS - - # Emulates Test::Simple - package Your::Module; - - my $CLASS = __PACKAGE__; - - use base 'Test::Builder::Module'; - @EXPORT = qw(ok); - - sub ok ($;$) { - my $tb = $CLASS->builder; - return $tb->ok(@_); - } - - 1; - - -=head1 DESCRIPTION - -This is a superclass for Test::Builder-based modules. It provides a -handful of common functionality and a method of getting at the underlying -Test::Builder object. - - -=head2 Importing - -Test::Builder::Module is a subclass of Exporter which means your -module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... -all act normally. - -A few methods are provided to do the C 23> part -for you. - -=head3 import - -Test::Builder::Module provides an import() method which acts in the -same basic way as Test::More's, setting the plan and controlling -exporting of functions and variables. This allows your module to set -the plan independent of Test::More. - -All arguments passed to import() are passed onto -C<< Your::Module->builder->plan() >> with the exception of -C<< import =>[qw(things to import)] >>. - - use Your::Module import => [qw(this that)], tests => 23; - -says to import the functions this() and that() as well as set the plan -to be 23 tests. - -import() also sets the exported_to() attribute of your builder to be -the caller of the import() function. - -Additional behaviors can be added to your import() method by overriding -import_extra(). - -=cut - -sub import { - my($class) = shift; - - # Don't run all this when loading ourself. - return 1 if $class eq 'Test::Builder::Module'; - - my $test = $class->builder; - - my $caller = caller; - - $test->exported_to($caller); - - $class->import_extra( \@_ ); - my(@imports) = $class->_strip_imports( \@_ ); - - $test->plan(@_); - - $class->export_to_level( 1, $class, @imports ); -} - -sub _strip_imports { - my $class = shift; - my $list = shift; - - my @imports = (); - my @other = (); - my $idx = 0; - while( $idx <= $#{$list} ) { - my $item = $list->[$idx]; - - if( defined $item and $item eq 'import' ) { - push @imports, @{ $list->[ $idx + 1 ] }; - $idx++; - } - else { - push @other, $item; - } - - $idx++; - } - - @$list = @other; - - return @imports; -} - -=head3 import_extra - - Your::Module->import_extra(\@import_args); - -import_extra() is called by import(). It provides an opportunity for you -to add behaviors to your module based on its import list. - -Any extra arguments which shouldn't be passed on to plan() should be -stripped off by this method. - -See Test::More for an example of its use. - -B This mechanism is I as it -feels like a bit of an ugly hack in its current form. - -=cut - -sub import_extra { } - -=head2 Builder - -Test::Builder::Module provides some methods of getting at the underlying -Test::Builder object. - -=head3 builder - - my $builder = Your::Class->builder; - -This method returns the Test::Builder object associated with Your::Class. -It is not a constructor so you can call it as often as you like. - -This is the preferred way to get the Test::Builder object. You should -I get it via C<< Test::Builder->new >> as was previously -recommended. - -The object returned by builder() may change at runtime so you should -call builder() inside each function rather than store it in a global. - - sub ok { - my $builder = Your::Class->builder; - - return $builder->ok(@_); - } - - -=cut - -sub builder { - return Test::Builder->new; -} - -1; diff --git a/t/lib/Test/More.pm b/t/lib/Test/More.pm deleted file mode 100644 index ad3cf50..0000000 --- a/t/lib/Test/More.pm +++ /dev/null @@ -1,1913 +0,0 @@ -package Test::More; - -use 5.006; -use strict; -use warnings; - -#---- perlcritic exemptions. ----# - -# We use a lot of subroutine prototypes -## no critic (Subroutines::ProhibitSubroutinePrototypes) - -# Can't use Carp because it might cause use_ok() to accidentally succeed -# even though the module being used forgot to use Carp. Yes, this -# actually happened. -sub _carp { - my( $file, $line ) = ( caller(1) )[ 1, 2 ]; - return warn @_, " at $file line $line\n"; -} - -our $VERSION = '0.99'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - -use Test::Builder::Module 0.99; -our @ISA = qw(Test::Builder::Module); -our @EXPORT = qw(ok use_ok require_ok - is isnt like unlike is_deeply - cmp_ok - skip todo todo_skip - pass fail - eq_array eq_hash eq_set - $TODO - plan - done_testing - can_ok isa_ok new_ok - diag note explain - subtest - BAIL_OUT -); - -=head1 NAME - -Test::More - yet another framework for writing test scripts - -=head1 SYNOPSIS - - use Test::More tests => 23; - # or - use Test::More skip_all => $reason; - # or - use Test::More; # see done_testing() - - require_ok( 'Some::Module' ); - - # Various ways to say "ok" - ok($got eq $expected, $test_name); - - is ($got, $expected, $test_name); - isnt($got, $expected, $test_name); - - # Rather than print STDERR "# here's what went wrong\n" - diag("here's what went wrong"); - - like ($got, qr/expected/, $test_name); - unlike($got, qr/expected/, $test_name); - - cmp_ok($got, '==', $expected, $test_name); - - is_deeply($got_complex_structure, $expected_complex_structure, $test_name); - - SKIP: { - skip $why, $how_many unless $have_some_feature; - - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; - - TODO: { - local $TODO = $why; - - ok( foo(), $test_name ); - is( foo(42), 23, $test_name ); - }; - - can_ok($module, @methods); - isa_ok($object, $class); - - pass($test_name); - fail($test_name); - - BAIL_OUT($why); - - # UNIMPLEMENTED!!! - my @status = Test::More::status; - - -=head1 DESCRIPTION - -B If you're just getting started writing tests, have a look at -L first. This is a drop in replacement for Test::Simple -which you can switch to once you get the hang of basic testing. - -The purpose of this module is to provide a wide range of testing -utilities. Various ways to say "ok" with better diagnostics, -facilities to skip tests, test future features and compare complicated -data structures. While you can do almost anything with a simple -C function, it doesn't provide good diagnostic output. - - -=head2 I love it when a plan comes together - -Before anything else, you need a testing plan. This basically declares -how many tests your script is going to run to protect against premature -failure. - -The preferred way to do this is to declare a plan when you C. - - use Test::More tests => 23; - -There are cases when you will not know beforehand how many tests your -script is going to run. In this case, you can declare your tests at -the end. - - use Test::More; - - ... run your tests ... - - done_testing( $number_of_tests_run ); - -Sometimes you really don't know how many tests were run, or it's too -difficult to calculate. In which case you can leave off -$number_of_tests_run. - -In some cases, you'll want to completely skip an entire testing script. - - use Test::More skip_all => $skip_reason; - -Your script will declare a skip with the reason why you skipped and -exit immediately with a zero (success). See L for -details. - -If you want to control what functions Test::More will export, you -have to use the 'import' option. For example, to import everything -but 'fail', you'd do: - - use Test::More tests => 23, import => ['!fail']; - -Alternatively, you can use the plan() function. Useful for when you -have to calculate the number of tests. - - use Test::More; - plan tests => keys %Stuff * 3; - -or for deciding between running the tests at all: - - use Test::More; - if( $^O eq 'MacOS' ) { - plan skip_all => 'Test irrelevant on MacOS'; - } - else { - plan tests => 42; - } - -=cut - -sub plan { - my $tb = Test::More->builder; - - return $tb->plan(@_); -} - -# This implements "use Test::More 'no_diag'" but the behavior is -# deprecated. -sub import_extra { - my $class = shift; - my $list = shift; - - my @other = (); - my $idx = 0; - while( $idx <= $#{$list} ) { - my $item = $list->[$idx]; - - if( defined $item and $item eq 'no_diag' ) { - $class->builder->no_diag(1); - } - else { - push @other, $item; - } - - $idx++; - } - - @$list = @other; - - return; -} - -=over 4 - -=item B - - done_testing(); - done_testing($number_of_tests); - -If you don't know how many tests you're going to run, you can issue -the plan when you're done running tests. - -$number_of_tests is the same as plan(), it's the number of tests you -expected to run. You can omit this, in which case the number of tests -you ran doesn't matter, just the fact that your tests ran to -conclusion. - -This is safer than and replaces the "no_plan" plan. - -=back - -=cut - -sub done_testing { - my $tb = Test::More->builder; - $tb->done_testing(@_); -} - -=head2 Test names - -By convention, each test is assigned a number in order. This is -largely done automatically for you. However, it's often very useful to -assign a name to each test. Which would you rather see: - - ok 4 - not ok 5 - ok 6 - -or - - ok 4 - basic multi-variable - not ok 5 - simple exponential - ok 6 - force == mass * acceleration - -The later gives you some idea of what failed. It also makes it easier -to find the test in your script, simply search for "simple -exponential". - -All test functions take a name argument. It's optional, but highly -suggested that you use it. - -=head2 I'm ok, you're not ok. - -The basic purpose of this module is to print out either "ok #" or "not -ok #" depending on if a given test succeeded or failed. Everything -else is just gravy. - -All of the following print "ok" or "not ok" depending on if the test -succeeded or failed. They all also return true or false, -respectively. - -=over 4 - -=item B - - ok($got eq $expected, $test_name); - -This simply evaluates any expression (C<$got eq $expected> is just a -simple example) and uses that to determine if the test succeeded or -failed. A true expression passes, a false one fails. Very simple. - -For example: - - ok( $exp{9} == 81, 'simple exponential' ); - ok( Film->can('db_Main'), 'set_db()' ); - ok( $p->tests == 4, 'saw tests' ); - ok( !grep(!defined $_, @items), 'all items defined' ); - -(Mnemonic: "This is ok.") - -$test_name is a very short description of the test that will be printed -out. It makes it very easy to find a test in your script when it fails -and gives others an idea of your intentions. $test_name is optional, -but we B strongly encourage its use. - -Should an ok() fail, it will produce some diagnostics: - - not ok 18 - sufficient mucus - # Failed test 'sufficient mucus' - # in foo.t at line 42. - -This is the same as Test::Simple's ok() routine. - -=cut - -sub ok ($;$) { - my( $test, $name ) = @_; - my $tb = Test::More->builder; - - return $tb->ok( $test, $name ); -} - -=item B - -=item B - - is ( $got, $expected, $test_name ); - isnt( $got, $expected, $test_name ); - -Similar to ok(), is() and isnt() compare their two arguments -with C and C respectively and use the result of that to -determine if the test succeeded or failed. So these: - - # Is the ultimate answer 42? - is( ultimate_answer(), 42, "Meaning of Life" ); - - # $foo isn't empty - isnt( $foo, '', "Got some foo" ); - -are similar to these: - - ok( ultimate_answer() eq 42, "Meaning of Life" ); - ok( $foo ne '', "Got some foo" ); - -C will only ever match C. So you can test a value -against C like this: - - is($not_defined, undef, "undefined as expected"); - -(Mnemonic: "This is that." "This isn't that.") - -So why use these? They produce better diagnostics on failure. ok() -cannot know what you are testing for (beyond the name), but is() and -isnt() know what the test was and why it failed. For example this -test: - - my $foo = 'waffle'; my $bar = 'yarblokos'; - is( $foo, $bar, 'Is foo the same as bar?' ); - -Will produce something like this: - - not ok 17 - Is foo the same as bar? - # Failed test 'Is foo the same as bar?' - # in foo.t at line 139. - # got: 'waffle' - # expected: 'yarblokos' - -So you can figure out what went wrong without rerunning the test. - -You are encouraged to use is() and isnt() over ok() where possible, -however do not be tempted to use them to find out if something is -true or false! - - # XXX BAD! - is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); - -This does not check if C is true, it checks if -it returns 1. Very different. Similar caveats exist for false and 0. -In these cases, use ok(). - - ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); - -A simple call to isnt() usually does not provide a strong test but there -are cases when you cannot say much more about a value than that it is -different from some other value: - - new_ok $obj, "Foo"; - - my $clone = $obj->clone; - isa_ok $obj, "Foo", "Foo->clone"; - - isnt $obj, $clone, "clone() produces a different object"; - -For those grammatical pedants out there, there's an C -function which is an alias of isnt(). - -=cut - -sub is ($$;$) { - my $tb = Test::More->builder; - - return $tb->is_eq(@_); -} - -sub isnt ($$;$) { - my $tb = Test::More->builder; - - return $tb->isnt_eq(@_); -} - -*isn't = \&isnt; - -=item B - - like( $got, qr/expected/, $test_name ); - -Similar to ok(), like() matches $got against the regex C. - -So this: - - like($got, qr/expected/, 'this is like that'); - -is similar to: - - ok( $got =~ m/expected/, 'this is like that'); - -(Mnemonic "This is like that".) - -The second argument is a regular expression. It may be given as a -regex reference (i.e. C) or (for better compatibility with older -perls) as a string that looks like a regex (alternative delimiters are -currently not supported): - - like( $got, '/expected/', 'this is like that' ); - -Regex options may be placed on the end (C<'/expected/i'>). - -Its advantages over ok() are similar to that of is() and isnt(). Better -diagnostics on failure. - -=cut - -sub like ($$;$) { - my $tb = Test::More->builder; - - return $tb->like(@_); -} - -=item B - - unlike( $got, qr/expected/, $test_name ); - -Works exactly as like(), only it checks if $got B match the -given pattern. - -=cut - -sub unlike ($$;$) { - my $tb = Test::More->builder; - - return $tb->unlike(@_); -} - -=item B - - cmp_ok( $got, $op, $expected, $test_name ); - -Halfway between C and C lies C. This allows you -to compare two arguments using any binary perl operator. The test -passes if the comparison is true and fails otherwise. - - # ok( $got eq $expected ); - cmp_ok( $got, 'eq', $expected, 'this eq that' ); - - # ok( $got == $expected ); - cmp_ok( $got, '==', $expected, 'this == that' ); - - # ok( $got && $expected ); - cmp_ok( $got, '&&', $expected, 'this && that' ); - ...etc... - -Its advantage over ok() is when the test fails you'll know what $got -and $expected were: - - not ok 1 - # Failed test in foo.t at line 12. - # '23' - # && - # undef - -It's also useful in those cases where you are comparing numbers and -is()'s use of C will interfere: - - cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); - -It's especially useful when comparing greater-than or smaller-than -relation between values: - - cmp_ok( $some_value, '<=', $upper_limit ); - - -=cut - -sub cmp_ok($$$;$) { - my $tb = Test::More->builder; - - return $tb->cmp_ok(@_); -} - -=item B - - can_ok($module, @methods); - can_ok($object, @methods); - -Checks to make sure the $module or $object can do these @methods -(works with functions, too). - - can_ok('Foo', qw(this that whatever)); - -is almost exactly like saying: - - ok( Foo->can('this') && - Foo->can('that') && - Foo->can('whatever') - ); - -only without all the typing and with a better interface. Handy for -quickly testing an interface. - -No matter how many @methods you check, a single can_ok() call counts -as one test. If you desire otherwise, use: - - foreach my $meth (@methods) { - can_ok('Foo', $meth); - } - -=cut - -sub can_ok ($@) { - my( $proto, @methods ) = @_; - my $class = ref $proto || $proto; - my $tb = Test::More->builder; - - unless($class) { - my $ok = $tb->ok( 0, "->can(...)" ); - $tb->diag(' can_ok() called with empty class or reference'); - return $ok; - } - - unless(@methods) { - my $ok = $tb->ok( 0, "$class->can(...)" ); - $tb->diag(' can_ok() called with no methods'); - return $ok; - } - - my @nok = (); - foreach my $method (@methods) { - $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; - } - - my $name = (@methods == 1) ? "$class->can('$methods[0]')" : - "$class->can(...)" ; - - my $ok = $tb->ok( !@nok, $name ); - - $tb->diag( map " $class->can('$_') failed\n", @nok ); - - return $ok; -} - -=item B - - isa_ok($object, $class, $object_name); - isa_ok($subclass, $class, $object_name); - isa_ok($ref, $type, $ref_name); - -Checks to see if the given C<< $object->isa($class) >>. Also checks to make -sure the object was defined in the first place. Handy for this sort -of thing: - - my $obj = Some::Module->new; - isa_ok( $obj, 'Some::Module' ); - -where you'd otherwise have to write - - my $obj = Some::Module->new; - ok( defined $obj && $obj->isa('Some::Module') ); - -to safeguard against your test script blowing up. - -You can also test a class, to make sure that it has the right ancestor: - - isa_ok( 'Vole', 'Rodent' ); - -It works on references, too: - - isa_ok( $array_ref, 'ARRAY' ); - -The diagnostics of this test normally just refer to 'the object'. If -you'd like them to be more specific, you can supply an $object_name -(for example 'Test customer'). - -=cut - -sub isa_ok ($$;$) { - my( $thing, $class, $thing_name ) = @_; - my $tb = Test::More->builder; - - my $whatami; - if( !defined $thing ) { - $whatami = 'undef'; - } - elsif( ref $thing ) { - $whatami = 'reference'; - - local($@,$!); - require Scalar::Util; - if( Scalar::Util::blessed($thing) ) { - $whatami = 'object'; - } - } - else { - $whatami = 'class'; - } - - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); - - if($error) { - die <isa on your $whatami and got some weird error. -Here's the error. -$error -WHOA - } - - # Special case for isa_ok( [], "ARRAY" ) and like - if( $whatami eq 'reference' ) { - $rslt = UNIVERSAL::isa($thing, $class); - } - - my($diag, $name); - if( defined $thing_name ) { - $name = "'$thing_name' isa '$class'"; - $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; - } - elsif( $whatami eq 'object' ) { - my $my_class = ref $thing; - $thing_name = qq[An object of class '$my_class']; - $name = "$thing_name isa '$class'"; - $diag = "The object of class '$my_class' isn't a '$class'"; - } - elsif( $whatami eq 'reference' ) { - my $type = ref $thing; - $thing_name = qq[A reference of type '$type']; - $name = "$thing_name isa '$class'"; - $diag = "The reference of type '$type' isn't a '$class'"; - } - elsif( $whatami eq 'undef' ) { - $thing_name = 'undef'; - $name = "$thing_name isa '$class'"; - $diag = "$thing_name isn't defined"; - } - elsif( $whatami eq 'class' ) { - $thing_name = qq[The class (or class-like) '$thing']; - $name = "$thing_name isa '$class'"; - $diag = "$thing_name isn't a '$class'"; - } - else { - die; - } - - my $ok; - if($rslt) { - $ok = $tb->ok( 1, $name ); - } - else { - $ok = $tb->ok( 0, $name ); - $tb->diag(" $diag\n"); - } - - return $ok; -} - -=item B - - my $obj = new_ok( $class ); - my $obj = new_ok( $class => \@args ); - my $obj = new_ok( $class => \@args, $object_name ); - -A convenience function which combines creating an object and calling -isa_ok() on that object. - -It is basically equivalent to: - - my $obj = $class->new(@args); - isa_ok $obj, $class, $object_name; - -If @args is not given, an empty list will be used. - -This function only works on new() and it assumes new() will return -just a single object which isa C<$class>. - -=cut - -sub new_ok { - my $tb = Test::More->builder; - $tb->croak("new_ok() must be given at least a class") unless @_; - - my( $class, $args, $object_name ) = @_; - - $args ||= []; - - my $obj; - my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); - if($success) { - local $Test::Builder::Level = $Test::Builder::Level + 1; - isa_ok $obj, $class, $object_name; - } - else { - $class = 'undef' if !defined $class; - $tb->ok( 0, "$class->new() died" ); - $tb->diag(" Error was: $error"); - } - - return $obj; -} - -=item B - - subtest $name => \&code; - -subtest() runs the &code as its own little test with its own plan and -its own result. The main test counts this as a single test using the -result of the whole subtest to determine if its ok or not ok. - -For example... - - use Test::More tests => 3; - - pass("First test"); - - subtest 'An example subtest' => sub { - plan tests => 2; - - pass("This is a subtest"); - pass("So is this"); - }; - - pass("Third test"); - -This would produce. - - 1..3 - ok 1 - First test - # Subtest: An example subtest - 1..2 - ok 1 - This is a subtest - ok 2 - So is this - ok 2 - An example subtest - ok 3 - Third test - -A subtest may call "skip_all". No tests will be run, but the subtest is -considered a skip. - - subtest 'skippy' => sub { - plan skip_all => 'cuz I said so'; - pass('this test will never be run'); - }; - -Returns true if the subtest passed, false otherwise. - -Due to how subtests work, you may omit a plan if you desire. This adds an -implicit C to the end of your subtest. The following two -subtests are equivalent: - - subtest 'subtest with implicit done_testing()', sub { - ok 1, 'subtests with an implicit done testing should work'; - ok 1, '... and support more than one test'; - ok 1, '... no matter how many tests are run'; - }; - - subtest 'subtest with explicit done_testing()', sub { - ok 1, 'subtests with an explicit done testing should work'; - ok 1, '... and support more than one test'; - ok 1, '... no matter how many tests are run'; - done_testing(); - }; - -=cut - -sub subtest { - my ($name, $subtests) = @_; - - my $tb = Test::More->builder; - return $tb->subtest(@_); -} - -=item B - -=item B - - pass($test_name); - fail($test_name); - -Sometimes you just want to say that the tests have passed. Usually -the case is you've got some complicated condition that is difficult to -wedge into an ok(). In this case, you can simply use pass() (to -declare the test ok) or fail (for not ok). They are synonyms for -ok(1) and ok(0). - -Use these very, very, very sparingly. - -=cut - -sub pass (;$) { - my $tb = Test::More->builder; - - return $tb->ok( 1, @_ ); -} - -sub fail (;$) { - my $tb = Test::More->builder; - - return $tb->ok( 0, @_ ); -} - -=back - - -=head2 Module tests - -Sometimes you want to test if a module, or a list of modules, can -successfully load. For example, you'll often want a first test which -simply loads all the modules in the distribution to make sure they -work before going on to do more complicated testing. - -For such purposes we have C and C. - -=over 4 - -=item B - - require_ok($module); - require_ok($file); - -Tries to C the given $module or $file. If it loads -successfully, the test will pass. Otherwise it fails and displays the -load error. - -C will guess whether the input is a module name or a -filename. - -No exception will be thrown if the load fails. - - # require Some::Module - require_ok "Some::Module"; - - # require "Some/File.pl"; - require_ok "Some/File.pl"; - - # stop testing if any of your modules will not load - for my $module (@module) { - require_ok $module or BAIL_OUT "Can't load $module"; - } - -=cut - -sub require_ok ($) { - my($module) = shift; - my $tb = Test::More->builder; - - my $pack = caller; - - # Try to determine if we've been given a module name or file. - # Module names must be barewords, files not. - $module = qq['$module'] unless _is_module_name($module); - - my $code = <ok( $eval_result, "require $module;" ); - - unless($ok) { - chomp $eval_error; - $tb->diag(< - - BEGIN { use_ok($module); } - BEGIN { use_ok($module, @imports); } - -Like C, but it will C the $module in question and -only loads modules, not files. - -If you just want to test a module can be loaded, use C. - -If you just want to load a module in a test, we recommend simply using -C directly. It will cause the test to stop. - -It's recommended that you run use_ok() inside a BEGIN block so its -functions are exported at compile-time and prototypes are properly -honored. - -If @imports are given, they are passed through to the use. So this: - - BEGIN { use_ok('Some::Module', qw(foo bar)) } - -is like doing this: - - use Some::Module qw(foo bar); - -Version numbers can be checked like so: - - # Just like "use Some::Module 1.02" - BEGIN { use_ok('Some::Module', 1.02) } - -Don't try to do this: - - BEGIN { - use_ok('Some::Module'); - - ...some code that depends on the use... - ...happening at compile time... - } - -because the notion of "compile-time" is relative. Instead, you want: - - BEGIN { use_ok('Some::Module') } - BEGIN { ...some code that depends on the use... } - -If you want the equivalent of C, use a module but not -import anything, use C. - - BEGIN { require_ok "Foo" } - -=cut - -sub use_ok ($;@) { - my( $module, @imports ) = @_; - @imports = () unless @imports; - my $tb = Test::More->builder; - - my( $pack, $filename, $line ) = caller; - $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line - - my $code; - if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { - # probably a version check. Perl needs to see the bare number - # for it to work with non-Exporter based modules. - $code = <ok( $eval_result, "use $module;" ); - - unless($ok) { - chomp $eval_error; - $@ =~ s{^BEGIN failed--compilation aborted at .*$} - {BEGIN failed--compilation aborted at $filename line $line.}m; - $tb->diag(< I'm not quite sure what will happen with filehandles. - -=over 4 - -=item B - - is_deeply( $got, $expected, $test_name ); - -Similar to is(), except that if $got and $expected are references, it -does a deep comparison walking each data structure to see if they are -equivalent. If the two structures are different, it will display the -place where they start differing. - -is_deeply() compares the dereferenced values of references, the -references themselves (except for their type) are ignored. This means -aspects such as blessing and ties are not considered "different". - -is_deeply() currently has very limited handling of function reference -and globs. It merely checks if they have the same referent. This may -improve in the future. - -L and L provide more in-depth functionality -along these lines. - -=cut - -our( @Data_Stack, %Refs_Seen ); -my $DNE = bless [], 'Does::Not::Exist'; - -sub _dne { - return ref $_[0] eq ref $DNE; -} - -## no critic (Subroutines::RequireArgUnpacking) -sub is_deeply { - my $tb = Test::More->builder; - - unless( @_ == 2 or @_ == 3 ) { - my $msg = <<'WARNING'; -is_deeply() takes two or three args, you gave %d. -This usually means you passed an array or hash instead -of a reference to it -WARNING - chop $msg; # clip off newline so carp() will put in line/file - - _carp sprintf $msg, scalar @_; - - return $tb->ok(0); - } - - my( $got, $expected, $name ) = @_; - - $tb->_unoverload_str( \$expected, \$got ); - - my $ok; - if( !ref $got and !ref $expected ) { # neither is a reference - $ok = $tb->is_eq( $got, $expected, $name ); - } - elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't - $ok = $tb->ok( 0, $name ); - $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); - } - else { # both references - local @Data_Stack = (); - if( _deep_check( $got, $expected ) ) { - $ok = $tb->ok( 1, $name ); - } - else { - $ok = $tb->ok( 0, $name ); - $tb->diag( _format_stack(@Data_Stack) ); - } - } - - return $ok; -} - -sub _format_stack { - my(@Stack) = @_; - - my $var = '$FOO'; - my $did_arrow = 0; - foreach my $entry (@Stack) { - my $type = $entry->{type} || ''; - my $idx = $entry->{'idx'}; - if( $type eq 'HASH' ) { - $var .= "->" unless $did_arrow++; - $var .= "{$idx}"; - } - elsif( $type eq 'ARRAY' ) { - $var .= "->" unless $did_arrow++; - $var .= "[$idx]"; - } - elsif( $type eq 'REF' ) { - $var = "\${$var}"; - } - } - - my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; - my @vars = (); - ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; - ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; - - my $out = "Structures begin differing at:\n"; - foreach my $idx ( 0 .. $#vals ) { - my $val = $vals[$idx]; - $vals[$idx] - = !defined $val ? 'undef' - : _dne($val) ? "Does not exist" - : ref $val ? "$val" - : "'$val'"; - } - - $out .= "$vars[0] = $vals[0]\n"; - $out .= "$vars[1] = $vals[1]\n"; - - $out =~ s/^/ /msg; - return $out; -} - -sub _type { - my $thing = shift; - - return '' if !ref $thing; - - for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) { - return $type if UNIVERSAL::isa( $thing, $type ); - } - - return ''; -} - -=back - - -=head2 Diagnostics - -If you pick the right test function, you'll usually get a good idea of -what went wrong when it failed. But sometimes it doesn't work out -that way. So here we have ways for you to write your own diagnostic -messages which are safer than just C. - -=over 4 - -=item B - - diag(@diagnostic_message); - -Prints a diagnostic message which is guaranteed not to interfere with -test output. Like C @diagnostic_message is simply concatenated -together. - -Returns false, so as to preserve failure. - -Handy for this sort of thing: - - ok( grep(/foo/, @users), "There's a foo user" ) or - diag("Since there's no foo, check that /etc/bar is set up right"); - -which would produce: - - not ok 42 - There's a foo user - # Failed test 'There's a foo user' - # in foo.t at line 52. - # Since there's no foo, check that /etc/bar is set up right. - -You might remember C with the mnemonic C. - -B The exact formatting of the diagnostic output is still -changing, but it is guaranteed that whatever you throw at it won't -interfere with the test. - -=item B - - note(@diagnostic_message); - -Like diag(), except the message will not be seen when the test is run -in a harness. It will only be visible in the verbose TAP stream. - -Handy for putting in notes which might be useful for debugging, but -don't indicate a problem. - - note("Tempfile is $tempfile"); - -=cut - -sub diag { - return Test::More->builder->diag(@_); -} - -sub note { - return Test::More->builder->note(@_); -} - -=item B - - my @dump = explain @diagnostic_message; - -Will dump the contents of any references in a human readable format. -Usually you want to pass this into C or C. - -Handy for things like... - - is_deeply($have, $want) || diag explain $have; - -or - - note explain \%args; - Some::Class->method(%args); - -=cut - -sub explain { - return Test::More->builder->explain(@_); -} - -=back - - -=head2 Conditional tests - -Sometimes running a test under certain conditions will cause the -test script to die. A certain function or method isn't implemented -(such as fork() on MacOS), some resource isn't available (like a -net connection) or a module isn't available. In these cases it's -necessary to skip tests, or declare that they are supposed to fail -but will work in the future (a todo test). - -For more details on the mechanics of skip and todo tests see -L. - -The way Test::More handles this is with a named block. Basically, a -block of tests which can be skipped over or made todo. It's best if I -just show you... - -=over 4 - -=item B - - SKIP: { - skip $why, $how_many if $condition; - - ...normal testing code goes here... - } - -This declares a block of tests that might be skipped, $how_many tests -there are, $why and under what $condition to skip them. An example is -the easiest way to illustrate: - - SKIP: { - eval { require HTML::Lint }; - - skip "HTML::Lint not installed", 2 if $@; - - my $lint = new HTML::Lint; - isa_ok( $lint, "HTML::Lint" ); - - $lint->parse( $html ); - is( $lint->errors, 0, "No errors found in HTML" ); - } - -If the user does not have HTML::Lint installed, the whole block of -code I. Test::More will output special ok's -which Test::Harness interprets as skipped, but passing, tests. - -It's important that $how_many accurately reflects the number of tests -in the SKIP block so the # of tests run will match up with your plan. -If your plan is C $how_many is optional and will default to 1. - -It's perfectly safe to nest SKIP blocks. Each SKIP block must have -the label C, or Test::More can't work its magic. - -You don't skip tests which are failing because there's a bug in your -program, or for which you don't yet have code written. For that you -use TODO. Read on. - -=cut - -## no critic (Subroutines::RequireFinalReturn) -sub skip { - my( $why, $how_many ) = @_; - my $tb = Test::More->builder; - - unless( defined $how_many ) { - # $how_many can only be avoided when no_plan is in use. - _carp "skip() needs to know \$how_many tests are in the block" - unless $tb->has_plan eq 'no_plan'; - $how_many = 1; - } - - if( defined $how_many and $how_many =~ /\D/ ) { - _carp - "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; - $how_many = 1; - } - - for( 1 .. $how_many ) { - $tb->skip($why); - } - - no warnings 'exiting'; - last SKIP; -} - -=item B - - TODO: { - local $TODO = $why if $condition; - - ...normal testing code goes here... - } - -Declares a block of tests you expect to fail and $why. Perhaps it's -because you haven't fixed a bug or haven't finished a new feature: - - TODO: { - local $TODO = "URI::Geller not finished"; - - my $card = "Eight of clubs"; - is( URI::Geller->your_card, $card, 'Is THIS your card?' ); - - my $spoon; - URI::Geller->bend_spoon; - is( $spoon, 'bent', "Spoon bending, that's original" ); - } - -With a todo block, the tests inside are expected to fail. Test::More -will run the tests normally, but print out special flags indicating -they are "todo". Test::Harness will interpret failures as being ok. -Should anything succeed, it will report it as an unexpected success. -You then know the thing you had todo is done and can remove the -TODO flag. - -The nice part about todo tests, as opposed to simply commenting out a -block of tests, is it's like having a programmatic todo list. You know -how much work is left to be done, you're aware of what bugs there are, -and you'll know immediately when they're fixed. - -Once a todo test starts succeeding, simply move it outside the block. -When the block is empty, delete it. - - -=item B - - TODO: { - todo_skip $why, $how_many if $condition; - - ...normal testing code... - } - -With todo tests, it's best to have the tests actually run. That way -you'll know when they start passing. Sometimes this isn't possible. -Often a failing test will cause the whole program to die or hang, even -inside an C with and using C. In these extreme -cases you have no choice but to skip over the broken tests entirely. - -The syntax and behavior is similar to a C except the -tests will be marked as failing but todo. Test::Harness will -interpret them as passing. - -=cut - -sub todo_skip { - my( $why, $how_many ) = @_; - my $tb = Test::More->builder; - - unless( defined $how_many ) { - # $how_many can only be avoided when no_plan is in use. - _carp "todo_skip() needs to know \$how_many tests are in the block" - unless $tb->has_plan eq 'no_plan'; - $how_many = 1; - } - - for( 1 .. $how_many ) { - $tb->todo_skip($why); - } - - no warnings 'exiting'; - last TODO; -} - -=item When do I use SKIP vs. TODO? - -B, use SKIP. -This includes optional modules that aren't installed, running under -an OS that doesn't have some feature (like fork() or symlinks), or maybe -you need an Internet connection and one isn't available. - -B, use TODO. This -is for any code you haven't written yet, or bugs you have yet to fix, -but want to put tests in your testing script (always a good idea). - - -=back - - -=head2 Test control - -=over 4 - -=item B - - BAIL_OUT($reason); - -Indicates to the harness that things are going so badly all testing -should terminate. This includes the running of any additional test scripts. - -This is typically used when testing cannot continue such as a critical -module failing to compile or a necessary external utility not being -available such as a database connection failing. - -The test will exit with 255. - -For even better control look at L. - -=cut - -sub BAIL_OUT { - my $reason = shift; - my $tb = Test::More->builder; - - $tb->BAIL_OUT($reason); -} - -=back - - -=head2 Discouraged comparison functions - -The use of the following functions is discouraged as they are not -actually testing functions and produce no diagnostics to help figure -out what went wrong. They were written before is_deeply() existed -because I couldn't figure out how to display a useful diff of two -arbitrary data structures. - -These functions are usually used inside an ok(). - - ok( eq_array(\@got, \@expected) ); - -C can do that better and with diagnostics. - - is_deeply( \@got, \@expected ); - -They may be deprecated in future versions. - -=over 4 - -=item B - - my $is_eq = eq_array(\@got, \@expected); - -Checks if two arrays are equivalent. This is a deep check, so -multi-level structures are handled correctly. - -=cut - -#'# -sub eq_array { - local @Data_Stack = (); - _deep_check(@_); -} - -sub _eq_array { - my( $a1, $a2 ) = @_; - - if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { - warn "eq_array passed a non-array ref"; - return 0; - } - - return 1 if $a1 eq $a2; - - my $ok = 1; - my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; - for( 0 .. $max ) { - my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; - my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; - - next if _equal_nonrefs($e1, $e2); - - push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; - $ok = _deep_check( $e1, $e2 ); - pop @Data_Stack if $ok; - - last unless $ok; - } - - return $ok; -} - -sub _equal_nonrefs { - my( $e1, $e2 ) = @_; - - return if ref $e1 or ref $e2; - - if ( defined $e1 ) { - return 1 if defined $e2 and $e1 eq $e2; - } - else { - return 1 if !defined $e2; - } - - return; -} - -sub _deep_check { - my( $e1, $e2 ) = @_; - my $tb = Test::More->builder; - - my $ok = 0; - - # Effectively turn %Refs_Seen into a stack. This avoids picking up - # the same referenced used twice (such as [\$a, \$a]) to be considered - # circular. - local %Refs_Seen = %Refs_Seen; - - { - $tb->_unoverload_str( \$e1, \$e2 ); - - # Either they're both references or both not. - my $same_ref = !( !ref $e1 xor !ref $e2 ); - my $not_ref = ( !ref $e1 and !ref $e2 ); - - if( defined $e1 xor defined $e2 ) { - $ok = 0; - } - elsif( !defined $e1 and !defined $e2 ) { - # Shortcut if they're both undefined. - $ok = 1; - } - elsif( _dne($e1) xor _dne($e2) ) { - $ok = 0; - } - elsif( $same_ref and( $e1 eq $e2 ) ) { - $ok = 1; - } - elsif($not_ref) { - push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; - $ok = 0; - } - else { - if( $Refs_Seen{$e1} ) { - return $Refs_Seen{$e1} eq $e2; - } - else { - $Refs_Seen{$e1} = "$e2"; - } - - my $type = _type($e1); - $type = 'DIFFERENT' unless _type($e2) eq $type; - - if( $type eq 'DIFFERENT' ) { - push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; - $ok = 0; - } - elsif( $type eq 'ARRAY' ) { - $ok = _eq_array( $e1, $e2 ); - } - elsif( $type eq 'HASH' ) { - $ok = _eq_hash( $e1, $e2 ); - } - elsif( $type eq 'REF' ) { - push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; - $ok = _deep_check( $$e1, $$e2 ); - pop @Data_Stack if $ok; - } - elsif( $type eq 'SCALAR' ) { - push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; - $ok = _deep_check( $$e1, $$e2 ); - pop @Data_Stack if $ok; - } - elsif($type) { - push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; - $ok = 0; - } - else { - _whoa( 1, "No type in _deep_check" ); - } - } - } - - return $ok; -} - -sub _whoa { - my( $check, $desc ) = @_; - if($check) { - die <<"WHOA"; -WHOA! $desc -This should never happen! Please contact the author immediately! -WHOA - } -} - -=item B - - my $is_eq = eq_hash(\%got, \%expected); - -Determines if the two hashes contain the same keys and values. This -is a deep check. - -=cut - -sub eq_hash { - local @Data_Stack = (); - return _deep_check(@_); -} - -sub _eq_hash { - my( $a1, $a2 ) = @_; - - if( grep _type($_) ne 'HASH', $a1, $a2 ) { - warn "eq_hash passed a non-hash ref"; - return 0; - } - - return 1 if $a1 eq $a2; - - my $ok = 1; - my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; - foreach my $k ( keys %$bigger ) { - my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; - my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; - - next if _equal_nonrefs($e1, $e2); - - push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; - $ok = _deep_check( $e1, $e2 ); - pop @Data_Stack if $ok; - - last unless $ok; - } - - return $ok; -} - -=item B - - my $is_eq = eq_set(\@got, \@expected); - -Similar to eq_array(), except the order of the elements is B -important. This is a deep check, but the irrelevancy of order only -applies to the top level. - - ok( eq_set(\@got, \@expected) ); - -Is better written: - - is_deeply( [sort @got], [sort @expected] ); - -B By historical accident, this is not a true set comparison. -While the order of elements does not matter, duplicate elements do. - -B eq_set() does not know how to deal with references at the top -level. The following is an example of a comparison which might not work: - - eq_set([\1, \2], [\2, \1]); - -L contains much better set comparison functions. - -=cut - -sub eq_set { - my( $a1, $a2 ) = @_; - return 0 unless @$a1 == @$a2; - - no warnings 'uninitialized'; - - # It really doesn't matter how we sort them, as long as both arrays are - # sorted with the same algorithm. - # - # Ensure that references are not accidentally treated the same as a - # string containing the reference. - # - # Have to inline the sort routine due to a threading/sort bug. - # See [rt.cpan.org 6782] - # - # I don't know how references would be sorted so we just don't sort - # them. This means eq_set doesn't really work with refs. - return eq_array( - [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], - [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], - ); -} - -=back - - -=head2 Extending and Embedding Test::More - -Sometimes the Test::More interface isn't quite enough. Fortunately, -Test::More is built on top of Test::Builder which provides a single, -unified backend for any test library to use. This means two test -libraries which both use Test::Builder B. - -If you simply want to do a little tweaking of how the tests behave, -you can access the underlying Test::Builder object like so: - -=over 4 - -=item B - - my $test_builder = Test::More->builder; - -Returns the Test::Builder object underlying Test::More for you to play -with. - - -=back - - -=head1 EXIT CODES - -If all your tests passed, Test::Builder will exit with zero (which is -normal). If anything failed it will exit with how many failed. If -you run less (or more) tests than you planned, the missing (or extras) -will be considered failures. If no tests were ever run Test::Builder -will throw a warning and exit with 255. If the test died, even after -having successfully completed all its tests, it will still be -considered a failure and will exit with 255. - -So the exit codes are... - - 0 all tests successful - 255 test died or all passed but wrong # of tests run - any other number how many failed (including missing or extras) - -If you fail more than 254 tests, it will be reported as 254. - -B This behavior may go away in future versions. - - -=head1 COMPATIBILITY - -Test::More works with Perls as old as 5.8.1. - -Thread support is not very reliable before 5.10.1, but that's -because threads are not very reliable before 5.10.1. - -Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. - -Key feature milestones include: - -=over 4 - -=item subtests - -Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. - -=item C - -This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. - -=item C - -Although C was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. - -=item C C and C - -These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. - -=back - -There is a full version history in the Changes file, and the Test::More versions included as core can be found using L: - - $ corelist -a Test::More - - -=head1 CAVEATS and NOTES - -=over 4 - -=item utf8 / "Wide character in print" - -If you use utf8 or other non-ASCII characters with Test::More you -might get a "Wide character in print" warning. Using C will not fix it. Test::Builder (which powers -Test::More) duplicates STDOUT and STDERR. So any changes to them, -including changing their output disciplines, will not be seem by -Test::More. - -One work around is to apply encodings to STDOUT and STDERR as early -as possible and before Test::More (or any other Test module) loads. - - use open ':std', ':encoding(utf8)'; - use Test::More; - -A more direct work around is to change the filehandles used by -Test::Builder. - - my $builder = Test::More->builder; - binmode $builder->output, ":encoding(utf8)"; - binmode $builder->failure_output, ":encoding(utf8)"; - binmode $builder->todo_output, ":encoding(utf8)"; - - -=item Overloaded objects - -String overloaded objects are compared B (or in cmp_ok()'s -case, strings or numbers as appropriate to the comparison op). This -prevents Test::More from piercing an object's interface allowing -better blackbox testing. So if a function starts returning overloaded -objects instead of bare strings your tests won't notice the -difference. This is good. - -However, it does mean that functions like is_deeply() cannot be used to -test the internals of string overloaded objects. In this case I would -suggest L which contains more flexible testing functions for -complex data structures. - - -=item Threads - -Test::More will only be aware of threads if "use threads" has been done -I Test::More is loaded. This is ok: - - use threads; - use Test::More; - -This may cause problems: - - use Test::More - use threads; - -5.8.1 and above are supported. Anything below that has too many bugs. - -=back - - -=head1 HISTORY - -This is a case of convergent evolution with Joshua Pritikin's Test -module. I was largely unaware of its existence when I'd first -written my own ok() routines. This module exists because I can't -figure out how to easily wedge test names into Test's interface (along -with a few other problems). - -The goal here is to have a testing utility that's simple to learn, -quick to use and difficult to trip yourself up with while still -providing more flexibility than the existing Test.pm. As such, the -names of the most common routines are kept tiny, special cases and -magic side-effects are kept to a minimum. WYSIWYG. - - -=head1 SEE ALSO - -L if all this confuses you and you just want to write -some tests. You can upgrade to Test::More later (it's forward -compatible). - -L is the test runner and output interpreter for Perl. -It's the thing that powers C and where the C utility -comes from. - -L tests written with Test.pm, the original testing -module, do not play well with other testing libraries. Test::Legacy -emulates the Test.pm interface and does play well with others. - -L for more ways to test complex data structures. -And it plays well with Test::More. - -L is like xUnit but more perlish. - -L gives you more powerful complex data structure testing. - -L shows the idea of embedded testing. - -L installs a whole bunch of useful test modules. - - -=head1 AUTHORS - -Michael G Schwern Eschwern@pobox.comE with much inspiration -from Joshua Pritikin's Test module and lots of help from Barrie -Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and -the perl-qa gang. - - -=head1 BUGS - -See F to report and view bugs. - - -=head1 SOURCE - -The source code repository for Test::More can be found at -F. - - -=head1 COPYRIGHT - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - -1; diff --git a/t/lib/Test/Simple.pm b/t/lib/Test/Simple.pm deleted file mode 100644 index 411b38b..0000000 --- a/t/lib/Test/Simple.pm +++ /dev/null @@ -1,214 +0,0 @@ -package Test::Simple; - -use 5.006; - -use strict; - -our $VERSION = '0.99'; -$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) - -use Test::Builder::Module 0.99; -our @ISA = qw(Test::Builder::Module); -our @EXPORT = qw(ok); - -my $CLASS = __PACKAGE__; - -=head1 NAME - -Test::Simple - Basic utilities for writing tests. - -=head1 SYNOPSIS - - use Test::Simple tests => 1; - - ok( $foo eq $bar, 'foo is bar' ); - - -=head1 DESCRIPTION - -** If you are unfamiliar with testing B first! ** - -This is an extremely simple, extremely basic module for writing tests -suitable for CPAN modules and other pursuits. If you wish to do more -complicated testing, use the Test::More module (a drop-in replacement -for this one). - -The basic unit of Perl testing is the ok. For each thing you want to -test your program will print out an "ok" or "not ok" to indicate pass -or fail. You do this with the ok() function (see below). - -The only other constraint is you must pre-declare how many tests you -plan to run. This is in case something goes horribly wrong during the -test and your test program aborts, or skips a test or whatever. You -do this like so: - - use Test::Simple tests => 23; - -You must have a plan. - - -=over 4 - -=item B - - ok( $foo eq $bar, $name ); - ok( $foo eq $bar ); - -ok() is given an expression (in this case C<$foo eq $bar>). If it's -true, the test passed. If it's false, it didn't. That's about it. - -ok() prints out either "ok" or "not ok" along with a test number (it -keeps track of that for you). - - # This produces "ok 1 - Hell not yet frozen over" (or not ok) - ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); - -If you provide a $name, that will be printed along with the "ok/not -ok" to make it easier to find your test when if fails (just search for -the name). It also makes it easier for the next guy to understand -what your test is for. It's highly recommended you use test names. - -All tests are run in scalar context. So this: - - ok( @stuff, 'I have some stuff' ); - -will do what you mean (fail if stuff is empty) - -=cut - -sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) - return $CLASS->builder->ok(@_); -} - -=back - -Test::Simple will start by printing number of tests run in the form -"1..M" (so "1..5" means you're going to run 5 tests). This strange -format lets Test::Harness know how many tests you plan on running in -case something goes horribly wrong. - -If all your tests passed, Test::Simple will exit with zero (which is -normal). If anything failed it will exit with how many failed. If -you run less (or more) tests than you planned, the missing (or extras) -will be considered failures. If no tests were ever run Test::Simple -will throw a warning and exit with 255. If the test died, even after -having successfully completed all its tests, it will still be -considered a failure and will exit with 255. - -So the exit codes are... - - 0 all tests successful - 255 test died or all passed but wrong # of tests run - any other number how many failed (including missing or extras) - -If you fail more than 254 tests, it will be reported as 254. - -This module is by no means trying to be a complete testing system. -It's just to get you started. Once you're off the ground its -recommended you look at L. - - -=head1 EXAMPLE - -Here's an example of a simple .t file for the fictional Film module. - - use Test::Simple tests => 5; - - use Film; # What you're testing. - - my $btaste = Film->new({ Title => 'Bad Taste', - Director => 'Peter Jackson', - Rating => 'R', - NumExplodingSheep => 1 - }); - ok( defined($btaste) && ref $btaste eq 'Film', 'new() works' ); - - ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); - ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); - ok( $btaste->Rating eq 'R', 'Rating() get' ); - ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); - -It will produce output like this: - - 1..5 - ok 1 - new() works - ok 2 - Title() get - ok 3 - Director() get - not ok 4 - Rating() get - # Failed test 'Rating() get' - # in t/film.t at line 14. - ok 5 - NumExplodingSheep() get - # Looks like you failed 1 tests of 5 - -Indicating the Film::Rating() method is broken. - - -=head1 CAVEATS - -Test::Simple will only report a maximum of 254 failures in its exit -code. If this is a problem, you probably have a huge test script. -Split it into multiple files. (Otherwise blame the Unix folks for -using an unsigned short integer as the exit status). - -Because VMS's exit codes are much, much different than the rest of the -universe, and perl does horrible mangling to them that gets in my way, -it works like this on VMS. - - 0 SS$_NORMAL all tests successful - 4 SS$_ABORT something went wrong - -Unfortunately, I can't differentiate any further. - - -=head1 NOTES - -Test::Simple is B tested all the way back to perl 5.6.0. - -Test::Simple is thread-safe in perl 5.8.1 and up. - -=head1 HISTORY - -This module was conceived while talking with Tony Bowden in his -kitchen one night about the problems I was having writing some really -complicated feature into the new Testing module. He observed that the -main problem is not dealing with these edge cases but that people hate -to write tests B. What was needed was a dead simple module -that took all the hard work out of testing and was really, really easy -to learn. Paul Johnson simultaneously had this idea (unfortunately, -he wasn't in Tony's kitchen). This is it. - - -=head1 SEE ALSO - -=over 4 - -=item L - -More testing functions! Once you outgrow Test::Simple, look at -Test::More. Test::Simple is 100% forward compatible with Test::More -(i.e. you can just use Test::More instead of Test::Simple in your -programs and things will still work). - -=back - -Look in Test::More's SEE ALSO for more testing modules. - - -=head1 AUTHORS - -Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern -Eschwern@pobox.comE, wardrobe by Calvin Klein. - - -=head1 COPYRIGHT - -Copyright 2001-2008 by Michael G Schwern Eschwern@pobox.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - -1;