From eeaf54cafd6017223a7db4bcedcbc03fcb03e52a Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 29 Apr 2026 17:56:51 +0200 Subject: [PATCH] feat(moose): bundle pure-Perl Moose runtime dependencies Bundle the upstream pure-Perl modules that the bundled Moose 2.4000 needs to load, so `examples/moose.pl` (and any `use Moose;` script) works on a fresh PerlOnJava install without first running `jcpan` to populate ~/.perlonjava/lib. Repro before this change: JAVA_TOOL_OPTIONS="-Duser.home=/tmp/empty-home" \ ./jperl examples/moose.pl # Can't locate Class/Load.pm in @INC Modules bundled (copied verbatim from CPAN, all pure-Perl, all under the same Perl-5 license): Class/Load.pm Class/Load/PP.pm Module/Runtime.pm Module/Implementation.pm Data/OptList.pm Params/Util.pm Params/Util/PP.pm Sub/Install.pm Sub/Exporter.pm Sub/Exporter/Progressive.pm MRO/Compat.pm Devel/OverloadInfo.pm Devel/StackTrace.pm Devel/StackTrace/Frame.pm Dist/CheckConflicts.pm Eval/Closure.pm Package/DeprecationManager.pm Class/Load/XS.pm is intentionally NOT bundled: its only job is to XSLoader::load() a native .so, which does nothing on the JVM and leaves Module::Implementation thinking the XS impl loaded successfully but with no symbols, so callers blow up with "Undefined subroutine &Class::Load::XS::is_class_loaded". With Class/Load/XS.pm absent, Module::Implementation falls back cleanly to Class::Load::PP. The same reasoning is why we don't ship Package::Stash::XS. Verification: JAVA_TOOL_OPTIONS="-Duser.home=/tmp/empty-home" \ ./jperl examples/moose.pl # 1..7 # all 7 subtests pass make # BUILD SUCCESSFUL, all unit tests pass Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/Class/Load.pm | 420 ++++ src/main/perl/lib/Class/Load/PP.pm | 59 + src/main/perl/lib/Data/OptList.pm | 416 ++++ src/main/perl/lib/Devel/OverloadInfo.pm | 309 +++ src/main/perl/lib/Devel/StackTrace.pm | 624 ++++++ src/main/perl/lib/Devel/StackTrace/Frame.pm | 272 +++ src/main/perl/lib/Dist/CheckConflicts.pm | 361 ++++ src/main/perl/lib/Eval/Closure.pm | 379 ++++ src/main/perl/lib/MRO/Compat.pm | 407 ++++ src/main/perl/lib/Module/Implementation.pm | 290 +++ src/main/perl/lib/Module/Runtime.pm | 520 +++++ .../perl/lib/Package/DeprecationManager.pm | 368 ++++ src/main/perl/lib/Params/Util.pm | 486 +++++ src/main/perl/lib/Params/Util/PP.pm | 276 +++ src/main/perl/lib/Sub/Exporter.pm | 1769 +++++++++++++++++ src/main/perl/lib/Sub/Exporter/Progressive.pm | 174 ++ src/main/perl/lib/Sub/Install.pm | 486 +++++ 18 files changed, 7618 insertions(+), 2 deletions(-) create mode 100644 src/main/perl/lib/Class/Load.pm create mode 100644 src/main/perl/lib/Class/Load/PP.pm create mode 100644 src/main/perl/lib/Data/OptList.pm create mode 100644 src/main/perl/lib/Devel/OverloadInfo.pm create mode 100644 src/main/perl/lib/Devel/StackTrace.pm create mode 100644 src/main/perl/lib/Devel/StackTrace/Frame.pm create mode 100644 src/main/perl/lib/Dist/CheckConflicts.pm create mode 100644 src/main/perl/lib/Eval/Closure.pm create mode 100644 src/main/perl/lib/MRO/Compat.pm create mode 100644 src/main/perl/lib/Module/Implementation.pm create mode 100644 src/main/perl/lib/Module/Runtime.pm create mode 100644 src/main/perl/lib/Package/DeprecationManager.pm create mode 100755 src/main/perl/lib/Params/Util.pm create mode 100644 src/main/perl/lib/Params/Util/PP.pm create mode 100644 src/main/perl/lib/Sub/Exporter.pm create mode 100644 src/main/perl/lib/Sub/Exporter/Progressive.pm create mode 100644 src/main/perl/lib/Sub/Install.pm diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 533c0d3f5..576762dc0 100644 --- a/src/main/java/org/perlonjava/core/Configuration.java +++ b/src/main/java/org/perlonjava/core/Configuration.java @@ -33,7 +33,7 @@ public final class Configuration { * Automatically populated by Gradle/Maven during build. * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String gitCommitId = "8acc9ffd5"; + public static final String gitCommitId = "e892920b5"; /** * Git commit date of the build (ISO format: YYYY-MM-DD). @@ -48,7 +48,7 @@ public final class Configuration { * Parsed by App::perlbrew and other tools via: perl -V | grep "Compiled at" * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String buildTimestamp = "Apr 29 2026 17:29:18"; + public static final String buildTimestamp = "Apr 29 2026 17:55:45"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/Class/Load.pm b/src/main/perl/lib/Class/Load.pm new file mode 100644 index 000000000..cf456a32d --- /dev/null +++ b/src/main/perl/lib/Class/Load.pm @@ -0,0 +1,420 @@ +use strict; +use warnings; +package Class::Load; # git description: v0.24-5-g22a44fd +# ABSTRACT: A working (require "Class::Name") and more +# KEYWORDS: class module load require use runtime + +our $VERSION = '0.25'; + +use base 'Exporter'; +use Data::OptList 0.110 (); +use Module::Implementation 0.04; +use Module::Runtime 0.012 (); +use Try::Tiny; + +{ + my $loader = Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PP' ], + symbols => ['is_class_loaded'], + ); + + $loader->(); +} + +our @EXPORT_OK = qw/load_class load_optional_class try_load_class is_class_loaded load_first_existing_class/; +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, +); + +our $ERROR; + +sub load_class { + my $class = shift; + my $options = shift; + + my ($res, $e) = try_load_class($class, $options); + return $class if $res; + + _croak($e); +} + +sub load_first_existing_class { + my $classes = Data::OptList::mkopt(\@_) + or return; + + foreach my $class (@{$classes}) { + Module::Runtime::check_module_name($class->[0]); + } + + for my $class (@{$classes}) { + my ($name, $options) = @{$class}; + + # We need to be careful not to pass an undef $options to this sub, + # since the XS version will blow up if that happens. + return $name if is_class_loaded($name, ($options ? $options : ())); + + my ($res, $e) = try_load_class($name, $options); + + return $name if $res; + + my $file = Module::Runtime::module_notional_filename($name); + + next if $e =~ /^Can't locate \Q$file\E in \@INC/; + next + if $options + && defined $options->{-version} + && $e =~ _version_fail_re($name, $options->{-version}); + + _croak("Couldn't load class ($name) because: $e"); + } + + my @list = map { + $_->[0] + . ( $_->[1] && defined $_->[1]{-version} + ? " (version >= $_->[1]{-version})" + : q{} ) + } @{$classes}; + + my $err + .= q{Can't locate } + . _or_list(@list) + . " in \@INC (\@INC contains: @INC)."; + _croak($err); +} + +sub _version_fail_re { + my $name = shift; + my $vers = shift; + + return qr/\Q$name\E version \Q$vers\E required--this is only version/; +} + +sub _nonexistent_fail_re { + my $name = shift; + + my $file = Module::Runtime::module_notional_filename($name); + return qr/Can't locate \Q$file\E in \@INC/; +} + +sub _or_list { + return $_[0] if @_ == 1; + + return join ' or ', @_ if @_ ==2; + + my $last = pop; + + my $list = join ', ', @_; + $list .= ', or ' . $last; + + return $list; +} + +sub load_optional_class { + my $class = shift; + my $options = shift; + + Module::Runtime::check_module_name($class); + + my ($res, $e) = try_load_class($class, $options); + return 1 if $res; + + return 0 + if $options + && defined $options->{-version} + && $e =~ _version_fail_re($class, $options->{-version}); + + return 0 + if $e =~ _nonexistent_fail_re($class); + + _croak($e); +} + +sub try_load_class { + my $class = shift; + my $options = shift; + + Module::Runtime::check_module_name($class); + + local $@; + undef $ERROR; + + if (is_class_loaded($class)) { + # We need to check this here rather than in is_class_loaded() because + # we want to return the error message for a failed version check, but + # is_class_loaded just returns true/false. + return 1 unless $options && defined $options->{-version}; + return try { + $class->VERSION($options->{-version}); + 1; + } + catch { + _error($_); + }; + } + + my $file = Module::Runtime::module_notional_filename($class); + # This says "our diagnostics of the package + # say perl's INC status about the file being loaded are + # wrong", so we delete it from %INC, so when we call require(), + # perl will *actually* try reloading the file. + # + # If the file is already in %INC, it won't retry, + # And on 5.8, it won't fail either! + # + # The extra benefit of this trick, is it helps even on + # 5.10, as instead of dying with "Compilation failed", + # it will die with the actual error, and that's a win-win. + delete $INC{$file}; + return try { + local $SIG{__DIE__} = 'DEFAULT'; + if ($options && defined $options->{-version}) { + Module::Runtime::use_module($class, $options->{-version}); + } + else { + Module::Runtime::require_module($class); + } + 1; + } + catch { + _error($_); + }; +} + +sub _error { + my $e = shift; + + $e =~ s/ at .+?Runtime\.pm line [0-9]+\.$//; + chomp $e; + + $ERROR = $e; + return 0 unless wantarray; + return 0, $ERROR; +} + +sub _croak { + require Carp; + local $Carp::CarpLevel = $Carp::CarpLevel + 2; + Carp::croak(shift); +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Load - A working (require "Class::Name") and more + +=head1 VERSION + +version 0.25 + +=head1 SYNOPSIS + + use Class::Load ':all'; + + try_load_class('Class::Name') + or plan skip_all => "Class::Name required to run these tests"; + + load_class('Class::Name'); + + is_class_loaded('Class::Name'); + + my $baseclass = load_optional_class('Class::Name::MightExist') + ? 'Class::Name::MightExist' + : 'Class::Name::Default'; + +=head1 DESCRIPTION + +C only accepts C style module names, not +C. How frustrating! For that, we provide +C. + +It's often useful to test whether a module can be loaded, instead of throwing +an error when it's not available. For that, we provide +C. + +Finally, sometimes we need to know whether a particular class has been loaded. +Asking C<%INC> is an option, but that will miss inner packages and any class +for which the filename does not correspond to the package name. For that, we +provide C. + +=head1 FUNCTIONS + +=head2 load_class Class::Name, \%options + +C will load C or throw an error, much like C. + +If C is already loaded (checked with C) then it +will not try to load the class. This is useful when you have inner packages +which C does not check. + +The C<%options> hash currently accepts one key, C<-version>. If you specify a +version, then this subroutine will call C<< Class::Name->VERSION( +$options{-version} ) >> internally, which will throw an error if the class's +version is not equal to or greater than the version you requested. + +This method will return the name of the class on success. + +=head2 try_load_class Class::Name, \%options -> (0|1, error message) + +Returns 1 if the class was loaded, 0 if it was not. If the class was not +loaded, the error will be returned as a second return value in list context. + +Again, if C is already loaded (checked with C) +then it will not try to load the class. This is useful when you have inner +packages which C does not check. + +Like C, you can pass a C<-version> in C<%options>. If the version +is not sufficient, then this subroutine will return false. + +=head2 is_class_loaded Class::Name, \%options -> 0|1 + +This uses a number of heuristics to determine if the class C is +loaded. There heuristics were taken from L's old pure-perl +implementation. + +Like C, you can pass a C<-version> in C<%options>. If the version +is not sufficient, then this subroutine will return false. + +=head2 load_first_existing_class Class::Name, \%options, ... + +This attempts to load the first loadable class in the list of classes +given. Each class name can be followed by an options hash reference. + +If any one of the classes loads and passes the optional version check, that +class name will be returned. If I of the classes can be loaded (or none +pass their version check), then an error will be thrown. + +If, when attempting to load a class, it fails to load because of a syntax +error, then an error will be thrown immediately. + +=head2 load_optional_class Class::Name, \%options -> 0|1 + +C is a lot like C, but also a lot like +C. + +If the class exists, and it works, then it will return 1. If you specify a +version in C<%options>, then the version check must succeed or it will return +0. + +If the class doesn't exist, and it appears to not exist on disk either, it +will return 0. + +If the class exists on disk, but loading from disk results in an error +(e.g.: a syntax error), then it will C with that error. + +This is useful for using if you want a fallback module system, i.e.: + + my $class = load_optional_class($foo) ? $foo : $default; + +That way, if $foo does exist, but can't be loaded due to error, you won't +get the behaviour of it simply not existing. + +=head1 CAVEATS + +Because of some of the heuristics that this module uses to infer whether a +module has been loaded, some false positives may occur in C +checks (which are also performed internally in other interfaces) -- if a class +has started to be loaded but then dies, it may appear that it has already been +loaded, which can cause other things to make the wrong decision. +L doesn't have this issue, but it also doesn't do some things +that this module does -- for example gracefully handle packages that have been +defined inline in the same file as another package. + +=head1 SEE ALSO + +=over 4 + +=item L + +This blog post is a good overview of the current state of the existing modules +for loading other modules in various ways. + +=item L + +This blog post describes how to handle optional modules with L. + +=item L + +This Japanese blog post describes why L now uses L +over its competitors. + +=item L, L, L, etc + +This module was designed to be used anywhere you have +C, which occurs in many large projects. + +=item L + +A leaner approach to loading modules + +=back + +=head1 SUPPORT + +Bugs may be submitted through L +(or L). + +There is also a mailing list available for users of this distribution, at +L. + +There is also an irc channel available for users of this distribution, at +L on C|irc://irc.perl.org/#moose>. + +=head1 AUTHOR + +Shawn M Moore + +=head1 CONTRIBUTORS + +=for stopwords Dave Rolsky Karen Etheridge Shawn Moore Jesse Luehrs Kent Fredric Paul Howarth Olivier Mengué Caleb Cushing + +=over 4 + +=item * + +Dave Rolsky + +=item * + +Karen Etheridge + +=item * + +Shawn Moore + +=item * + +Jesse Luehrs + +=item * + +Kent Fredric + +=item * + +Paul Howarth + +=item * + +Olivier Mengué + +=item * + +Caleb Cushing + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2008 by Shawn M Moore. + +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/src/main/perl/lib/Class/Load/PP.pm b/src/main/perl/lib/Class/Load/PP.pm new file mode 100644 index 000000000..a6b37ef77 --- /dev/null +++ b/src/main/perl/lib/Class/Load/PP.pm @@ -0,0 +1,59 @@ +use strict; +use warnings; +package Class::Load::PP; + +our $VERSION = '0.25'; + +use Module::Runtime (); +use Package::Stash 0.14; +use Scalar::Util (); +use Try::Tiny; + +sub is_class_loaded { + my $class = shift; + my $options = shift; + + my $loaded = _is_class_loaded($class); + + return $loaded if ! $loaded; + return $loaded unless $options && $options->{-version}; + + return try { + $class->VERSION($options->{-version}); + 1; + } + catch { + 0; + }; +} + +sub _is_class_loaded { + my $class = shift; + + return 0 unless Module::Runtime::is_module_name($class); + + my $stash = Package::Stash->new($class); + + if ($stash->has_symbol('$VERSION')) { + my $version = ${ $stash->get_symbol('$VERSION') }; + if (defined $version) { + return 1 if ! ref $version; + # Sometimes $VERSION ends up as a reference to undef (weird) + return 1 if ref $version && Scalar::Util::reftype $version eq 'SCALAR' && defined ${$version}; + # a version object + return 1 if Scalar::Util::blessed $version; + } + } + + if ($stash->has_symbol('@ISA')) { + return 1 if @{ $stash->get_symbol('@ISA') }; + } + + # check for any method + return 1 if $stash->list_all_symbols('CODE'); + + # fail + return 0; +} + +1; diff --git a/src/main/perl/lib/Data/OptList.pm b/src/main/perl/lib/Data/OptList.pm new file mode 100644 index 000000000..5a942c8c2 --- /dev/null +++ b/src/main/perl/lib/Data/OptList.pm @@ -0,0 +1,416 @@ +use strict; +use warnings; +package Data::OptList 0.114; +# ABSTRACT: parse and validate simple name/value option pairs + +use List::Util (); +use Params::Util (); +use Sub::Install 0.921 (); + +#pod =head1 SYNOPSIS +#pod +#pod use Data::OptList; +#pod +#pod my $options = Data::OptList::mkopt([ +#pod qw(key1 key2 key3 key4), +#pod key5 => { ... }, +#pod key6 => [ ... ], +#pod key7 => sub { ... }, +#pod key8 => { ... }, +#pod key8 => [ ... ], +#pod ]); +#pod +#pod ...is the same thing, more or less, as: +#pod +#pod my $options = [ +#pod [ key1 => undef, ], +#pod [ key2 => undef, ], +#pod [ key3 => undef, ], +#pod [ key4 => undef, ], +#pod [ key5 => { ... }, ], +#pod [ key6 => [ ... ], ], +#pod [ key7 => sub { ... }, ], +#pod [ key8 => { ... }, ], +#pod [ key8 => [ ... ], ], +#pod ]); +#pod +#pod =head1 DESCRIPTION +#pod +#pod Hashes are great for storing named data, but if you want more than one entry +#pod for a name, you have to use a list of pairs. Even then, this is really boring +#pod to write: +#pod +#pod $values = [ +#pod foo => undef, +#pod bar => undef, +#pod baz => undef, +#pod xyz => { ... }, +#pod ]; +#pod +#pod Just look at all those undefs! Don't worry, we can get rid of those: +#pod +#pod $values = [ +#pod map { $_ => undef } qw(foo bar baz), +#pod xyz => { ... }, +#pod ]; +#pod +#pod Aaaauuugh! We've saved a little typing, but now it requires thought to read, +#pod and thinking is even worse than typing... and it's got a bug! It looked right, +#pod didn't it? Well, the C<< xyz => { ... } >> gets consumed by the map, and we +#pod don't get the data we wanted. +#pod +#pod With Data::OptList, you can do this instead: +#pod +#pod $values = Data::OptList::mkopt([ +#pod qw(foo bar baz), +#pod xyz => { ... }, +#pod ]); +#pod +#pod This works by assuming that any defined scalar is a name and any reference +#pod following a name is its value. +#pod +#pod =func mkopt +#pod +#pod my $opt_list = Data::OptList::mkopt($input, \%arg); +#pod +#pod Valid arguments are: +#pod +#pod moniker - a word used in errors to describe the opt list; encouraged +#pod require_unique - if true, no name may appear more than once +#pod must_be - types to which opt list values are limited (described below) +#pod name_test - a coderef used to test whether a value can be a name +#pod (described below, but you probably don't want this) +#pod +#pod This produces an array of arrays; the inner arrays are name/value pairs. +#pod Values will be either "undef" or a reference. +#pod +#pod Positional parameters may be used for compatibility with the old C +#pod interface: +#pod +#pod my $opt_list = Data::OptList::mkopt($input, $moniker, $req_uni, $must_be); +#pod +#pod Valid values for C<$input>: +#pod +#pod undef -> [] +#pod hashref -> [ [ key1 => value1 ] ... ] # non-ref values become undef +#pod arrayref -> every name followed by a non-name becomes a pair: [ name => ref ] +#pod every name followed by undef becomes a pair: [ name => undef ] +#pod otherwise, it becomes [ name => undef ] like so: +#pod [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ] +#pod +#pod By default, a I is any defined non-reference. The C parameter +#pod can be a code ref that tests whether the argument passed it is a name or not. +#pod This should be used rarely. Interactions between C and +#pod C are not yet particularly elegant, as C just tests +#pod string equality. B +#pod +#pod The C parameter is either a scalar or array of scalars; it defines +#pod what kind(s) of refs may be values. If an invalid value is found, an exception +#pod is thrown. If no value is passed for this argument, any reference is valid. +#pod If C specifies that values must be CODE, HASH, ARRAY, or SCALAR, then +#pod Params::Util is used to check whether the given value can provide that +#pod interface. Otherwise, it checks that the given value is an object of the kind. +#pod +#pod In other words: +#pod +#pod [ qw(SCALAR HASH Object::Known) ] +#pod +#pod Means: +#pod +#pod _SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known') +#pod +#pod =cut + +my %test_for; +BEGIN { + %test_for = ( + CODE => \&Params::Util::_CODELIKE, ## no critic + HASH => \&Params::Util::_HASHLIKE, ## no critic + ARRAY => \&Params::Util::_ARRAYLIKE, ## no critic + SCALAR => \&Params::Util::_SCALAR0, ## no critic + ); +} + +sub mkopt { + my ($opt_list) = shift; + + my ($moniker, $require_unique, $must_be); # the old positional args + my ($name_test, $is_a); + + if (@_) { + if (@_ == 1 and Params::Util::_HASHLIKE($_[0])) { + ($moniker, $require_unique, $must_be, $name_test) + = @{$_[0]}{ qw(moniker require_unique must_be name_test) }; + } else { + ($moniker, $require_unique, $must_be) = @_; + } + + # Transform the $must_be specification into a closure $is_a + # that will check if a value matches the spec + + if (defined $must_be) { + $must_be = [ $must_be ] unless ref $must_be; + my @checks = map { + my $class = $_; + $test_for{$class} + || sub { Params::Util::_INSTANCE($_[0], $class) } + } @$must_be; + + $is_a = (@checks == 1) + ? $checks[0] + : sub { + my $value = $_[0]; + List::Util::first { defined($_->($value)) } @checks + }; + + $moniker = 'unnamed' unless defined $moniker; + } + } + + return [] unless $opt_list; + + $name_test ||= sub { ! ref $_[0] }; + + $opt_list = [ + map { $_ => (ref $opt_list->{$_} ? $opt_list->{$_} : ()) } keys %$opt_list + ] if ref $opt_list eq 'HASH'; + + my @return; + my %seen; + + for (my $i = 0; $i < @$opt_list; $i++) { ## no critic + my $name = $opt_list->[$i]; + + if ($require_unique) { + Carp::croak "multiple definitions provided for $name" if $seen{$name}++; + } + + my $value; + + if ($i < $#$opt_list) { + if (not defined $opt_list->[$i+1]) { + $i++ + } elsif (! $name_test->($opt_list->[$i+1])) { + $value = $opt_list->[++$i]; + if ($is_a && !$is_a->($value)) { + my $ref = ref $value; + Carp::croak "$ref-ref values are not valid in $moniker opt list"; + } + } + } + + push @return, [ $name => $value ]; + } + + return \@return; +} + +#pod =func mkopt_hash +#pod +#pod my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be); +#pod +#pod Given valid C> input, this routine returns a reference to a hash. It +#pod will throw an exception if any name has more than one value. +#pod +#pod =cut + +sub mkopt_hash { + my ($opt_list, $moniker, $must_be) = @_; + return {} unless $opt_list; + + $opt_list = mkopt($opt_list, $moniker, 1, $must_be); + my %hash = map { $_->[0] => $_->[1] } @$opt_list; + return \%hash; +} + +#pod =head1 EXPORTS +#pod +#pod Both C and C may be exported on request. +#pod +#pod =cut + +BEGIN { + *import = Sub::Install::exporter { + exports => [qw(mkopt mkopt_hash)], + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Data::OptList - parse and validate simple name/value option pairs + +=head1 VERSION + +version 0.114 + +=head1 SYNOPSIS + + use Data::OptList; + + my $options = Data::OptList::mkopt([ + qw(key1 key2 key3 key4), + key5 => { ... }, + key6 => [ ... ], + key7 => sub { ... }, + key8 => { ... }, + key8 => [ ... ], + ]); + +...is the same thing, more or less, as: + + my $options = [ + [ key1 => undef, ], + [ key2 => undef, ], + [ key3 => undef, ], + [ key4 => undef, ], + [ key5 => { ... }, ], + [ key6 => [ ... ], ], + [ key7 => sub { ... }, ], + [ key8 => { ... }, ], + [ key8 => [ ... ], ], + ]); + +=head1 DESCRIPTION + +Hashes are great for storing named data, but if you want more than one entry +for a name, you have to use a list of pairs. Even then, this is really boring +to write: + + $values = [ + foo => undef, + bar => undef, + baz => undef, + xyz => { ... }, + ]; + +Just look at all those undefs! Don't worry, we can get rid of those: + + $values = [ + map { $_ => undef } qw(foo bar baz), + xyz => { ... }, + ]; + +Aaaauuugh! We've saved a little typing, but now it requires thought to read, +and thinking is even worse than typing... and it's got a bug! It looked right, +didn't it? Well, the C<< xyz => { ... } >> gets consumed by the map, and we +don't get the data we wanted. + +With Data::OptList, you can do this instead: + + $values = Data::OptList::mkopt([ + qw(foo bar baz), + xyz => { ... }, + ]); + +This works by assuming that any defined scalar is a name and any reference +following a name is its value. + +=head1 PERL VERSION + +This library should run on perls released even a long time ago. It should +work on any version of perl released in the last five years. + +Although it may work on older versions of perl, no guarantee is made that the +minimum required version will not be increased. The version may be increased +for any reason, and there is no promise that patches will be accepted to +lower the minimum required perl. + +=head1 FUNCTIONS + +=head2 mkopt + + my $opt_list = Data::OptList::mkopt($input, \%arg); + +Valid arguments are: + + moniker - a word used in errors to describe the opt list; encouraged + require_unique - if true, no name may appear more than once + must_be - types to which opt list values are limited (described below) + name_test - a coderef used to test whether a value can be a name + (described below, but you probably don't want this) + +This produces an array of arrays; the inner arrays are name/value pairs. +Values will be either "undef" or a reference. + +Positional parameters may be used for compatibility with the old C +interface: + + my $opt_list = Data::OptList::mkopt($input, $moniker, $req_uni, $must_be); + +Valid values for C<$input>: + + undef -> [] + hashref -> [ [ key1 => value1 ] ... ] # non-ref values become undef + arrayref -> every name followed by a non-name becomes a pair: [ name => ref ] + every name followed by undef becomes a pair: [ name => undef ] + otherwise, it becomes [ name => undef ] like so: + [ "a", "b", [ 1, 2 ] ] -> [ [ a => undef ], [ b => [ 1, 2 ] ] ] + +By default, a I is any defined non-reference. The C parameter +can be a code ref that tests whether the argument passed it is a name or not. +This should be used rarely. Interactions between C and +C are not yet particularly elegant, as C just tests +string equality. B + +The C parameter is either a scalar or array of scalars; it defines +what kind(s) of refs may be values. If an invalid value is found, an exception +is thrown. If no value is passed for this argument, any reference is valid. +If C specifies that values must be CODE, HASH, ARRAY, or SCALAR, then +Params::Util is used to check whether the given value can provide that +interface. Otherwise, it checks that the given value is an object of the kind. + +In other words: + + [ qw(SCALAR HASH Object::Known) ] + +Means: + + _SCALAR0($value) or _HASH($value) or _INSTANCE($value, 'Object::Known') + +=head2 mkopt_hash + + my $opt_hash = Data::OptList::mkopt_hash($input, $moniker, $must_be); + +Given valid C> input, this routine returns a reference to a hash. It +will throw an exception if any name has more than one value. + +=head1 EXPORTS + +Both C and C may be exported on request. + +=head1 AUTHOR + +Ricardo Signes + +=head1 CONTRIBUTORS + +=for stopwords Olivier Mengué Ricardo Signes + +=over 4 + +=item * + +Olivier Mengué + +=item * + +Ricardo Signes + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2006 by 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/src/main/perl/lib/Devel/OverloadInfo.pm b/src/main/perl/lib/Devel/OverloadInfo.pm new file mode 100644 index 000000000..45be645fe --- /dev/null +++ b/src/main/perl/lib/Devel/OverloadInfo.pm @@ -0,0 +1,309 @@ +package Devel::OverloadInfo; +$Devel::OverloadInfo::VERSION = '0.008'; +# ABSTRACT: introspect overloaded operators + +#pod =head1 DESCRIPTION +#pod +#pod Devel::OverloadInfo returns information about L +#pod operators for a given class (or object), including where in the +#pod inheritance hierarchy the overloads are declared and where the code +#pod implementing them is. +#pod +#pod =cut + +use strict; +use warnings; +use overload (); +use Scalar::Util qw(blessed); +use Package::Stash 0.14; +use MRO::Compat; + +BEGIN { + if (eval { require Sub::Util } && defined &Sub::Util::subname) { + *subname = \&Sub::Util::subname; + } + else { + require B; + *subname = sub { + my ($coderef) = @_; + die 'Not a subroutine reference' + unless ref $coderef; + my $cv = B::svref_2object($coderef); + die 'Not a subroutine reference' + unless $cv->isa('B::CV'); + my $gv = $cv->GV; + return undef + if $gv->isa('B::SPECIAL'); + my $stash = $gv->STASH; + my $package = $stash->isa('B::SPECIAL') ? '__ANON__' : $stash->NAME; + return $package . '::' . $gv->NAME; + }; + } +} + + +use Exporter 5.57 qw(import); +our @EXPORT_OK = qw(overload_info overload_op_info is_overloaded); + +sub stash_with_symbol { + my ($class, $symbol) = @_; + + for my $package (@{mro::get_linear_isa($class)}) { + my $stash = Package::Stash->new($package); + my $value_ref = $stash->get_symbol($symbol); + return ($stash, $value_ref) if $value_ref; + } + return; +} + +#pod =func is_overloaded +#pod +#pod if (is_overloaded($class_or_object)) { ... } +#pod +#pod Returns a boolean indicating whether the given class or object has any +#pod overloading declared. Note that a bare C with no +#pod actual operators counts as being overloaded. +#pod +#pod Equivalent to +#pod L, but +#pod doesn't trigger various bugs associated with it in versions of perl +#pod before 5.16. +#pod +#pod =cut + +sub is_overloaded { + my $class = blessed($_[0]) || $_[0]; + + # Perl before 5.16 seems to corrupt inherited overload info if + # there's a lone dereference overload and overload::Overloaded() + # is called before any object has been blessed into the class. + return !!("$]" >= 5.016 + ? overload::Overloaded($class) + : stash_with_symbol($class, '&()') + ); +} + +#pod =func overload_op_info +#pod +#pod my $info = overload_op_info($class_or_object, $op); +#pod +#pod Returns a hash reference with information about the specified +#pod overloaded operator of the named class or blessed object. +#pod +#pod Returns C if the operator is not overloaded. +#pod +#pod See L for the available operators. +#pod +#pod The keys in the returned hash are as follows: +#pod +#pod =over +#pod +#pod =item class +#pod +#pod The name of the class in which the operator overloading was declared. +#pod +#pod =item code +#pod +#pod A reference to the function implementing the overloaded operator. +#pod +#pod =item code_name +#pod +#pod The fully qualified name of the function implementing the overloaded operator. +#pod +#pod =item method_name (optional) +#pod +#pod The name of the method implementing the overloaded operator, if the +#pod overloading was specified as a named method, e.g. C<< use overload $op +#pod => 'method'; >>. +#pod +#pod =item code_class (optional) +#pod +#pod The name of the class in which the method specified by C +#pod was found. +#pod +#pod =item value (optional) +#pod +#pod For the special C key, the value it was given in C. +#pod +#pod =back +#pod +#pod =cut + +sub overload_op_info { + my ($class, $op) = @_; + $class = blessed($class) || $class; + + return undef unless is_overloaded($class); + my $op_method = $op eq 'fallback' ? "()" : "($op"; + my ($stash, $func) = stash_with_symbol($class, "&$op_method") + or return undef; + my $info = { + class => $stash->name, + }; + if ($func == \&overload::nil) { + # Named method or fallback, stored in the scalar slot + if (my $value_ref = $stash->get_symbol("\$$op_method")) { + my $value = $$value_ref; + if ($op eq 'fallback') { + $info->{value} = $value; + } else { + $info->{method_name} = $value; + if (my ($impl_stash, $impl_func) = stash_with_symbol($class, "&$value")) { + $info->{code_class} = $impl_stash->name; + $info->{code} = $impl_func; + } + } + } + } else { + $info->{code} = $func; + } + $info->{code_name} = subname($info->{code}) + if exists $info->{code}; + + return $info; +} + +#pod =func overload_info +#pod +#pod my $info = overload_info($class_or_object); +#pod +#pod Returns a hash reference with information about all the overloaded +#pod operators of specified class name or blessed object. The keys are the +#pod overloaded operators, as specified in C<%overload::ops> (see +#pod L), and the values are the hashes +#pod returned by L. +#pod +#pod =cut + +sub overload_info { + my $class = blessed($_[0]) || $_[0]; + + return {} unless is_overloaded($class); + + my (%overloaded); + for my $op (map split(/\s+/), values %overload::ops) { + my $info = overload_op_info($class, $op) + or next; + $overloaded{$op} = $info + } + return \%overloaded; +} + +#pod =head1 CAVEATS +#pod +#pod Whether the C key exists when it has its default value of +#pod C varies between perl versions: Before 5.18 it's there, in +#pod later versions it's not. +#pod +#pod =cut + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Devel::OverloadInfo - introspect overloaded operators + +=head1 VERSION + +version 0.008 + +=head1 DESCRIPTION + +Devel::OverloadInfo returns information about L +operators for a given class (or object), including where in the +inheritance hierarchy the overloads are declared and where the code +implementing them is. + +=head1 FUNCTIONS + +=head2 is_overloaded + + if (is_overloaded($class_or_object)) { ... } + +Returns a boolean indicating whether the given class or object has any +overloading declared. Note that a bare C with no +actual operators counts as being overloaded. + +Equivalent to +L, but +doesn't trigger various bugs associated with it in versions of perl +before 5.16. + +=head2 overload_op_info + + my $info = overload_op_info($class_or_object, $op); + +Returns a hash reference with information about the specified +overloaded operator of the named class or blessed object. + +Returns C if the operator is not overloaded. + +See L for the available operators. + +The keys in the returned hash are as follows: + +=over + +=item class + +The name of the class in which the operator overloading was declared. + +=item code + +A reference to the function implementing the overloaded operator. + +=item code_name + +The fully qualified name of the function implementing the overloaded operator. + +=item method_name (optional) + +The name of the method implementing the overloaded operator, if the +overloading was specified as a named method, e.g. C<< use overload $op +=> 'method'; >>. + +=item code_class (optional) + +The name of the class in which the method specified by C +was found. + +=item value (optional) + +For the special C key, the value it was given in C. + +=back + +=head2 overload_info + + my $info = overload_info($class_or_object); + +Returns a hash reference with information about all the overloaded +operators of specified class name or blessed object. The keys are the +overloaded operators, as specified in C<%overload::ops> (see +L), and the values are the hashes +returned by L. + +=head1 CAVEATS + +Whether the C key exists when it has its default value of +C varies between perl versions: Before 5.18 it's there, in +later versions it's not. + +=head1 AUTHOR + +Dagfinn Ilmari Mannsåker + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 by Dagfinn Ilmari Mannsåker. + +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/src/main/perl/lib/Devel/StackTrace.pm b/src/main/perl/lib/Devel/StackTrace.pm new file mode 100644 index 000000000..67fa362a5 --- /dev/null +++ b/src/main/perl/lib/Devel/StackTrace.pm @@ -0,0 +1,624 @@ +package Devel::StackTrace; + +use 5.006; + +use strict; +use warnings; + +our $VERSION = '2.05'; + +use Devel::StackTrace::Frame; +use File::Spec; +use Scalar::Util qw( blessed ); + +use overload + '""' => \&as_string, + bool => sub {1}, + fallback => 1; + +sub new { + my $class = shift; + my %p = @_; + + $p{unsafe_ref_capture} = !delete $p{no_refs} + if exists $p{no_refs}; + + my $self = bless { + index => undef, + frames => [], + raw => [], + %p, + }, $class; + + $self->_record_caller_data; + + return $self; +} + +sub _record_caller_data { + my $self = shift; + + my $filter = $self->{filter_frames_early} && $self->_make_frame_filter; + + # We exclude this method by starting at least one frame back. + my $x = 1 + ( $self->{skip_frames} || 0 ); + + while ( + my @c + = $self->{no_args} + ? caller( $x++ ) + : do { + ## no critic (Modules::ProhibitMultiplePackages, Variables::ProhibitPackageVars) + package # the newline keeps dzil from adding a version here + DB; + @DB::args = (); + caller( $x++ ); + } + ) { + + my @args; + + ## no critic (Variables::ProhibitPackageVars, BuiltinFunctions::ProhibitComplexMappings) + unless ( $self->{no_args} ) { + + # This is the same workaroud as was applied to Carp.pm a little + # while back + # (https://rt.perl.org/Public/Bug/Display.html?id=131046): + # + # Guard our serialization of the stack from stack refcounting + # bugs NOTE this is NOT a complete solution, we cannot 100% + # guard against these bugs. However in many cases Perl *is* + # capable of detecting them and throws an error when it + # does. Unfortunately serializing the arguments on the stack is + # a perfect way of finding these bugs, even when they would not + # affect normal program flow that did not poke around inside the + # stack. Inside of Carp.pm it makes little sense reporting these + # bugs, as Carp's job is to report the callers errors, not the + # ones it might happen to tickle while doing so. See: + # https://rt.perl.org/Public/Bug/Display.html?id=131046 and: + # https://rt.perl.org/Public/Bug/Display.html?id=52610 for more + # details and discussion. - Yves + @args = map { + my $arg; + local $@ = $@; + eval { + $arg = $_; + 1; + } or do { + $arg = '** argument not available anymore **'; + }; + $arg; + } @DB::args; + } + ## use critic + + my $raw = { + caller => \@c, + args => \@args, + }; + + next if $filter && !$filter->($raw); + + unless ( $self->{unsafe_ref_capture} ) { + $raw->{args} = [ map { ref $_ ? $self->_ref_to_string($_) : $_ } + @{ $raw->{args} } ]; + } + + push @{ $self->{raw} }, $raw; + } +} + +sub _ref_to_string { + my $self = shift; + my $ref = shift; + + return overload::AddrRef($ref) + if blessed $ref && $ref->isa('Exception::Class::Base'); + + return overload::AddrRef($ref) unless $self->{respect_overload}; + + ## no critic (Variables::RequireInitializationForLocalVars) + local $@; + local $SIG{__DIE__}; + ## use critic + + my $str = eval { $ref . q{} }; + + return $@ ? overload::AddrRef($ref) : $str; +} + +sub _make_frames { + my $self = shift; + + my $filter = !$self->{filter_frames_early} && $self->_make_frame_filter; + + my $raw = delete $self->{raw}; + for my $r ( @{$raw} ) { + next if $filter && !$filter->($r); + + $self->_add_frame( $r->{caller}, $r->{args} ); + } +} + +my $default_filter = sub {1}; + +sub _make_frame_filter { + my $self = shift; + + my ( @i_pack_re, %i_class ); + if ( $self->{ignore_package} ) { + ## no critic (Variables::RequireInitializationForLocalVars) + local $@; + local $SIG{__DIE__}; + ## use critic + + $self->{ignore_package} = [ $self->{ignore_package} ] + unless eval { @{ $self->{ignore_package} } }; + + @i_pack_re + = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} }; + } + + my $p = __PACKAGE__; + push @i_pack_re, qr/^\Q$p\E$/; + + if ( $self->{ignore_class} ) { + $self->{ignore_class} = [ $self->{ignore_class} ] + unless ref $self->{ignore_class}; + %i_class = map { $_ => 1 } @{ $self->{ignore_class} }; + } + + my $user_filter = $self->{frame_filter}; + + return sub { + return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re; + return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class; + + if ($user_filter) { + return $user_filter->( $_[0] ); + } + + return 1; + }; +} + +sub _add_frame { + my $self = shift; + my $c = shift; + my $p = shift; + + # eval and is_require are only returned when applicable under 5.00503. + push @$c, ( undef, undef ) if scalar @$c == 6; + + push @{ $self->{frames} }, + Devel::StackTrace::Frame->new( + $c, + $p, + $self->{respect_overload}, + $self->{max_arg_length}, + $self->{message}, + $self->{indent} + ); +} + +sub next_frame { + my $self = shift; + + # reset to top if necessary. + $self->{index} = -1 unless defined $self->{index}; + + my @f = $self->frames; + if ( defined $f[ $self->{index} + 1 ] ) { + return $f[ ++$self->{index} ]; + } + else { + $self->{index} = undef; + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + return undef; + } +} + +sub prev_frame { + my $self = shift; + + my @f = $self->frames; + + # reset to top if necessary. + $self->{index} = scalar @f unless defined $self->{index}; + + if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) { + return $f[ --$self->{index} ]; + } + else { + ## no critic (Subroutines::ProhibitExplicitReturnUndef) + $self->{index} = undef; + return undef; + } +} + +sub reset_pointer { + my $self = shift; + + $self->{index} = undef; + + return; +} + +sub frames { + my $self = shift; + + if (@_) { + die + "Devel::StackTrace->frames can only take Devel::StackTrace::Frame args\n" + if grep { !$_->isa('Devel::StackTrace::Frame') } @_; + + $self->{frames} = \@_; + delete $self->{raw}; + } + else { + $self->_make_frames if $self->{raw}; + } + + return @{ $self->{frames} }; +} + +sub frame { + my $self = shift; + my $i = shift; + + return unless defined $i; + + return ( $self->frames )[$i]; +} + +sub frame_count { + my $self = shift; + + return scalar( $self->frames ); +} + +sub message { $_[0]->{message} } + +sub as_string { + my $self = shift; + my $p = shift; + + my @frames = $self->frames; + if (@frames) { + my $st = q{}; + my $first = 1; + for my $f (@frames) { + $st .= $f->as_string( $first, $p ) . "\n"; + $first = 0; + } + + return $st; + } + + my $msg = $self->message; + return $msg if defined $msg; + + return 'Trace begun'; +} + +{ + ## no critic (Modules::ProhibitMultiplePackages, ClassHierarchies::ProhibitExplicitISA) + package # hide from PAUSE + Devel::StackTraceFrame; + + our @ISA = 'Devel::StackTrace::Frame'; +} + +1; + +# ABSTRACT: An object representing a stack trace + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Devel::StackTrace - An object representing a stack trace + +=head1 VERSION + +version 2.05 + +=head1 SYNOPSIS + + use Devel::StackTrace; + + my $trace = Devel::StackTrace->new; + + print $trace->as_string; # like carp + + # from top (most recent) of stack to bottom. + while ( my $frame = $trace->next_frame ) { + print "Has args\n" if $frame->hasargs; + } + + # from bottom (least recent) of stack to top. + while ( my $frame = $trace->prev_frame ) { + print "Sub: ", $frame->subroutine, "\n"; + } + +=head1 DESCRIPTION + +The C module contains two classes, C and +L. These objects encapsulate the information that can +retrieved via Perl's C function, as well as providing a simple +interface to this data. + +The C object contains a set of C +objects, one for each level of the stack. The frames contain all the data +available from C. + +This code was created to support my L class (part of +L) but may be useful in other contexts. + +=head1 'TOP' AND 'BOTTOM' OF THE STACK + +When describing the methods of the trace object, I use the words 'top' and +'bottom'. In this context, the 'top' frame on the stack is the most recent +frame and the 'bottom' is the least recent. + +Here's an example: + + foo(); # bottom frame is here + + sub foo { + bar(); + } + + sub bar { + Devel::StackTrace->new; # top frame is here. + } + +=head1 METHODS + +This class provide the following methods: + +=head2 Devel::StackTrace->new(%named_params) + +Returns a new Devel::StackTrace object. + +Takes the following parameters: + +=over 4 + +=item * frame_filter => $sub + +By default, Devel::StackTrace will include all stack frames before the call to +its constructor. + +However, you may want to filter out some frames with more granularity than +'ignore_package' or 'ignore_class' allow. + +You can provide a subroutine which is called with the raw frame data for each +frame. This is a hash reference with two keys, "caller", and "args", both of +which are array references. The "caller" key is the raw data as returned by +Perl's C function, and the "args" key are the subroutine arguments +found in C<@DB::args>. + +The filter should return true if the frame should be included, or false if it +should be skipped. + +=item * filter_frames_early => $boolean + +If this parameter is true, C will be called as soon as the +stacktrace is created, and before refs are stringified (if +C is not set), rather than being filtered lazily when +L objects are first needed. + +This is useful if you want to filter based on the frame's arguments and want to +be able to examine object properties, for example. + +=item * ignore_package => $package_name OR \@package_names + +Any frames where the package is one of these packages will not be on the stack. + +=item * ignore_class => $package_name OR \@package_names + +Any frames where the package is a subclass of one of these packages (or is the +same package) will not be on the stack. + +Devel::StackTrace internally adds itself to the 'ignore_package' parameter, +meaning that the Devel::StackTrace package is B ignored. However, if +you create a subclass of Devel::StackTrace it will not be ignored. + +=item * skip_frames => $integer + +This will cause this number of stack frames to be excluded from top of the +stack trace. This prevents the frames from being captured at all, and applies +before the C, C, or C options, even +with C. + +=item * unsafe_ref_capture => $boolean + +If this parameter is true, then Devel::StackTrace will store references +internally when generating stacktrace frames. + +B. Using this option will keep any objects or references alive past +their normal lifetime, until the stack trace object goes out of scope. It can +keep objects alive even after their C sub is called, resulting it it +being called multiple times on the same object. + +If not set, Devel::StackTrace replaces any references with their stringified +representation. + +=item * no_args => $boolean + +If this parameter is true, then Devel::StackTrace will not store caller +arguments in stack trace frames at all. + +=item * respect_overload => $boolean + +By default, Devel::StackTrace will call C to get the +underlying string representation of an object, instead of respecting the +object's stringification overloading. If you would prefer to see the overloaded +representation of objects in stack traces, then set this parameter to true. + +=item * max_arg_length => $integer + +By default, Devel::StackTrace will display the entire argument for each +subroutine call. Setting this parameter causes truncates each subroutine +argument's string representation if it is longer than this number of +characters. + +=item * message => $string + +By default, Devel::StackTrace will use 'Trace begun' as the message for the +first stack frame when you call C. You can supply an alternative +message using this option. + +=item * indent => $boolean + +If this parameter is true, each stack frame after the first will start with a +tab character, just like C. + +=back + +=head2 $trace->next_frame + +Returns the next L object on the stack, going down. +If this method hasn't been called before it returns the first frame. It returns +C when it reaches the bottom of the stack and then resets its pointer so +the next call to C<< $trace->next_frame >> or C<< $trace->prev_frame >> will +work properly. + +=head2 $trace->prev_frame + +Returns the next L object on the stack, going up. If +this method hasn't been called before it returns the last frame. It returns +undef when it reaches the top of the stack and then resets its pointer so the +next call to C<< $trace->next_frame >> or C<< $trace->prev_frame >> will work +properly. + +=head2 $trace->reset_pointer + +Resets the pointer so that the next call to C<< $trace->next_frame >> or C<< +$trace->prev_frame >> will start at the top or bottom of the stack, as +appropriate. + +=head2 $trace->frames + +When this method is called with no arguments, it returns a list of +L objects. They are returned in order from top (most +recent) to bottom. + +This method can also be used to set the object's frames if you pass it a list +of L objects. + +This is useful if you want to filter the list of frames in ways that are more +complex than can be handled by the C<< $trace->filter_frames >> method: + + $stacktrace->frames( my_filter( $stacktrace->frames ) ); + +=head2 $trace->frame($index) + +Given an index, this method returns the relevant frame, or undef if there is no +frame at that index. The index is exactly like a Perl array. The first frame is +0 and negative indexes are allowed. + +=head2 $trace->frame_count + +Returns the number of frames in the trace object. + +=head2 $trace->as_string(\%p) + +Calls C<< $frame->as_string >> on each frame from top to bottom, producing +output quite similar to the Carp module's cluck/confess methods. + +The optional C<\%p> parameter only has one option. The C +parameter truncates each subroutine argument's string representation if it is +longer than this number of characters. + +If all the frames in a trace are skipped then this just returns the C +passed to the constructor or the string C<"Trace begun">. + +=head2 $trace->message + +Returns the message passed to the constructor. If this wasn't passed then this +method returns C. + +=head1 SUPPORT + +Bugs may be submitted at L. + +=head1 SOURCE + +The source code repository for Devel-StackTrace can be found at L. + +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, please +consider making a "donation" to me via PayPal. I spend a lot of free time +creating free software, and would appreciate any support you'd care to offer. + +Please note that B in order for me +to continue working on this particular software. I will continue to do so, +inasmuch as I have in the past, for as long as it interests me. + +Similarly, a donation made in this way will probably not make me work on this +software much more, unless I get so many donations that I can consider working +on free software full time (let's all have a chuckle at that together). + +To donate, log into PayPal and send money to autarch@urth.org, or use the +button at L. + +=head1 AUTHOR + +Dave Rolsky + +=head1 CONTRIBUTORS + +=for stopwords Dagfinn Ilmari Mannsåker David Cantrell Graham Knop Ivan Bessarabov Mark Fowler Pali Ricardo Signes + +=over 4 + +=item * + +Dagfinn Ilmari Mannsåker + +=item * + +David Cantrell + +=item * + +Graham Knop + +=item * + +Ivan Bessarabov + +=item * + +Mark Fowler + +=item * + +Pali + +=item * + +Ricardo Signes + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2000 - 2024 by David Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +The full text of the license can be found in the +F file included with this distribution. + +=cut diff --git a/src/main/perl/lib/Devel/StackTrace/Frame.pm b/src/main/perl/lib/Devel/StackTrace/Frame.pm new file mode 100644 index 000000000..f7e8d3f9c --- /dev/null +++ b/src/main/perl/lib/Devel/StackTrace/Frame.pm @@ -0,0 +1,272 @@ +package Devel::StackTrace::Frame; + +use strict; +use warnings; + +our $VERSION = '2.05'; + +# Create accessor routines +BEGIN { + ## no critic (TestingAndDebugging::ProhibitNoStrict) + no strict 'refs'; + + my @attrs = qw( + package + filename + line + subroutine + hasargs + wantarray + evaltext + is_require + hints + bitmask + ); + + for my $attr (@attrs) { + *{$attr} = sub { my $s = shift; return $s->{$attr} }; + } +} + +{ + my @args = qw( + package + filename + line + subroutine + hasargs + wantarray + evaltext + is_require + hints + bitmask + ); + + sub new { + my $proto = shift; + my $class = ref $proto || $proto; + + my $self = bless {}, $class; + + @{$self}{@args} = @{ shift() }; + $self->{args} = shift; + $self->{respect_overload} = shift; + $self->{max_arg_length} = shift; + $self->{message} = shift; + $self->{indent} = shift; + + # fixup unix-style paths on win32 + $self->{filename} = File::Spec->canonpath( $self->{filename} ); + + return $self; + } +} + +sub args { + my $self = shift; + + return @{ $self->{args} }; +} + +sub as_string { + my $self = shift; + my $first = shift; + my $p = shift; + + my $sub = $self->subroutine; + + # This code stolen straight from Carp.pm and then tweaked. All + # errors are probably my fault -dave + if ($first) { + $sub + = defined $self->{message} + ? $self->{message} + : 'Trace begun'; + } + else { + + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" + if ( my $eval = $self->evaltext ) { + if ( $self->is_require ) { + $sub = "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + $sub = "eval '$eval'"; + } + } + elsif ( $sub eq '(eval)' ) { + $sub = 'eval {...}'; + } + + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string + # + # We copy them because they're going to be modified. + # + if ( my @a = $self->args ) { + for (@a) { + + # set args to the string "undef" if undefined + unless ( defined $_ ) { + $_ = 'undef'; + next; + } + + # hack! + ## no critic (Subroutines::ProtectPrivateSubs) + $_ = $self->Devel::StackTrace::_ref_to_string($_) + if ref $_; + ## use critic; + + ## no critic (Variables::RequireInitializationForLocalVars) + local $SIG{__DIE__}; + local $@; + ## use critic; + + ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval) + eval { + my $max_arg_length + = exists $p->{max_arg_length} + ? $p->{max_arg_length} + : $self->{max_arg_length}; + + if ( $max_arg_length + && length $_ > $max_arg_length ) { + ## no critic (BuiltinFunctions::ProhibitLvalueSubstr) + substr( $_, $max_arg_length ) = '...'; + } + + s/'/\\'/g; + + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + + # print control/high ASCII chars as 'M-' or '^' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + }; + ## use critic + + if ( my $e = $@ ) { + $_ = $e =~ /malformed utf-8/i ? '(bad utf-8)' : '?'; + } + } + + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join( ', ', @a ) . ')'; + $sub .= ' called'; + } + } + + # If the user opted into indentation (a la Carp::confess), pre-add a tab + my $tab = $self->{indent} && !$first ? "\t" : q{}; + + return "${tab}$sub at " . $self->filename . ' line ' . $self->line; +} + +1; + +# ABSTRACT: A single frame in a stack trace + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Devel::StackTrace::Frame - A single frame in a stack trace + +=head1 VERSION + +version 2.05 + +=head1 DESCRIPTION + +See L for details. + +=for Pod::Coverage new + +=head1 METHODS + +See Perl's C documentation for more information on what these methods +return. + +=head2 $frame->package + +The package which created this frame. + +=head2 $frame->filename + +The filename which created this frame. + +=head2 $frame->line + +The line where the frame was created. + +=head2 $frame->subroutine + +The subroutine which created this frame. + +=head2 $frame->hasargs + +This will be true if a new C<@_> was created for this this frame. + +=head2 $frame->wantarray + +This indicates the context for the call for this frame. This will be true if +called in array context, false in scalar context, and C in void context. + +=head2 $frame->evaltext + +Returns undef if the frame was not part of an eval. + +=head2 $frame->is_require + +Returns undef if the frame was not part of a require. + +=head2 $frame->args + +Returns the arguments passed to the frame. Note that any arguments that are +references are returned as references, not copies. + +=head2 $frame->hints + +Returns the value of C<$^H> for this frame. + +=head2 $frame->bitmask + +Returns the value of C<$bitmask> for this frame. + +=head2 $frame->as_string + +Returns a string containing a description of the frame. + +=head1 SUPPORT + +Bugs may be submitted at L. + +=head1 SOURCE + +The source code repository for Devel-StackTrace can be found at L. + +=head1 AUTHOR + +Dave Rolsky + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2000 - 2024 by David Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +The full text of the license can be found in the +F file included with this distribution. + +=cut diff --git a/src/main/perl/lib/Dist/CheckConflicts.pm b/src/main/perl/lib/Dist/CheckConflicts.pm new file mode 100644 index 000000000..8370a0119 --- /dev/null +++ b/src/main/perl/lib/Dist/CheckConflicts.pm @@ -0,0 +1,361 @@ +package Dist::CheckConflicts; +BEGIN { + $Dist::CheckConflicts::AUTHORITY = 'cpan:DOY'; +} +$Dist::CheckConflicts::VERSION = '0.11'; +use strict; +use warnings; +use 5.006; +# ABSTRACT: declare version conflicts for your dist + +use base 'Exporter'; +our @EXPORT = our @EXPORT_OK = ( + qw(conflicts check_conflicts calculate_conflicts dist) +); + +use Carp; +use Module::Runtime 0.009 'module_notional_filename', 'require_module'; + + +my %CONFLICTS; +my %HAS_CONFLICTS; +my %DISTS; + +sub import { + my $pkg = shift; + my $for = caller; + + my ($conflicts, $alsos, $dist); + ($conflicts, @_) = _strip_opt('-conflicts' => @_); + ($alsos, @_) = _strip_opt('-also' => @_); + ($dist, @_) = _strip_opt('-dist' => @_); + + my %conflicts = %{ $conflicts || {} }; + for my $also (@{ $alsos || [] }) { + eval { require_module($also) } or next; + if (!exists $CONFLICTS{$also}) { + $also .= '::Conflicts'; + eval { require_module($also) } or next; + } + if (!exists $CONFLICTS{$also}) { + next; + } + my %also_confs = $also->conflicts; + for my $also_conf (keys %also_confs) { + $conflicts{$also_conf} = $also_confs{$also_conf} + if !exists $conflicts{$also_conf} + || $conflicts{$also_conf} lt $also_confs{$also_conf}; + } + } + + $CONFLICTS{$for} = \%conflicts; + $DISTS{$for} = $dist || $for; + + if (grep { $_ eq ':runtime' } @_) { + for my $conflict (keys %conflicts) { + $HAS_CONFLICTS{$conflict} ||= []; + push @{ $HAS_CONFLICTS{$conflict} }, $for; + } + + # warn for already loaded things... + for my $conflict (keys %conflicts) { + if (exists $INC{module_notional_filename($conflict)}) { + _check_version([$for], $conflict); + } + } + + # and warn for subsequently loaded things... + @INC = grep { + !(ref($_) eq 'ARRAY' && @$_ > 1 && $_->[1] == \%CONFLICTS) + } @INC; + unshift @INC, [ + sub { + my ($sub, $file) = @_; + + (my $mod = $file) =~ s{\.pm$}{}; + $mod =~ s{/}{::}g; + return unless $mod =~ /[\w:]+/; + + return unless defined $HAS_CONFLICTS{$mod}; + + { + local $HAS_CONFLICTS{$mod}; + require $file; + } + + _check_version($HAS_CONFLICTS{$mod}, $mod); + + # the previous require already handled it + my $called; + return sub { + return 0 if $called; + $_ = "1;"; + $called = 1; + return 1; + }; + }, + \%CONFLICTS, # arbitrary but unique, see above + ]; + } + + $pkg->export_to_level(1, @_); +} + +sub _strip_opt { + my ($opt, @args) = @_; + + my $val; + for my $idx ( 0 .. $#args - 1 ) { + if (defined $args[$idx] && $args[$idx] eq $opt) { + $val = (splice @args, $idx, 2)[1]; + last; + } + } + + return ( $val, @args ); +} + +sub _check_version { + my ($fors, $mod) = @_; + + for my $for (@$fors) { + my $conflict_ver = $CONFLICTS{$for}{$mod}; + my $version = do { + no strict 'refs'; + ${ ${ $mod . '::' }{VERSION} }; + }; + + if ($version le $conflict_ver) { + warn <dist; + my @conflicts = $package->calculate_conflicts; + return unless @conflicts; + + my $err = "Conflicts detected for $dist:\n"; + for my $conflict (@conflicts) { + $err .= " $conflict->{package} is version " + . "$conflict->{installed}, but must be greater than version " + . "$conflict->{required}\n"; + } + die $err; +} + + +sub calculate_conflicts { + my $package = shift; + my %conflicts = $package->conflicts; + + my @ret; + + + CONFLICT: + for my $conflict (keys %conflicts) { + my $success = do { + local $SIG{__WARN__} = sub {}; + eval { require_module($conflict) }; + }; + my $error = $@; + my $file = module_notional_filename($conflict); + next if not $success and $error =~ /Can't locate \Q$file\E in \@INC/; + + warn "Warning: $conflict did not compile" if not $success; + my $installed = $success ? $conflict->VERSION : 'unknown'; + push @ret, { + package => $conflict, + installed => $installed, + required => $conflicts{$conflict}, + } if not $success or $installed le $conflicts{$conflict}; + } + + return sort { $a->{package} cmp $b->{package} } @ret; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Dist::CheckConflicts - declare version conflicts for your dist + +=head1 VERSION + +version 0.11 + +=head1 SYNOPSIS + + use Dist::CheckConflicts + -dist => 'Class-MOP', + -conflicts => { + 'Moose' => '1.14', + 'namespace::autoclean' => '0.08', + }, + -also => [ + 'Package::Stash::Conflicts', + ]; + + __PACKAGE__->check_conflicts; + +=head1 DESCRIPTION + +One shortcoming of the CPAN clients that currently exist is that they have no +way of specifying conflicting downstream dependencies of modules. This module +attempts to work around this issue by allowing you to specify conflicting +versions of modules separately, and deal with them after the module is done +installing. + +For instance, say you have a module C, and some other module C uses +C. If C were to change its API in a non-backwards-compatible way, +this would cause C to break until it is updated to use the new API. C +can't just depend on the fixed version of C, because this will cause a +circular dependency (because C is already depending on C), and this +doesn't express intent properly anyway - C doesn't use C at all. The +ideal solution would be for there to be a way to specify conflicting versions +of modules in a way that would let CPAN clients update conflicting modules +automatically after an existing module is upgraded, but until that happens, +this module will allow users to do this manually. + +This module accepts a hash of options passed to its C statement, with +these keys being valid: + +=over 4 + +=item -conflicts + +A hashref of conflict specifications, where keys are module names, and values +are the last broken version - any version greater than the specified version +should work. + +=item -also + +Additional modules to get conflicts from (potentially recursively). This should +generally be a list of modules which use Dist::CheckConflicts, which correspond +to the dists that your dist depends on. (In an ideal world, this would be +intuited directly from your dependency list, but the dependency list isn't +available outside of build time). + +=item -dist + +The name of the distribution, to make the error message from check_conflicts +more user-friendly. + +=back + +The methods listed below are exported by this module into the module that uses +it, so you should call these methods on your module, not Dist::CheckConflicts. + +As an example, this command line can be used to update your modules, after +installing the C dist (assuming that C is the module in +the C dist which uses Dist::CheckConflicts): + + perl -MFoo::Conflicts -e'print "$_\n" + for map { $_->{package} } Foo::Conflicts->calculate_conflicts' | cpanm + +As an added bonus, loading your conflicts module will provide warnings at +runtime if conflicting modules are detected (regardless of whether they are +loaded before or afterwards). + +=head1 METHODS + +=head2 conflicts + +Returns the conflict specification (the C<-conflicts> parameter to +C), as a hash. + +=head2 dist + +Returns the dist name (either as specified by the C<-dist> parameter to +C, or the package name which Cd this module). + +=head2 check_conflicts + +Examine the modules that are currently installed, and throw an exception with +useful information if any modules are at versions which conflict with the dist. + +=head2 calculate_conflicts + +Examine the modules that are currently installed, and return a list of modules +which conflict with the dist. The modules will be returned as a list of +hashrefs, each containing C, C, and C keys. + +=head1 BUGS + +No known bugs. + +Please report any bugs to GitHub Issues at +L. + +=head1 SEE ALSO + +L + +L + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Dist::CheckConflicts + +You can also look for information at: + +=over 4 + +=item * MetaCPAN + +L + +=item * Github + +L + +=item * RT: CPAN's request tracker + +L + +=item * CPAN Ratings + +L + +=back + +=head1 AUTHOR + +Jesse Luehrs + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 by Jesse Luehrs. + +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/src/main/perl/lib/Eval/Closure.pm b/src/main/perl/lib/Eval/Closure.pm new file mode 100644 index 000000000..fc41646cc --- /dev/null +++ b/src/main/perl/lib/Eval/Closure.pm @@ -0,0 +1,379 @@ +package Eval::Closure; +BEGIN { + $Eval::Closure::AUTHORITY = 'cpan:DOY'; +} +$Eval::Closure::VERSION = '0.14'; +use strict; +use warnings; +# ABSTRACT: safely and cleanly create closures via string eval + +use Exporter 'import'; +@Eval::Closure::EXPORT = @Eval::Closure::EXPORT_OK = 'eval_closure'; + +use Carp; +use overload (); +use Scalar::Util qw(reftype); + +use constant HAS_LEXICAL_SUBS => $] >= 5.018; + + + +sub eval_closure { + my (%args) = @_; + + # default to copying environment + $args{alias} = 0 if !exists $args{alias}; + + $args{source} = _canonicalize_source($args{source}); + _validate_env($args{environment} ||= {}); + + $args{source} = _line_directive(@args{qw(line description)}) + . $args{source} + if defined $args{description} && !($^P & 0x10); + + my ($code, $e) = _clean_eval_closure(@args{qw(source environment alias)}); + + if (!$code) { + if ($args{terse_error}) { + die "$e\n"; + } + else { + croak("Failed to compile source: $e\n\nsource:\n$args{source}") + } + } + + return $code; +} + +sub _canonicalize_source { + my ($source) = @_; + + if (defined($source)) { + if (ref($source)) { + if (reftype($source) eq 'ARRAY' + || overload::Method($source, '@{}')) { + return join "\n", @$source; + } + elsif (overload::Method($source, '""')) { + return "$source"; + } + else { + croak("The 'source' parameter to eval_closure must be a " + . "string or array reference"); + } + } + else { + return $source; + } + } + else { + croak("The 'source' parameter to eval_closure is required"); + } +} + +sub _validate_env { + my ($env) = @_; + + croak("The 'environment' parameter must be a hashref") + unless reftype($env) eq 'HASH'; + + for my $var (keys %$env) { + if (HAS_LEXICAL_SUBS) { + croak("Environment key '$var' should start with \@, \%, \$, or \&") + if index('$@%&', substr($var, 0, 1)) < 0; + } + else { + croak("Environment key '$var' should start with \@, \%, or \$") + if index('$@%', substr($var, 0, 1)) < 0; + } + croak("Environment values must be references, not $env->{$var}") + unless ref($env->{$var}); + } +} + +sub _line_directive { + my ($line, $description) = @_; + + $line = 1 unless defined($line); + + return qq{#line $line "$description"\n}; +} + +sub _clean_eval_closure { + my ($source, $captures, $alias) = @_; + + my @capture_keys = keys %$captures; + + if ($ENV{EVAL_CLOSURE_PRINT_SOURCE}) { + _dump_source(_make_compiler_source($source, $alias, @capture_keys)); + } + + my ($compiler, $e) = _make_compiler($source, $alias, @capture_keys); + return (undef, $e) unless defined $compiler; + + my $code = $compiler->(@$captures{@capture_keys}); + + if (!defined $code) { + return ( + undef, + "The 'source' parameter must return a subroutine reference, " + . "not undef" + ) + } + if (!ref($code) || ref($code) ne 'CODE') { + return ( + undef, + "The 'source' parameter must return a subroutine reference, not " + . ref($code) + ) + } + + if ($alias) { + require Devel::LexAlias; + Devel::LexAlias::lexalias($code, $_, $captures->{$_}) + for grep substr($_, 0, 1) ne '&', @capture_keys; + } + + return ($code, $e); +} + +sub _make_compiler { + my $source = _make_compiler_source(@_); + + _clean_eval($source) +} + +sub _clean_eval { + local $@; + local $SIG{__DIE__}; + my $compiler = eval $_[0]; + my $e = $@; + ( $compiler, $e ) +} + +$Eval::Closure::SANDBOX_ID = 0; + +sub _make_compiler_source { + my ($source, $alias, @capture_keys) = @_; + $Eval::Closure::SANDBOX_ID++; + my $i = 0; + return join "\n", ( + "package Eval::Closure::Sandbox_$Eval::Closure::SANDBOX_ID;", + 'sub {', + (map { _make_lexical_assignment($_, $i++, $alias) } @capture_keys), + $source, + '}', + ); +} + +sub _make_lexical_assignment { + my ($key, $index, $alias) = @_; + my $sigil = substr($key, 0, 1); + my $name = substr($key, 1); + if (HAS_LEXICAL_SUBS && $sigil eq '&') { + my $tmpname = '$__' . $name . '__' . $index; + return 'use feature "lexical_subs"; ' + . 'no warnings "experimental::lexical_subs"; ' + . 'my ' . $tmpname . ' = $_[' . $index . ']; ' + . 'my sub ' . $name . ' { goto ' . $tmpname . ' }'; + } + if ($alias) { + return 'my ' . $key . ';'; + } + else { + return 'my ' . $key . ' = ' . $sigil . '{$_[' . $index . ']};'; + } +} + +sub _dump_source { + my ($source) = @_; + + my $output; + local $@; + if (eval { require Perl::Tidy; 1 }) { + Perl::Tidy::perltidy( + source => \$source, + destination => \$output, + argv => [], + ); + } + else { + $output = $source; + } + + warn "$output\n"; +} + + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Eval::Closure - safely and cleanly create closures via string eval + +=head1 VERSION + +version 0.14 + +=head1 SYNOPSIS + + use Eval::Closure; + + my $code = eval_closure( + source => 'sub { $foo++ }', + environment => { + '$foo' => \1, + }, + ); + + warn $code->(); # 1 + warn $code->(); # 2 + + my $code2 = eval_closure( + source => 'sub { $code->() }', + ); # dies, $code isn't in scope + +=head1 DESCRIPTION + +String eval is often used for dynamic code generation. For instance, C +uses it heavily, to generate inlined versions of accessors and constructors, +which speeds code up at runtime by a significant amount. String eval is not +without its issues however - it's difficult to control the scope it's used in +(which determines which variables are in scope inside the eval), and it's easy +to miss compilation errors, since eval catches them and sticks them in $@ +instead. + +This module attempts to solve these problems. It provides an C +function, which evals a string in a clean environment, other than a fixed list +of specified variables. Compilation errors are rethrown automatically. + +=head1 FUNCTIONS + +=head2 eval_closure(%args) + +This function provides the main functionality of this module. It is exported by +default. It takes a hash of parameters, with these keys being valid: + +=over 4 + +=item source + +The string to be evaled. It should end by returning a code reference. It can +access any variable declared in the C parameter (and only those +variables). It can be either a string, or an arrayref of lines (which will be +joined with newlines to produce the string). + +=item environment + +The environment to provide to the eval. This should be a hashref, mapping +variable names (including sigils) to references of the appropriate type. For +instance, a valid value for environment would be C<< { '@foo' => [] } >> (which +would allow the generated function to use an array named C<@foo>). Generally, +this is used to allow the generated function to access externally defined +variables (so you would pass in a reference to a variable that already exists). + +In perl 5.18 and greater, the environment hash can contain variables with a +sigil of C<&>. This will create a lexical sub in the evaluated code (see +L). Using a C<&> sigil on perl versions +before lexical subs were available will throw an error. + +=item alias + +If set to true, the coderef returned closes over the variables referenced in +the environment hashref. (This feature requires L.) If set to +false, the coderef closes over a I<< shallow copy >> of the variables. + +If this argument is omitted, Eval::Closure will currently assume false, but +this assumption may change in a future version. + +=item description + +This lets you provide a bit more information in backtraces. Normally, when a +function that was generated through string eval is called, that stack frame +will show up as "(eval n)", where 'n' is a sequential identifier for every +string eval that has happened so far in the program. Passing a C +parameter lets you override that to something more useful (for instance, +L overrides the description for accessors to something like "accessor +foo at MyClass.pm, line 123"). + +=item line + +This lets you override the particular line number that appears in backtraces, +much like the C option. The default is 1. + +=item terse_error + +Normally, this function appends the source code that failed to compile, and +prepends some explanatory text. Setting this option to true suppresses that +behavior so you get only the compilation error that Perl actually reported. + +=back + +=head1 BUGS + +No known bugs. + +Please report any bugs to GitHub Issues at +L. + +=head1 SEE ALSO + +=over 4 + +=item * L + +This module is a factoring out of code that used to live here + +=back + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Eval::Closure + +You can also look for information at: + +=over 4 + +=item * MetaCPAN + +L + +=item * Github + +L + +=item * RT: CPAN's request tracker + +L + +=item * CPAN Ratings + +L + +=back + +=head1 NOTES + +Based on code from L, by Stevan Little and the +Moose Cabal. + +=head1 AUTHOR + +Jesse Luehrs + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2016 by Jesse Luehrs. + +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/src/main/perl/lib/MRO/Compat.pm b/src/main/perl/lib/MRO/Compat.pm new file mode 100644 index 000000000..3e6dd74ee --- /dev/null +++ b/src/main/perl/lib/MRO/Compat.pm @@ -0,0 +1,407 @@ +package MRO::Compat; +use strict; +use warnings; +require 5.006_000; + +# Keep this < 1.00, so people can tell the fake +# mro.pm from the real one +our $VERSION = '0.15'; + +BEGIN { + # Alias our private functions over to + # the mro:: namespace and load + # Class::C3 if Perl < 5.9.5 + if($] < 5.009_005) { + $mro::VERSION # to fool Module::Install when generating META.yml + = $VERSION; + $INC{'mro.pm'} = __FILE__; + *mro::import = \&__import; + *mro::get_linear_isa = \&__get_linear_isa; + *mro::set_mro = \&__set_mro; + *mro::get_mro = \&__get_mro; + *mro::get_isarev = \&__get_isarev; + *mro::is_universal = \&__is_universal; + *mro::method_changed_in = \&__method_changed_in; + *mro::invalidate_all_method_caches + = \&__invalidate_all_method_caches; + require Class::C3; + if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) { + *mro::get_pkg_gen = \&__get_pkg_gen_c3xs; + } + else { + *mro::get_pkg_gen = \&__get_pkg_gen_pp; + } + } + + # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+ + else { + require mro; + no warnings 'redefine'; + *Class::C3::initialize = sub { 1 }; + *Class::C3::reinitialize = sub { 1 }; + *Class::C3::uninitialize = sub { 1 }; + } +} + +=head1 NAME + +MRO::Compat - mro::* interface compatibility for Perls < 5.9.5 + +=head1 SYNOPSIS + + package PPP; use base qw/Exporter/; + package X; use base qw/PPP/; + package Y; use base qw/PPP/; + package Z; use base qw/PPP/; + + package FooClass; use base qw/X Y Z/; + + package main; + use MRO::Compat; + my $linear = mro::get_linear_isa('FooClass'); + print join(q{, }, @$linear); + + # Prints: FooClass, X, PPP, Exporter, Y, Z + +=head1 DESCRIPTION + +The "mro" namespace provides several utilities for dealing +with method resolution order and method caching in general +in Perl 5.9.5 and higher. + +This module provides those interfaces for +earlier versions of Perl (back to 5.6.0 anyways). + +It is a harmless no-op to use this module on 5.9.5+. That +is to say, code which properly uses L will work +unmodified on both older Perls and 5.9.5+. + +If you're writing a piece of software that would like to use +the parts of 5.9.5+'s mro:: interfaces that are supported +here, and you want compatibility with older Perls, this +is the module for you. + +Some parts of this code will work better and/or faster with +L installed (which is an optional prereq +of L, which is in turn a prereq of this +package), but it's not a requirement. + +This module never exports any functions. All calls must +be fully qualified with the C prefix. + +The interface documentation here serves only as a quick +reference of what the function basically does, and what +differences between L and 5.9.5+ one should +look out for. The main docs in 5.9.5's L are the real +interface docs, and contain a lot of other useful information. + +=head1 Functions + +=head2 mro::get_linear_isa($classname[, $type]) + +Returns an arrayref which is the linearized "ISA" of the given class. +Uses whichever MRO is currently in effect for that class by default, +or the given MRO (either C or C if specified as C<$type>). + +The linearized ISA of a class is a single ordered list of all of the +classes that would be visited in the process of resolving a method +on the given class, starting with itself. It does not include any +duplicate entries. + +Note that C (and any members of C's MRO) are not +part of the MRO of a class, even though all classes implicitly inherit +methods from C and its parents. + +=cut + +sub __get_linear_isa_dfs { + my @check = shift; + my @lin; + + my %found; + while (defined(my $check = shift @check)) { + push @lin, $check; + no strict 'refs'; + unshift @check, grep !$found{$_}++, @{"$check\::ISA"}; + } + + return \@lin; +} + +sub __get_linear_isa ($;$) { + my ($classname, $type) = @_; + die "mro::get_mro requires a classname" if !defined $classname; + + $type ||= __get_mro($classname); + if($type eq 'dfs') { + return __get_linear_isa_dfs($classname); + } + elsif($type eq 'c3') { + return [Class::C3::calculateMRO($classname)]; + } + die "type argument must be 'dfs' or 'c3'"; +} + +=head2 mro::import + +This allows the C and +C syntaxes, providing you +C first. Please see the +L section for additional details. + +=cut + +sub __import { + if($_[1]) { + goto &Class::C3::import if $_[1] eq 'c3'; + __set_mro(scalar(caller), $_[1]); + } +} + +=head2 mro::set_mro($classname, $type) + +Sets the mro of C<$classname> to one of the types +C or C. Please see the L +section for additional details. + +=cut + +sub __set_mro ($$) { + my ($classname, $type) = @_; + + if(!defined $classname || !$type) { + die q{Usage: mro::set_mro($classname, $type)}; + } + + if($type eq 'c3') { + eval "package $classname; use Class::C3"; + die $@ if $@; + } + elsif($type eq 'dfs') { + # In the dfs case, check whether we need to undo C3 + if(defined $Class::C3::MRO{$classname}) { + Class::C3::_remove_method_dispatch_table($classname); + } + delete $Class::C3::MRO{$classname}; + } + else { + die qq{Invalid mro type "$type"}; + } + + return; +} + +=head2 mro::get_mro($classname) + +Returns the MRO of the given class (either C or C). + +It considers any Class::C3-using class to have C3 MRO +even before L is called. + +=cut + +sub __get_mro ($) { + my $classname = shift; + die "mro::get_mro requires a classname" if !defined $classname; + return 'c3' if exists $Class::C3::MRO{$classname}; + return 'dfs'; +} + +=head2 mro::get_isarev($classname) + +Returns an arrayref of classes who are subclasses of the +given classname. In other words, classes in whose @ISA +hierarchy we appear, no matter how indirectly. + +This is much slower on pre-5.9.5 Perls with MRO::Compat +than it is on 5.9.5+, as it has to search the entire +package namespace. + +=cut + +sub __get_all_pkgs_with_isas { + no strict 'refs'; + no warnings 'recursion'; + + my @retval; + + my $search = shift; + my $pfx; + my $isa; + if(defined $search) { + $isa = \@{"$search\::ISA"}; + $pfx = "$search\::"; + } + else { + $search = 'main'; + $isa = \@main::ISA; + $pfx = ''; + } + + push(@retval, $search) if scalar(@$isa); + + foreach my $cand (keys %{"$search\::"}) { + if($cand =~ s/::$//) { + next if $cand eq $search; # skip self-reference (main?) + push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)}); + } + } + + return \@retval; +} + +sub __get_isarev_recurse { + no strict 'refs'; + + my ($class, $all_isas, $level) = @_; + + die "Recursive inheritance detected" if $level > 100; + + my %retval; + + foreach my $cand (@$all_isas) { + my $found_me; + foreach (@{"$cand\::ISA"}) { + if($_ eq $class) { + $found_me = 1; + last; + } + } + if($found_me) { + $retval{$cand} = 1; + map { $retval{$_} = 1 } + @{__get_isarev_recurse($cand, $all_isas, $level+1)}; + } + } + return [keys %retval]; +} + +sub __get_isarev ($) { + my $classname = shift; + die "mro::get_isarev requires a classname" if !defined $classname; + + __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0); +} + +=head2 mro::is_universal($classname) + +Returns a boolean status indicating whether or not +the given classname is either C itself, +or one of C's parents by C<@ISA> inheritance. + +Any class for which this function returns true is +"universal" in the sense that all classes potentially +inherit methods from it. + +=cut + +sub __is_universal ($) { + my $classname = shift; + die "mro::is_universal requires a classname" if !defined $classname; + + my $lin = __get_linear_isa('UNIVERSAL'); + foreach (@$lin) { + return 1 if $classname eq $_; + } + + return 0; +} + +=head2 mro::invalidate_all_method_caches + +Increments C, which invalidates method +caching in all packages. + +Please note that this is rarely necessary, unless you are +dealing with a situation which is known to confuse Perl's +method caching. + +=cut + +sub __invalidate_all_method_caches () { + # Super secret mystery code :) + @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA; + return; +} + +=head2 mro::method_changed_in($classname) + +Invalidates the method cache of any classes dependent on the +given class. In L on pre-5.9.5 Perls, this is +an alias for C above, as +pre-5.9.5 Perls have no other way to do this. It will still +enforce the requirement that you pass it a classname, for +compatibility. + +Please note that this is rarely necessary, unless you are +dealing with a situation which is known to confuse Perl's +method caching. + +=cut + +sub __method_changed_in ($) { + my $classname = shift; + die "mro::method_changed_in requires a classname" if !defined $classname; + + __invalidate_all_method_caches(); +} + +=head2 mro::get_pkg_gen($classname) + +Returns an integer which is incremented every time a local +method of or the C<@ISA> of the given package changes on +Perl 5.9.5+. On earlier Perls with this L module, +it will probably increment a lot more often than necessary. + +=cut + +{ + my $__pkg_gen = 2; + sub __get_pkg_gen_pp ($) { + my $classname = shift; + die "mro::get_pkg_gen requires a classname" if !defined $classname; + return $__pkg_gen++; + } +} + +sub __get_pkg_gen_c3xs ($) { + my $classname = shift; + die "mro::get_pkg_gen requires a classname" if !defined $classname; + + return Class::C3::XS::_plsubgen(); +} + +=head1 USING C3 + +While this module makes the 5.9.5+ syntaxes +C and C available +on older Perls, it does so merely by passing off the work +to L. + +It does not remove the need for you to call +C, C, and/or +C at the appropriate times +as documented in the L docs. These three functions +are always provided by L, either via L +itself on older Perls, or directly as no-ops on 5.9.5+. + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Brandon L. Black, Eblblack@gmail.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2008 Brandon L. Black Eblblack@gmail.comE + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/src/main/perl/lib/Module/Implementation.pm b/src/main/perl/lib/Module/Implementation.pm new file mode 100644 index 000000000..0cdc3b5bd --- /dev/null +++ b/src/main/perl/lib/Module/Implementation.pm @@ -0,0 +1,290 @@ +package Module::Implementation; +# git description: v0.08-2-gd599347 +$Module::Implementation::VERSION = '0.09'; + +use strict; +use warnings; + +use Module::Runtime 0.012 qw( require_module ); +use Try::Tiny; + +# This is needed for the benefit of Test::CleanNamespaces, which in turn loads +# Package::Stash, which in turn loads this module and expects a minimum +# version. +unless ( exists $Module::Implementation::{VERSION} + && ${ $Module::Implementation::{VERSION} } ) { + + $Module::Implementation::{VERSION} = \42; +} + +my %Implementation; + +sub build_loader_sub { + my $caller = caller(); + + return _build_loader( $caller, @_ ); +} + +sub _build_loader { + my $package = shift; + my %args = @_; + + my @implementations = @{ $args{implementations} }; + my @symbols = @{ $args{symbols} || [] }; + + my $implementation; + my $env_var = uc $package; + $env_var =~ s/::/_/g; + $env_var .= '_IMPLEMENTATION'; + + return sub { + my ( $implementation, $loaded ) = _load_implementation( + $package, + $ENV{$env_var}, + \@implementations, + ); + + $Implementation{$package} = $implementation; + + _copy_symbols( $loaded, $package, \@symbols ); + + return $loaded; + }; +} + +sub implementation_for { + my $package = shift; + + return $Implementation{$package}; +} + +sub _load_implementation { + my $package = shift; + my $env_value = shift; + my $implementations = shift; + + if ($env_value) { + die "$env_value is not a valid implementation for $package" + unless grep { $_ eq $env_value } @{$implementations}; + + my $requested = "${package}::$env_value"; + + # Values from the %ENV hash are tainted. We know it's safe to untaint + # this value because the value was one of our known implementations. + ($requested) = $requested =~ /^(.+)$/; + + try { + require_module($requested); + } + catch { + require Carp; + Carp::croak("Could not load $requested: $_"); + }; + + return ( $env_value, $requested ); + } + else { + my $err; + for my $possible ( @{$implementations} ) { + my $try = "${package}::$possible"; + + my $ok; + try { + require_module($try); + $ok = 1; + } + catch { + $err .= $_ if defined $_; + }; + + return ( $possible, $try ) if $ok; + } + + require Carp; + if ( defined $err && length $err ) { + Carp::croak( + "Could not find a suitable $package implementation: $err"); + } + else { + Carp::croak( + 'Module::Runtime failed to load a module but did not throw a real error. This should never happen. Something is very broken' + ); + } + } +} + +sub _copy_symbols { + my $from_package = shift; + my $to_package = shift; + my $symbols = shift; + + for my $sym ( @{$symbols} ) { + my $type = $sym =~ s/^([\$\@\%\&\*])// ? $1 : '&'; + + my $from = "${from_package}::$sym"; + my $to = "${to_package}::$sym"; + + { + no strict 'refs'; + no warnings 'once'; + + # Copied from Exporter + *{$to} + = $type eq '&' ? \&{$from} + : $type eq '$' ? \${$from} + : $type eq '@' ? \@{$from} + : $type eq '%' ? \%{$from} + : $type eq '*' ? *{$from} + : die + "Can't copy symbol from $from_package to $to_package: $type$sym"; + } + } +} + +1; + +# ABSTRACT: Loads one of several alternate underlying implementations for a module + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Module::Implementation - Loads one of several alternate underlying implementations for a module + +=head1 VERSION + +version 0.09 + +=head1 SYNOPSIS + + package Foo::Bar; + + use Module::Implementation; + + BEGIN { + my $loader = Module::Implementation::build_loader_sub( + implementations => [ 'XS', 'PurePerl' ], + symbols => [ 'run', 'check' ], + ); + + $loader->(); + } + + package Consumer; + + # loads the first viable implementation + use Foo::Bar; + +=head1 DESCRIPTION + +This module abstracts out the process of choosing one of several underlying +implementations for a module. This can be used to provide XS and pure Perl +implementations of a module, or it could be used to load an implementation for +a given OS or any other case of needing to provide multiple implementations. + +This module is only useful when you know all the implementations ahead of +time. If you want to load arbitrary implementations then you probably want +something like a plugin system, not this module. + +=head1 API + +This module provides two subroutines, neither of which are exported. + +=head2 Module::Implementation::build_loader_sub(...) + +This subroutine takes the following arguments. + +=over 4 + +=item * implementations + +This should be an array reference of implementation names. Each name should +correspond to a module in the caller's namespace. + +In other words, using the example in the L, this module will look +for the C and C modules. + +This argument is required. + +=item * symbols + +A list of symbols to copy from the implementation package to the calling +package. + +These can be prefixed with a variable type: C<$>, C<@>, C<%>, C<&>, or +C<*)>. If no prefix is given, the symbol is assumed to be a subroutine. + +This argument is optional. + +=back + +This subroutine I the implementation loader as a sub reference. + +It is up to you to call this loader sub in your code. + +I recommend that you I call this loader in an C sub. If a +caller explicitly requests no imports, your C sub will not be run at +all, which can cause weird breakage. + +=head2 Module::Implementation::implementation_for($package) + +Given a package name, this subroutine returns the implementation that was +loaded for the package. This is not a full package name, just the suffix that +identifies the implementation. For the L example, this subroutine +would be called as C, +and it would return "XS" or "PurePerl". + +=head1 HOW THE IMPLEMENTATION LOADER WORKS + +The implementation loader works like this ... + +First, it checks for an C<%ENV> var specifying the implementation to load. The +env var is based on the package name which loads the implementations. The +C<::> package separator is replaced with C<_>, and made entirely +upper-case. Finally, we append "_IMPLEMENTATION" to this name. + +So in our L example, the corresponding C<%ENV> key would be +C. + +If this is set, then the loader will B try to load this one +implementation. + +If the env var requests an implementation which doesn't match one of the +implementations specified when the loader was created, an error is thrown. + +If this one implementation fails to load then loader throws an error. This is +useful for testing. You can request a specific implementation in a test file +by writing something like this: + + BEGIN { $ENV{FOO_BAR_IMPLEMENTATION} = 'XS' } + use Foo::Bar; + +If the environment variable is I set, then the loader simply tries the +implementations originally passed to C. The +implementations are tried in the order in which they were originally passed. + +The loader will use the first implementation that loads without an error. It +will copy any requested symbols from this implementation. + +If none of the implementations can be loaded, then the loader throws an +exception. + +The loader returns the name of the package it loaded. + +=head1 AUTHOR + +Dave Rolsky + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2014 by Dave Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +=cut diff --git a/src/main/perl/lib/Module/Runtime.pm b/src/main/perl/lib/Module/Runtime.pm new file mode 100644 index 000000000..a1410404e --- /dev/null +++ b/src/main/perl/lib/Module/Runtime.pm @@ -0,0 +1,520 @@ +package Module::Runtime; + +# Don't "use 5.006" here, because Perl 5.15.6 will load feature.pm if +# the version check is done that way. +BEGIN { require 5.006; } +# Don't "use warnings" here, to avoid dependencies. Do standardise the +# warning status by lexical override; unfortunately the only safe bitset +# to build in is the empty set, equivalent to "no warnings". +BEGIN { ${^WARNING_BITS} = ""; } +# Don't "use strict" here, to avoid dependencies. + +our $VERSION = '0.018'; + +# Don't use Exporter here, to avoid dependencies. +our @EXPORT_OK = qw( + $module_name_rx is_module_name is_valid_module_name check_module_name + module_notional_filename require_module + use_module use_package_optimistically + $top_module_spec_rx $sub_module_spec_rx + is_module_spec is_valid_module_spec check_module_spec + compose_module_name +); +my %export_ok = map { ($_ => undef) } @EXPORT_OK; +sub import { + my $me = shift; + my $callpkg = caller; + my $errs = ""; + foreach(@_) { + if(exists $export_ok{$_}) { + # We would need to do "no strict 'refs'" here + # if we had enabled strict at file scope. + if(/\A\$(.*)\z/s) { + *{$callpkg."::".$1} = \$$1; + } else { + *{$callpkg."::".$_} = \&$_; + } + } else { + $errs .= "\"$_\" is not exported by the $me module\n"; + } + } + if($errs ne "") { + die sprintf "%sCan't continue after import errors at %s line %u.\n", + $errs, (caller)[1,2]; + } +} + +# Logic duplicated from Params::Classify. Duplicating it here avoids +# an extensive and potentially circular dependency graph. +sub _is_string($) { + my($arg) = @_; + return defined($arg) && ref(\$arg) eq "SCALAR"; +} + +our $module_name_rx = qr{[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*}; + +my $qual_module_spec_rx = + qr{(?:/|::)[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*}; + +my $unqual_top_module_spec_rx = + qr{[A-Z_a-z][0-9A-Z_a-z]*(?:(?:/|::)[0-9A-Z_a-z]+)*}; + +our $top_module_spec_rx = qr{$qual_module_spec_rx|$unqual_top_module_spec_rx}; + +my $unqual_sub_module_spec_rx = qr{[0-9A-Z_a-z]+(?:(?:/|::)[0-9A-Z_a-z]+)*}; + +our $sub_module_spec_rx = qr{$qual_module_spec_rx|$unqual_sub_module_spec_rx}; + +sub is_module_name($) { _is_string($_[0]) && $_[0] =~ /\A$module_name_rx\z/o } + +*is_valid_module_name = \&is_module_name; + +sub check_module_name($) { + unless(&is_module_name) { + die +(_is_string($_[0]) ? "`$_[0]'" : "argument"). + " is not a module name\n"; + } +} + +sub module_notional_filename($) { + &check_module_name; + my($name) = @_; + $name =~ s{::}{/}g; + return $name.".pm"; +} + +# Don't "use constant" here, to avoid dependencies. +BEGIN { + ## no critic (ValuesAndExpressions::ProhibitMismatchedOperators) + *_WORK_AROUND_HINT_LEAKAGE = + "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001) + ? sub(){1} : sub(){0}; + *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; +} + +BEGIN { + if(_WORK_AROUND_BROKEN_MODULE_STATE) { + eval <<'END_CODE' or die $@; ## no critic (BuiltinFunctions::ProhibitStringyEval) + sub Module::Runtime::__GUARD__::DESTROY { + delete $INC{$_[0]->[0]} if @{$_[0]}; + } + 1; +END_CODE + } +} + +sub require_module($) { + # Localise %^H to work around [perl #68590], where the bug exists + # and this is a satisfactory workaround. The bug consists of + # %^H state leaking into each required module, polluting the + # module's lexical state. + local %^H if _WORK_AROUND_HINT_LEAKAGE; + if(_WORK_AROUND_BROKEN_MODULE_STATE) { + my $notional_filename = &module_notional_filename; + my $guard = bless([ $notional_filename ], + "Module::Runtime::__GUARD__"); + my $result = CORE::require($notional_filename); + pop @$guard; + return $result; + } else { + return scalar(CORE::require(&module_notional_filename)); + } +} + +sub use_module($;$) { + my($name, $version) = @_; + require_module($name); + $name->VERSION($version) if @_ >= 2; + return $name; +} + +my $FILE = __FILE__; +sub use_package_optimistically($;$) { + my($name, $version) = @_; + my $fn = module_notional_filename($name); + eval { + local $SIG{__DIE__}; + require_module($name); + 1; + } or do { + die $@ if ( + $@ !~ /\ACan't locate \Q$fn\E .+ at \Q$FILE\E line/s || + $@ =~ /^Compilation\ failed\ in\ require\ at\ \Q$FILE\E\ line/xm + ); + }; + $name->VERSION($version) if @_ >= 2; + return $name; +} + +sub is_module_spec($$) { + my($prefix, $spec) = @_; + return _is_string($spec) && ( + $prefix ? $spec =~ /\A$sub_module_spec_rx\z/o + : $spec =~ /\A$top_module_spec_rx\z/o + ); +} + +*is_valid_module_spec = \&is_module_spec; + +sub check_module_spec($$) { + unless(&is_module_spec) { + die +(_is_string($_[1]) ? "`$_[1]'" : "argument"). + " is not a module specification\n"; + } +} + +sub compose_module_name($$) { + my($prefix, $spec) = @_; + check_module_name($prefix) if defined $prefix; + &check_module_spec; + if($spec =~ s{\A(?:/|::)}{}) { + # OK + } else { + $spec = $prefix."::".$spec if defined $prefix; + } + $spec =~ s{/}{::}g; + return $spec; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=for :stopwords Andrew Main (Zefram) Main, Graham Knop + +=head1 NAME + +Module::Runtime - runtime module handling + +=head1 SYNOPSIS + + use Module::Runtime qw( + $module_name_rx is_module_name check_module_name + module_notional_filename require_module); + + if($module_name =~ /\A$module_name_rx\z/o) { ... + if(is_module_name($module_name)) { ... + check_module_name($module_name); + + $notional_filename = module_notional_filename($module_name); + require_module($module_name); + + use Module::Runtime qw(use_module use_package_optimistically); + + $bi = use_module("Math::BigInt", 1.31)->new("1_234"); + $widget = use_package_optimistically("Local::Widget")->new; + + use Module::Runtime qw( + $top_module_spec_rx $sub_module_spec_rx + is_module_spec check_module_spec + compose_module_name); + + if($spec =~ /\A$top_module_spec_rx\z/o) { ... + if($spec =~ /\A$sub_module_spec_rx\z/o) { ... + if(is_module_spec("Standard::Prefix", $spec)) { ... + check_module_spec("Standard::Prefix", $spec); + + $module_name = compose_module_name("Standard::Prefix", $spec); + +=head1 DESCRIPTION + +The functions exported by this module deal with runtime handling of +Perl modules, which are normally handled at compile time. This module +avoids using any other modules, so that it can be used in low-level +infrastructure. + +The parts of this module that work with module names apply the same syntax +that is used for barewords in Perl source. In principle this syntax +can vary between versions of Perl, and this module applies the syntax of +the Perl on which it is running. In practice the usable syntax hasn't +changed yet. There's some intent for Unicode module names to be supported +in the future, but this hasn't yet amounted to any consistent facility. + +The functions of this module whose purpose is to load modules include +workarounds for three old Perl core bugs regarding C. These +workarounds are applied on any Perl version where the bugs exist, except +for a case where one of the bugs cannot be adequately worked around in +pure Perl. + +=head2 Module name syntax + +The usable module name syntax has not changed from Perl 5.000 up to +Perl 5.19.8. The syntax is composed entirely of ASCII characters. +From Perl 5.6 onward there has been some attempt to allow the use of +non-ASCII Unicode characters in Perl source, but it was fundamentally +broken (like the entirety of Perl 5.6's Unicode handling) and remained +pretty much entirely unusable until it got some attention in the Perl +5.15 series. Although Unicode is now consistently accepted by the +parser in some places, it remains broken for module names. Furthermore, +there has not yet been any work on how to map Unicode module names into +filenames, so in that respect also Unicode module names are unusable. + +The module name syntax is, precisely: the string must consist of one or +more segments separated by C<::>; each segment must consist of one or more +identifier characters (ASCII alphanumerics plus "_"); the first character +of the string must not be a digit. Thus "C", "C", +and "C" are all valid module names, whereas "C" +and "C<1foo::bar>" are not. C<'> separators are not permitted by this +module, though they remain usable in Perl source, being translated to +C<::> in the parser. + +=head2 Core bugs worked around + +The first bug worked around is core bug [perl #68590], which causes +lexical state in one file to leak into another that is Cd/Cd +from it. This bug is present from Perl 5.6 up to Perl 5.10, and is +fixed in Perl 5.11.0. From Perl 5.9.4 up to Perl 5.10.0 no satisfactory +workaround is possible in pure Perl. The workaround means that modules +loaded via this module don't suffer this pollution of their lexical +state. Modules loaded in other ways, or via this module on the Perl +versions where the pure Perl workaround is impossible, remain vulnerable. +The module L provides a complete workaround +for this bug. + +The second bug worked around causes some kinds of failure in module +loading, principally compilation errors in the loaded module, to be +recorded in C<%INC> as if they were successful, so later attempts to load +the same module immediately indicate success. This bug is present up +to Perl 5.8.9, and is fixed in Perl 5.9.0. The workaround means that a +compilation error in a module loaded via this module won't be cached as +a success. Modules loaded in other ways remain liable to produce bogus +C<%INC> entries, and if a bogus entry exists then it will mislead this +module if it is used to re-attempt loading. + +The third bug worked around causes the wrong context to be seen at +file scope of a loaded module, if C is invoked in a location +that inherits context from a higher scope. This bug is present up to +Perl 5.11.2, and is fixed in Perl 5.11.3. The workaround means that +a module loaded via this module will always see the correct context. +Modules loaded in other ways remain vulnerable. + +=head1 REGULAR EXPRESSIONS + +These regular expressions do not include any anchors, so to check +whether an entire string matches a syntax item you must supply the +anchors yourself. + +=over + +=item $module_name_rx + +Matches a valid Perl module name in bareword syntax. + +=item $top_module_spec_rx + +Matches a module specification for use with +L<"compose_module_name"|/compose_module_name(PREFIX, SPEC)>. +where no prefix is being used. + +=item $sub_module_spec_rx + +Matches a module specification for use with +L<"compose_module_name"|/compose_module_name(PREFIX, SPEC)>, +where a prefix is being used. + +=back + +=head1 FUNCTIONS + +=head2 Basic module handling + +=over + +=item is_module_name(ARG) + +Returns a truth value indicating whether I is a plain string +satisfying Perl module name syntax as described for L. + +=item is_valid_module_name(ARG) + +Deprecated alias for L<"is_module_name"|/is_module_name(ARG)>. + +=item check_module_name(ARG) + +Check whether I is a plain string +satisfying Perl module name syntax as described for L. +Return normally if it is, or C if it is not. + +=item module_notional_filename(NAME) + +Generates a notional relative filename for a module, which is used in +some Perl core interfaces. +The I is a string, which should be a valid module name (one or +more C<::>-separated segments). If it is not a valid name, the function +Cs. + +The notional filename for the named module is generated and returned. +This filename is always in Unix style, with C directory separators +and a C<.pm> suffix. This kind of filename can be used as an argument to +C, and is the key that appears in C<%INC> to identify a module, +regardless of actual local filename syntax. + +=item require_module(NAME) + +This is essentially the bareword form of C, in runtime form. +The I is a string, which should be a valid module name (one or +more C<::>-separated segments). If it is not a valid name, the function +Cs. + +The module specified by I is loaded, if it hasn't been already, +in the manner of the bareword form of C. That means that a +search through C<@INC> is performed, and a byte-compiled form of the +module will be used if available. + +The return value is as for C. That is, it is the value returned +by the module itself if the module is loaded anew, or C<1> if the module +was already loaded. + +=back + +=head2 Structured module use + +=over + +=item use_module(NAME[, VERSION]) + +This is essentially C in runtime form, but without the importing +feature (which is fundamentally a compile-time thing). The I is +handled just like in C above: it must be a module name, +and the named module is loaded as if by the bareword form of C. + +If a I is specified, the C method of the loaded module is +called with the specified I as an argument. This normally serves to +ensure that the version loaded is at least the version required. This is +the same functionality provided by the I parameter of C. + +On success, the name of the module is returned. This is unlike +L<"require_module"|/require_module(NAME)>, and is done so that the entire call +to L<"use_module"|/use_module(NAME[, VERSION])> can be used as a class name to +call a constructor, as in the example in the synopsis. + +=item use_package_optimistically(NAME[, VERSION]) + +This is an analogue of L<"use_module"|/use_module(NAME[, VERSION])> for +the situation where there is +uncertainty as to whether a package/class is defined in its own module +or by some other means. It attempts to arrange for the named package to +be available, either by loading a module or by doing nothing and hoping. + +An attempt is made to load the named module (as if by the bareword form +of C). If the module cannot be found then it is assumed that +the package was actually already loaded by other means, and no error +is signaled. That's the optimistic bit. + +I this optional module loading is liable to cause unreliable +behaviour, including security problems. It interacts especially badly +with having C<.> in C<@INC>, which was the default state of affairs in +Perls prior to 5.25.11. If a package is actually defined by some means +other than a module, then applying this function to it causes a spurious +attempt to load a module that is expected to be non-existent. If a +module actually exists under that name then it will be unintentionally +loaded. If C<.> is in C<@INC> and this code is ever run with the current +directory being one writable by a malicious user (such as F), then +the malicious user can easily cause the victim to run arbitrary code, by +creating a module file under the predictable spuriously-loaded name in the +writable directory. Generally, optional module loading should be avoided. + +This is mostly the same operation that is performed by the L pragma +to ensure that the specified base classes are available. The behaviour +of L was simplified in version 2.18, and later improved in version +2.20, and on both occasions this function changed to match. + +If a I is specified, the C method of the loaded package is +called with the specified I as an argument. This normally serves +to ensure that the version loaded is at least the version required. +On success, the name of the package is returned. These aspects of the +function work just like L<"use_module"|/use_module(NAME[, VERSION])>. + +=back + +=head2 Module name composition + +=over + +=item is_module_spec(PREFIX, SPEC) + +Returns a truth value indicating +whether I is valid input for +L<"compose_module_name"|/compose_module_name(PREFIX, SPEC)>. +See below for what that entails. Whether a I is supplied affects +the validity of I, but the exact value of the prefix is unimportant, +so this function treats I as a truth value. + +=item is_valid_module_spec(PREFIX, SPEC) + +Deprecated alias for L<"is_module_spec"|/is_module_spec(PREFIX, SPEC)>. + +=item check_module_spec(PREFIX, SPEC) + +Check whether I is valid input for +L<"compose_module_name"|/compose_module_name(PREFIX, SPEC)>. +Return normally if it is, or C if it is not. + +=item compose_module_name(PREFIX, SPEC) + +This function is intended to make it more convenient for a user to specify +a Perl module name at runtime. Users have greater need for abbreviations +and context-sensitivity than programmers, and Perl module names get a +little unwieldy. I is what the user specifies, and this function +translates it into a module name in standard form, which it returns. + +I has syntax approximately that of a standard module name: it +should consist of one or more name segments, each of which consists +of one or more identifier characters. However, C is permitted as a +separator, in addition to the standard C<::>. The two separators are +entirely interchangeable. + +Additionally, if I is not C then it must be a module +name in standard form, and it is prefixed to the user-specified name. +The user can inhibit the prefix addition by starting I with a +separator (either C or C<::>). + +=back + +=head1 BUGS + +On Perl versions 5.7.2 to 5.8.8, if C is overridden by the +C mechanism, it is likely to break the heuristics used by +L<"use_package_optimistically"|/use_package_optimistically(NAME[, VERSION])>, +making it signal an error for a missing +module rather than assume that it was already loaded. From Perl 5.8.9 +onward, and on 5.7.1 and earlier, this module can avoid being confused +by such an override. On the affected versions, a C override +might be installed by L, if something requires +its bugfix but for some reason its XS implementation isn't available. + +=head1 SEE ALSO + +=over 4 + +=item * L + +=item * L + +=item * L + +=item * L + +=back + +=head1 AUTHOR + +Andrew Main (Zefram) + +=head1 COPYRIGHT + +Copyright (C) 2004, 2006, 2007, 2009, 2010, 2011, 2012, 2014, 2017 +Andrew Main (Zefram) + +Copyright (C) 2025 Graham Knop + +=head1 LICENSE + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/src/main/perl/lib/Package/DeprecationManager.pm b/src/main/perl/lib/Package/DeprecationManager.pm new file mode 100644 index 000000000..181d0e7cb --- /dev/null +++ b/src/main/perl/lib/Package/DeprecationManager.pm @@ -0,0 +1,368 @@ +package Package::DeprecationManager; + +use strict; +use warnings; + +our $VERSION = '0.18'; + +use Carp qw( croak ); +use List::Util 1.33 qw( any ); +use Package::Stash; +use Params::Util qw( _HASH0 ); +use Sub::Install; +use Sub::Util qw( set_subname ); + +sub import { + shift; + my %args = @_; + + croak + 'You must provide a hash reference -deprecations parameter when importing Package::DeprecationManager' + unless $args{-deprecations} && _HASH0( $args{-deprecations} ); + + my %registry; + + my $caller = caller(); + + my $orig_import = $caller->can('import'); + + my $import = _build_import( \%registry, $orig_import ); + my $warn + = _build_warn( \%registry, $args{-deprecations}, $args{-ignore} ); + + # We need to remove this to prevent a 'subroutine redefined' warning. + if ($orig_import) { + Package::Stash->new($caller)->remove_symbol('&import'); + } + + Sub::Install::install_sub( + { + code => set_subname( $caller . '::import', $import ), + into => $caller, + as => 'import', + } + ); + + Sub::Install::install_sub( + { + code => set_subname( $caller . '::deprecated', $warn ), + into => $caller, + as => 'deprecated', + } + ); + + return; +} + +sub _build_import { + my $registry = shift; + my $orig_import = shift; + + return sub { + my $class = shift; + + my @args; + + my $api_version; + ## no critic (ControlStructures::ProhibitCStyleForLoops) + for ( my $i = 0; $i < @_; $i++ ) { + if ( $_[$i] eq '-api_version' || $_[$i] eq '-compatible' ) { + $api_version = $_[ ++$i ]; + } + else { + push @args, $_[$i]; + } + } + ## use critic + + my $caller = caller(); + $registry->{$caller} = $api_version + if defined $api_version; + + if ($orig_import) { + @_ = ( $class, @args ); + goto &{$orig_import}; + } + + return; + }; +} + +sub _build_warn { + my $registry = shift; + my $deprecated_at = shift; + my $ignore = shift; + + my %ignore = map { $_ => 1 } grep { !ref } @{ $ignore || [] }; + my @ignore_res = grep {ref} @{ $ignore || [] }; + + my %warned; + + return sub { + my %args = @_ < 2 ? ( message => shift ) : @_; + + my ( $package, undef, undef, $sub ) = caller(1); + + my $skipped = 1; + + if ( @ignore_res || keys %ignore ) { + while ( + defined $package + && ( $ignore{$package} || any { $package =~ $_ } @ignore_res ) + ) { + $package = caller( $skipped++ ); + } + } + + $package = 'unknown package' unless defined $package; + + unless ( defined $args{feature} ) { + $args{feature} = $sub; + } + + my $compat_version = $registry->{$package}; + + my $at = $deprecated_at->{ $args{feature} }; + + return + if defined $compat_version + && defined $deprecated_at + && $compat_version lt $at; + + my $msg; + if ( defined $args{message} ) { + $msg = $args{message}; + } + else { + $msg = "$args{feature} has been deprecated"; + $msg .= " since version $at" + if defined $at; + } + + return if $warned{$package}{ $args{feature} }{$msg}; + + $warned{$package}{ $args{feature} }{$msg} = 1; + + # We skip at least two levels. One for this anon sub, and one for the + # sub calling it. + local $Carp::CarpLevel = $Carp::CarpLevel + $skipped; + + Carp::cluck($msg); + }; +} + +1; + +# ABSTRACT: Manage deprecation warnings for your distribution + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Package::DeprecationManager - Manage deprecation warnings for your distribution + +=head1 VERSION + +version 0.18 + +=head1 SYNOPSIS + + package My::Class; + + use Package::DeprecationManager -deprecations => { + 'My::Class::foo' => '0.02', + 'My::Class::bar' => '0.05', + 'feature-X' => '0.07', + }; + + sub foo { + deprecated( 'Do not call foo!' ); + + ... + } + + sub bar { + deprecated(); + + ... + } + + sub baz { + my %args = @_; + + if ( $args{foo} ) { + deprecated( + message => ..., + feature => 'feature-X', + ); + } + } + + package Other::Class; + + use My::Class -api_version => '0.04'; + + My::Class->new()->foo(); # warns + My::Class->new()->bar(); # does not warn + My::Class->new()->bar(); # does not warn again + +=head1 DESCRIPTION + +This module allows you to manage a set of deprecations for one or more modules. + +When you import C, you must provide a set of +C<-deprecations> as a hash ref. The keys are "feature" names, and the values +are the version when that feature was deprecated. + +In many cases, you can simply use the fully qualified name of a subroutine or +method as the feature name. This works for cases where the whole subroutine is +deprecated. However, the feature names can be any string. This is useful if you +don't want to deprecate an entire subroutine, just a certain usage. + +You can also provide an optional array reference in the C<-ignore> parameter. + +The values to be ignored can be package names or regular expressions (made with +C). Use this to ignore packages in your distribution that can appear on +the call stack when a deprecated feature is used. + +As part of the import process, C will export two +subroutines into its caller. It provides an C sub for the caller and +a C sub. + +The C sub allows callers of I class to specify an +C<-api_version> parameter. If this is supplied, then deprecation warnings are +only issued for deprecations with API versions earlier than the one specified. + +You must call the C sub in each deprecated subroutine. When +called, it will issue a warning using C. + +The C sub can be called in several ways. If you do not pass any +arguments, it will generate an appropriate warning message. If you pass a +single argument, this is used as the warning message. + +Finally, you can call it with named arguments. Currently, the only allowed +names are C and C. The C argument should correspond +to the feature name passed in the C<-deprecations> hash. + +If you don't explicitly specify a feature, the C sub uses +C to identify its caller, using its fully qualified subroutine name. + +A given deprecation warning is only issued once for a given package. This +module tracks this based on both the feature name I the error message +itself. This means that if you provide several different error messages for the +same feature, all of those errors will appear. + +=head2 Other import() subs + +This module works by installing an C sub in any package that uses it. +If that package I has an C sub, then that C will be +called after any arguments passed for C are +stripped out. You need to define your C sub before you C to make this work: + + package HasExporter; + + use Exporter qw( import ); + + use Package::DeprecationManager -deprecations => { + 'HasExporter::foo' => '0.02', + }; + + our @EXPORT_OK = qw( some_sub another_sub ); + +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, please +consider making a "donation" to me via PayPal. I spend a lot of free time +creating free software, and would appreciate any support you'd care to offer. + +Please note that B in order for me +to continue working on this particular software. I will continue to do so, +inasmuch as I have in the past, for as long as it interests me. + +Similarly, a donation made in this way will probably not make me work on this +software much more, unless I get so many donations that I can consider working +on free software full time, which seems unlikely at best. + +To donate, log into PayPal and send money to autarch@urth.org or use the button +on this page: L + +=head1 CREDITS + +The idea for this functionality and some of its implementation was originally +created as L by Goro Fuji. + +=head1 BUGS + +Please report any bugs or feature requests to +C, or through the web interface at +L. I will be notified, and then you'll automatically be +notified of progress on your bug as I make changes. + +Bugs may be submitted at L. + +=head1 SOURCE + +The source code repository for Package-DeprecationManager can be found at L. + +=head1 DONATIONS + +If you'd like to thank me for the work I've done on this module, please +consider making a "donation" to me via PayPal. I spend a lot of free time +creating free software, and would appreciate any support you'd care to offer. + +Please note that B in order for me +to continue working on this particular software. I will continue to do so, +inasmuch as I have in the past, for as long as it interests me. + +Similarly, a donation made in this way will probably not make me work on this +software much more, unless I get so many donations that I can consider working +on free software full time (let's all have a chuckle at that together). + +To donate, log into PayPal and send money to autarch@urth.org, or use the +button at L. + +=head1 AUTHOR + +Dave Rolsky + +=head1 CONTRIBUTORS + +=for stopwords Aristotle Pagaltzis Jesse Luehrs Karen Etheridge Tomas Doran + +=over 4 + +=item * + +Aristotle Pagaltzis + +=item * + +Jesse Luehrs + +=item * + +Karen Etheridge + +=item * + +Tomas Doran + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2023 by Dave Rolsky. + +This is free software, licensed under: + + The Artistic License 2.0 (GPL Compatible) + +The full text of the license can be found in the +F file included with this distribution. + +=cut diff --git a/src/main/perl/lib/Params/Util.pm b/src/main/perl/lib/Params/Util.pm new file mode 100755 index 000000000..36c8b1536 --- /dev/null +++ b/src/main/perl/lib/Params/Util.pm @@ -0,0 +1,486 @@ +package Params::Util; + +=pod + +=head1 NAME + +Params::Util - Simple, compact and correct param-checking functions + +=head1 SYNOPSIS + + # Import some functions + use Params::Util qw{_SCALAR _HASH _INSTANCE}; + + # If you are lazy, or need a lot of them... + use Params::Util ':ALL'; + + sub foo { + my $object = _INSTANCE(shift, 'Foo') or return undef; + my $image = _SCALAR(shift) or return undef; + my $options = _HASH(shift) or return undef; + # etc... + } + +=head1 DESCRIPTION + +C provides a basic set of importable functions that makes +checking parameters a hell of a lot easier + +While they can be (and are) used in other contexts, the main point +behind this module is that the functions B Do What You Mean, +and Do The Right Thing, so they are most useful when you are getting +params passed into your code from someone and/or somewhere else +and you can't really trust the quality. + +Thus, C is of most use at the edges of your API, where +params and data are coming in from outside your code. + +The functions provided by C check in the most strictly +correct manner known, are documented as thoroughly as possible so their +exact behaviour is clear, and heavily tested so make sure they are not +fooled by weird data and Really Bad Things. + +To use, simply load the module providing the functions you want to use +as arguments (as shown in the SYNOPSIS). + +To aid in maintainability, C will B export by +default. + +You must explicitly name the functions you want to export, or use the +C<:ALL> param to just have it export everything (although this is not +recommended if you have any _FOO functions yourself with which future +additions to C may clash) + +=head1 FUNCTIONS + +=cut + +use 5.00503; +use strict; +use warnings; +use parent qw{Exporter XSLoader}; + +use Params::Util::PP qw(); + +our $VERSION = '1.102'; + +local $ENV{PERL_DL_NONLAZY} = 0 if $ENV{PERL_DL_NONLAZY}; +XSLoader::load("Params::Util", $VERSION) unless $ENV{PERL_PARAMS_UTIL_PP}; + +our @EXPORT_OK = qw{ + _STRING _IDENTIFIER + _CLASS _CLASSISA _SUBCLASS _DRIVER _CLASSDOES + _NUMBER _POSINT _NONNEGINT + _SCALAR _SCALAR0 + _ARRAY _ARRAY0 _ARRAYLIKE + _HASH _HASH0 _HASHLIKE + _CODE _CODELIKE + _INVOCANT _REGEX _INSTANCE _INSTANCEDOES + _SET _SET0 + _HANDLE +}; +our %EXPORT_TAGS = (ALL => \@EXPORT_OK); + +## no critic (TestingAndDebugging::ProhibitNoStrict) +no strict "refs"; +Params::Util->can($_) or *$_ = Params::Util::PP->can($_) for (@EXPORT_OK); +use strict "refs"; + +##################################################################### +# Param Checking Functions + +=pod + +=head2 _STRING $string + +The C<_STRING> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a normal non-false string of non-zero length. + +Note that this will NOT do anything magic to deal with the special +C<'0'> false negative case, but will return it. + + # '0' not considered valid data + my $name = _STRING(shift) or die "Bad name"; + + # '0' is considered valid data + my $string = _STRING($_[0]) ? shift : die "Bad string"; + +Please also note that this function expects a normal string. It does +not support overloading or other magic techniques to get a string. + +Returns the string as a convenience if it is a valid string, or +C if not. + +=head2 _IDENTIFIER $string + +The C<_IDENTIFIER> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a string that is a valid Perl identifier. + +Returns the string as a convenience if it is a valid identifier, or +C if not. + +=head2 _CLASS $string + +The C<_CLASS> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a string that is a valid Perl class. + +This function only checks that the format is valid, not that the +class is actually loaded. It also assumes "normalized" form, and does +not accept class names such as C<::Foo> or C. + +Returns the string as a convenience if it is a valid class name, or +C if not. + +=head2 _CLASSISA $string, $class + +The C<_CLASSISA> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a string that is a particularly class, or a subclass of it. + +This function checks that the format is valid and calls the -Eisa +method on the class name. It does not check that the class is actually +loaded. + +It also assumes "normalized" form, and does +not accept class names such as C<::Foo> or C. + +Returns the string as a convenience if it is a valid class name, or +C if not. + +=head2 _CLASSDOES $string, $role + +This routine behaves exactly like C>, but checks with C<< ->DOES +>> rather than C<< ->isa >>. This is probably only a good idea to use on Perl +5.10 or later, when L has been +implemented. + +=head2 _SUBCLASS $string, $class + +The C<_SUBCLASS> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a string that is a subclass of a specified class. + +This function checks that the format is valid and calls the -Eisa +method on the class name. It does not check that the class is actually +loaded. + +It also assumes "normalized" form, and does +not accept class names such as C<::Foo> or C. + +Returns the string as a convenience if it is a valid class name, or +C if not. + +=head2 _NUMBER $scalar + +The C<_NUMBER> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a number. That is, it is defined and perl thinks it's a number. + +This function is basically a Params::Util-style wrapper around the +L C function. + +Returns the value as a convenience, or C if the value is not a +number. + +=head2 _POSINT $integer + +The C<_POSINT> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a positive integer (of any length). + +Returns the value as a convenience, or C if the value is not a +positive integer. + +The name itself is derived from the XML schema constraint of the same +name. + +=head2 _NONNEGINT $integer + +The C<_NONNEGINT> function is intended to be imported into your +package, and provides a convenient way to test to see if a value is +a non-negative integer (of any length). That is, a positive integer, +or zero. + +Returns the value as a convenience, or C if the value is not a +non-negative integer. + +As with other tests that may return false values, care should be taken +to test via "defined" in boolean validly contexts. + + unless ( defined _NONNEGINT($value) ) { + die "Invalid value"; + } + +The name itself is derived from the XML schema constraint of the same +name. + +=head2 _SCALAR \$scalar + +The C<_SCALAR> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference, with content of non-zero length. + +For a version that allows zero length C references, see +the C<_SCALAR0> function. + +Returns the C reference itself as a convenience, or C +if the value provided is not a C reference. + +=head2 _SCALAR0 \$scalar + +The C<_SCALAR0> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference, allowing content of zero-length. + +For a simpler "give me some content" version that requires non-zero +length, C<_SCALAR> function. + +Returns the C reference itself as a convenience, or C +if the value provided is not a C reference. + +=head2 _ARRAY $value + +The C<_ARRAY> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference containing B one element of any kind. + +For a more basic form that allows zero length ARRAY references, see +the C<_ARRAY0> function. + +Returns the C reference itself as a convenience, or C +if the value provided is not an C reference. + +=head2 _ARRAY0 $value + +The C<_ARRAY0> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference, allowing C references that contain no +elements. + +For a more basic "An array of something" form that also requires at +least one element, see the C<_ARRAY> function. + +Returns the C reference itself as a convenience, or C +if the value provided is not an C reference. + +=head2 _ARRAYLIKE $value + +The C<_ARRAYLIKE> function tests whether a given scalar value can respond to +array dereferencing. If it can, the value is returned. If it cannot, +C<_ARRAYLIKE> returns C. + +=head2 _HASH $value + +The C<_HASH> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference with at least one entry. + +For a version of this function that allows the C to be empty, +see the C<_HASH0> function. + +Returns the C reference itself as a convenience, or C +if the value provided is not an C reference. + +=head2 _HASH0 $value + +The C<_HASH0> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference, regardless of the C content. + +For a simpler "A hash of something" version that requires at least one +element, see the C<_HASH> function. + +Returns the C reference itself as a convenience, or C +if the value provided is not an C reference. + +=head2 _HASHLIKE $value + +The C<_HASHLIKE> function tests whether a given scalar value can respond to +hash dereferencing. If it can, the value is returned. If it cannot, +C<_HASHLIKE> returns C. + +=head2 _CODE $value + +The C<_CODE> function is intended to be imported into your package, +and provides a convenient way to test for a raw and unblessed +C reference. + +Returns the C reference itself as a convenience, or C +if the value provided is not an C reference. + +=head2 _CODELIKE $value + +The C<_CODELIKE> is the more generic version of C<_CODE>. Unlike C<_CODE>, +which checks for an explicit C reference, the C<_CODELIKE> function +also includes things that act like them, such as blessed objects that +overload C<'&{}'>. + +Please note that in the case of objects overloaded with '&{}', you will +almost always end up also testing it in 'bool' context at some stage. + +For example: + + sub foo { + my $code1 = _CODELIKE(shift) or die "No code param provided"; + my $code2 = _CODELIKE(shift); + if ( $code2 ) { + print "Got optional second code param"; + } + } + +As such, you will most likely always want to make sure your class has +at least the following to allow it to evaluate to true in boolean +context. + + # Always evaluate to true in boolean context + use overload 'bool' => sub () { 1 }; + +Returns the callable value as a convenience, or C if the +value provided is not callable. + +Note - This function was formerly known as _CALLABLE but has been renamed +for greater symmetry with the other _XXXXLIKE functions. + +The use of _CALLABLE has been deprecated. It will continue to work, but +with a warning, until end-2006, then will be removed. + +I apologize for any inconvenience caused. + +=head2 _INVOCANT $value + +This routine tests whether the given value is a valid method invocant. +This can be either an instance of an object, or a class name. + +If so, the value itself is returned. Otherwise, C<_INVOCANT> +returns C. + +=head2 _INSTANCE $object, $class + +The C<_INSTANCE> function is intended to be imported into your package, +and provides a convenient way to test for an object of a particular class +in a strictly correct manner. + +Returns the object itself as a convenience, or C if the value +provided is not an object of that type. + +=head2 _INSTANCEDOES $object, $role + +This routine behaves exactly like C>, but checks with C<< ->DOES +>> rather than C<< ->isa >>. This is probably only a good idea to use on Perl +5.10 or later, when L has been +implemented. + +=head2 _REGEX $value + +The C<_REGEX> function is intended to be imported into your package, +and provides a convenient way to test for a regular expression. + +Returns the value itself as a convenience, or C if the value +provided is not a regular expression. + +=head2 _SET \@array, $class + +The C<_SET> function is intended to be imported into your package, +and provides a convenient way to test for set of at least one object of +a particular class in a strictly correct manner. + +The set is provided as a reference to an C of objects of the +class provided. + +For an alternative function that allows zero-length sets, see the +C<_SET0> function. + +Returns the C reference itself as a convenience, or C if +the value provided is not a set of that class. + +=head2 _SET0 \@array, $class + +The C<_SET0> function is intended to be imported into your package, +and provides a convenient way to test for a set of objects of a +particular class in a strictly correct manner, allowing for zero objects. + +The set is provided as a reference to an C of objects of the +class provided. + +For an alternative function that requires at least one object, see the +C<_SET> function. + +Returns the C reference itself as a convenience, or C if +the value provided is not a set of that class. + +=head2 _HANDLE + +The C<_HANDLE> function is intended to be imported into your package, +and provides a convenient way to test whether or not a single scalar +value is a file handle. + +Unfortunately, in Perl the definition of a file handle can be a little +bit fuzzy, so this function is likely to be somewhat imperfect (at first +anyway). + +That said, it is implement as well or better than the other file handle +detectors in existence (and we stole from the best of them). + +=head2 _DRIVER $string + + sub foo { + my $class = _DRIVER(shift, 'My::Driver::Base') or die "Bad driver"; + ... + } + +The C<_DRIVER> function is intended to be imported into your +package, and provides a convenient way to load and validate +a driver class. + +The most common pattern when taking a driver class as a parameter +is to check that the name is a class (i.e. check against _CLASS) +and then to load the class (if it exists) and then ensure that +the class returns true for the isa method on some base driver name. + +Return the value as a convenience, or C if the value is not +a class name, the module does not exist, the module does not load, +or the class fails the isa test. + +=head1 TO DO + +- Add _CAN to help resolve the UNIVERSAL::can debacle + +- Implement an assertion-like version of this module, that dies on +error. + +- Implement a Test:: version of this module, for use in testing + +=head1 SUPPORT + +Bugs should be reported via the CPAN bug tracker at + +L + +=head1 AUTHOR + +Adam Kennedy Eadamk AT cpan.orgE + +Jens Rehsack Erehsack AT cpan.orgE + +=head1 SEE ALSO + +L + +=head1 COPYRIGHT + +Copyright 2005 - 2012 Adam Kennedy. + +Copyright 2020 - 2020 Jens Rehsack. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut + +1; diff --git a/src/main/perl/lib/Params/Util/PP.pm b/src/main/perl/lib/Params/Util/PP.pm new file mode 100644 index 000000000..2f9a3862f --- /dev/null +++ b/src/main/perl/lib/Params/Util/PP.pm @@ -0,0 +1,276 @@ +package Params::Util::PP; + +use strict; +use warnings; + +our $VERSION = '1.102'; + +=pod + +=head1 NAME + +Params::Util::PP - PurePerl Params::Util routines + +=cut + +use Scalar::Util (); +use overload (); + +Scalar::Util->can("looks_like_number") and Scalar::Util->import("looks_like_number"); +# Use a private pure-perl copy of looks_like_number if the version of +# Scalar::Util is old (for whatever reason). +Params::Util::PP->can("looks_like_number") or *looks_like_number = sub { + local $_ = shift; + + # checks from perlfaq4 + return 0 if !defined($_); + if (ref($_)) + { + return overload::Overloaded($_) ? defined(0 + $_) : 0; + } + return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer + ## no critic (RegularExpressions::ProhibitComplexRegexes) + 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; +}; + +## no critic (Subroutines::ProhibitSubroutinePrototypes, Subroutines::RequireArgUnpacking) +## no critic (Subroutines::ProhibitUnusedPrivateSubroutines) + +sub _XScompiled { return 0; } + +sub _STRING ($) +{ + my $arg = $_[0]; + return (defined $arg and not ref $arg and length($arg)) ? $arg : undef; +} + +sub _IDENTIFIER ($) +{ + my $arg = $_[0]; + return (defined $arg and not ref $arg and $arg =~ m/^[^\W\d]\w*\z/s) ? $arg : undef; +} + +sub _CLASS ($) +{ + my $arg = $_[0]; + return (defined $arg and not ref $arg and $arg =~ m/^[^\W\d]\w*(?:::\w+)*\z/s) ? $arg : undef; +} + +sub _CLASSISA ($$) +{ + return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->isa($_[1])) ? $_[0] : undef; +} + +sub _CLASSDOES ($$) +{ + return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0]->DOES($_[1])) ? $_[0] : undef; +} + +sub _SUBCLASS ($$) +{ + return (defined $_[0] and not ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s and $_[0] ne $_[1] and $_[0]->isa($_[1])) + ? $_[0] + : undef; +} + +sub _NUMBER ($) +{ + my $arg = $_[0]; + return (defined $arg and not ref $arg and looks_like_number($arg)) ? $arg : undef; +} + +sub _POSINT ($) +{ + my $arg = $_[0]; + return (defined $arg and not ref $arg and $arg =~ m/^[1-9]\d*$/) ? $arg : undef; +} + +sub _NONNEGINT ($) +{ + my $arg = $_[0]; + return (defined $arg and not ref $arg and $arg =~ m/^(?:0|[1-9]\d*)$/) ? $arg : undef; +} + +sub _SCALAR ($) +{ + return (ref $_[0] eq 'SCALAR' and defined ${$_[0]} and ${$_[0]} ne '') ? $_[0] : undef; +} + +sub _SCALAR0 ($) +{ + return ref $_[0] eq 'SCALAR' ? $_[0] : undef; +} + +sub _ARRAY ($) +{ + return (ref $_[0] eq 'ARRAY' and @{$_[0]}) ? $_[0] : undef; +} + +sub _ARRAY0 ($) +{ + return ref $_[0] eq 'ARRAY' ? $_[0] : undef; +} + +sub _ARRAYLIKE +{ + return ( + defined $_[0] and ref $_[0] and ((Scalar::Util::reftype($_[0]) eq 'ARRAY') + or overload::Method($_[0], '@{}')) + ) ? $_[0] : undef; +} + +sub _HASH ($) +{ + return (ref $_[0] eq 'HASH' and scalar %{$_[0]}) ? $_[0] : undef; +} + +sub _HASH0 ($) +{ + return ref $_[0] eq 'HASH' ? $_[0] : undef; +} + +sub _HASHLIKE +{ + return ( + defined $_[0] and ref $_[0] and ((Scalar::Util::reftype($_[0]) eq 'HASH') + or overload::Method($_[0], '%{}')) + ) ? $_[0] : undef; +} + +sub _CODE ($) +{ + return ref $_[0] eq 'CODE' ? $_[0] : undef; +} + +sub _CODELIKE($) +{ + return ( + (Scalar::Util::reftype($_[0]) || '') eq 'CODE' + or Scalar::Util::blessed($_[0]) and overload::Method($_[0], '&{}') + ) ? $_[0] : undef; +} + +sub _INVOCANT($) +{ + return ( + defined $_[0] + and ( + defined Scalar::Util::blessed($_[0]) + or + # We used to check for stash definedness, but any class-like name is a + # valid invocant for UNIVERSAL methods, so we stopped. -- rjbs, 2006-07-02 + _CLASS($_[0]) + ) + ) ? $_[0] : undef; +} + +sub _INSTANCE ($$) +{ + return (Scalar::Util::blessed($_[0]) and $_[0]->isa($_[1])) ? $_[0] : undef; +} + +sub _INSTANCEDOES ($$) +{ + return (Scalar::Util::blessed($_[0]) and $_[0]->DOES($_[1])) ? $_[0] : undef; +} + +sub _REGEX ($) +{ + return (defined $_[0] and 'Regexp' eq ref($_[0])) ? $_[0] : undef; +} + +sub _SET ($$) +{ + my $set_param = shift; + _ARRAY($set_param) or return undef; + foreach my $item (@$set_param) + { + _INSTANCE($item, $_[0]) or return undef; + } + return $set_param; +} + +sub _SET0 ($$) +{ + my $set_param = shift; + _ARRAY0($set_param) or return undef; + foreach my $item (@$set_param) + { + _INSTANCE($item, $_[0]) or return undef; + } + return $set_param; +} + +# We're doing this longhand for now. Once everything is perfect, +# we'll compress this into something that compiles more efficiently. +# Further, testing file handles is not something that is generally +# done millions of times, so doing it slowly is not a big speed hit. +sub _HANDLE +{ + my $it = shift; + + # It has to be defined, of course + unless (defined $it) + { + return undef; + } + + # Normal globs are considered to be file handles + if (ref $it eq 'GLOB') + { + return $it; + } + + # Check for a normal tied filehandle + # Side Note: 5.5.4's tied() and can() doesn't like getting undef + if (tied($it) and tied($it)->can('TIEHANDLE')) + { + return $it; + } + + # There are no other non-object handles that we support + unless (Scalar::Util::blessed($it)) + { + return undef; + } + + # Check for a common base classes for conventional IO::Handle object + if ($it->isa('IO::Handle')) + { + return $it; + } + + # Check for tied file handles using Tie::Handle + if ($it->isa('Tie::Handle')) + { + return $it; + } + + # IO::Scalar is not a proper seekable, but it is valid is a + # regular file handle + if ($it->isa('IO::Scalar')) + { + return $it; + } + + # Yet another special case for IO::String, which refuses (for now + # anyway) to become a subclass of IO::Handle. + if ($it->isa('IO::String')) + { + return $it; + } + + # This is not any sort of object we know about + return undef; +} + +sub _DRIVER ($$) +{ + ## no critic (BuiltinFunctions::ProhibitStringyEval) + return (defined _CLASS($_[0]) and eval "require $_[0];" and not $@ and $_[0]->isa($_[1]) and $_[0] ne $_[1]) ? $_[0] : undef; +} + +1; diff --git a/src/main/perl/lib/Sub/Exporter.pm b/src/main/perl/lib/Sub/Exporter.pm new file mode 100644 index 000000000..3c9308909 --- /dev/null +++ b/src/main/perl/lib/Sub/Exporter.pm @@ -0,0 +1,1769 @@ +use v5.12.0; +use warnings; +package Sub::Exporter 0.991; +# ABSTRACT: a sophisticated exporter for custom-built routines + +use Carp (); +use Data::OptList 0.100 (); +use Params::Util 0.14 (); # _CODELIKE +use Sub::Install 0.92 (); + +#pod =head1 SYNOPSIS +#pod +#pod Sub::Exporter must be used in two places. First, in an exporting module: +#pod +#pod # in the exporting module: +#pod package Text::Tweaker; +#pod use Sub::Exporter -setup => { +#pod exports => [ +#pod qw(squish titlecase), # always works the same way +#pod reformat => \&build_reformatter, # generator to build exported function +#pod trim => \&build_trimmer, +#pod indent => \&build_indenter, +#pod ], +#pod collectors => [ 'defaults' ], +#pod }; +#pod +#pod Then, in an importing module: +#pod +#pod # in the importing module: +#pod use Text::Tweaker +#pod 'squish', +#pod indent => { margin => 5 }, +#pod reformat => { width => 79, justify => 'full', -as => 'prettify_text' }, +#pod defaults => { eol => 'CRLF' }; +#pod +#pod With this setup, the importing module ends up with three routines: C, +#pod C, and C. The latter two have been built to the +#pod specifications of the importer -- they are not just copies of the code in the +#pod exporting package. +#pod +#pod =head1 DESCRIPTION +#pod +#pod B If you're not familiar with Exporter or exporting, read +#pod L first! +#pod +#pod =head2 Why Generators? +#pod +#pod The biggest benefit of Sub::Exporter over existing exporters (including the +#pod ubiquitous Exporter.pm) is its ability to build new coderefs for export, rather +#pod than to simply export code identical to that found in the exporting package. +#pod +#pod If your module's consumers get a routine that works like this: +#pod +#pod use Data::Analyze qw(analyze); +#pod my $value = analyze($data, $tolerance, $passes); +#pod +#pod and they constantly pass only one or two different set of values for the +#pod non-C<$data> arguments, your code can benefit from Sub::Exporter. By writing a +#pod simple generator, you can let them do this, instead: +#pod +#pod use Data::Analyze +#pod analyze => { tolerance => 0.10, passes => 10, -as => analyze10 }, +#pod analyze => { tolerance => 0.15, passes => 50, -as => analyze50 }; +#pod +#pod my $value = analyze10($data); +#pod +#pod The package with the generator for that would look something like this: +#pod +#pod package Data::Analyze; +#pod use Sub::Exporter -setup => { +#pod exports => [ +#pod analyze => \&build_analyzer, +#pod ], +#pod }; +#pod +#pod sub build_analyzer { +#pod my ($class, $name, $arg) = @_; +#pod +#pod return sub { +#pod my $data = shift; +#pod my $tolerance = shift || $arg->{tolerance}; +#pod my $passes = shift || $arg->{passes}; +#pod +#pod analyze($data, $tolerance, $passes); +#pod } +#pod } +#pod +#pod Your module's user now has to do less work to benefit from it -- and remember, +#pod you're often your own user! Investing in customized subroutines is an +#pod investment in future laziness. +#pod +#pod This also avoids a common form of ugliness seen in many modules: package-level +#pod configuration. That is, you might have seen something like the above +#pod implemented like so: +#pod +#pod use Data::Analyze qw(analyze); +#pod $Data::Analyze::default_tolerance = 0.10; +#pod $Data::Analyze::default_passes = 10; +#pod +#pod This might save time, until you have multiple modules using Data::Analyze. +#pod Because there is only one global configuration, they step on each other's toes +#pod and your code begins to have mysterious errors. +#pod +#pod Generators can also allow you to export class methods to be called as +#pod subroutines: +#pod +#pod package Data::Methodical; +#pod use Sub::Exporter -setup => { exports => { some_method => \&_curry_class } }; +#pod +#pod sub _curry_class { +#pod my ($class, $name) = @_; +#pod sub { $class->$name(@_); }; +#pod } +#pod +#pod Because of the way that exporters and Sub::Exporter work, any package that +#pod inherits from Data::Methodical can inherit its exporter and override its +#pod C. If a user imports C from that package, he'll +#pod receive a subroutine that calls the method on the subclass, rather than on +#pod Data::Methodical itself. Keep in mind that if you re-setup Sub::Exporter in a +#pod package that inherits from Data::Methodical you will, of course, be entirely +#pod replacing the exporter from Data::Methodical. C is a method, and is +#pod hidden by the same means as any other method. +#pod +#pod =head2 Other Customizations +#pod +#pod Building custom routines with generators isn't the only way that Sub::Exporters +#pod allows the importing code to refine its use of the exported routines. They may +#pod also be renamed to avoid naming collisions. +#pod +#pod Consider the following code: +#pod +#pod # this program determines to which circle of Hell you will be condemned +#pod use Morality qw(sin virtue); # for calculating viciousness +#pod use Math::Trig qw(:all); # for dealing with circles +#pod +#pod The programmer has inadvertently imported two C routines. The solution, +#pod in Exporter.pm-based modules, would be to import only one and then call the +#pod other by its fully-qualified name. Alternately, the importer could write a +#pod routine that did so, or could mess about with typeglobs. +#pod +#pod How much easier to write: +#pod +#pod # this program determines to which circle of Hell you will be condemned +#pod use Morality qw(virtue), sin => { -as => 'offense' }; +#pod use Math::Trig -all => { -prefix => 'trig_' }; +#pod +#pod and to have at one's disposal C and C -- not to mention +#pod C and C. +#pod +#pod =head1 EXPORTER CONFIGURATION +#pod +#pod You can configure an exporter for your package by using Sub::Exporter like so: +#pod +#pod package Tools; +#pod use Sub::Exporter +#pod -setup => { exports => [ qw(function1 function2 function3) ] }; +#pod +#pod This is the simplest way to use the exporter, and is basically equivalent to +#pod this: +#pod +#pod package Tools; +#pod use base qw(Exporter); +#pod our @EXPORT_OK = qw(function1 function2 function3); +#pod +#pod Any basic use of Sub::Exporter will look like this: +#pod +#pod package Tools; +#pod use Sub::Exporter -setup => \%config; +#pod +#pod The following keys are valid in C<%config>: +#pod +#pod exports - a list of routines to provide for exporting; each routine may be +#pod followed by generator +#pod groups - a list of groups to provide for exporting; each must be followed by +#pod either (a) a list of exports, possibly with arguments for each +#pod export, or (b) a generator +#pod +#pod collectors - a list of names into which values are collected for use in +#pod routine generation; each name may be followed by a validator +#pod +#pod In addition to the basic options above, a few more advanced options may be +#pod passed: +#pod +#pod into_level - how far up the caller stack to look for a target (default 0) +#pod into - an explicit target (package) into which to export routines +#pod +#pod In other words: Sub::Exporter installs a C routine which, when called, +#pod exports routines to the calling namespace. The C and C +#pod options change where those exported routines are installed. +#pod +#pod generator - a callback used to produce the code that will be installed +#pod default: Sub::Exporter::default_generator +#pod +#pod installer - a callback used to install the code produced by the generator +#pod default: Sub::Exporter::default_installer +#pod +#pod For information on how these callbacks are used, see the documentation for +#pod C> and C>. +#pod +#pod =head2 Export Configuration +#pod +#pod The C list may be provided as an array reference or a hash reference. +#pod The list is processed in such a way that the following are equivalent: +#pod +#pod { exports => [ qw(foo bar baz), quux => \&quux_generator ] } +#pod +#pod { exports => +#pod { foo => undef, bar => undef, baz => undef, quux => \&quux_generator } } +#pod +#pod Generators are code that return coderefs. They are called with four +#pod parameters: +#pod +#pod $class - the class whose exporter has been called (the exporting class) +#pod $name - the name of the export for which the routine is being build +#pod \%arg - the arguments passed for this export +#pod \%col - the collections for this import +#pod +#pod Given the configuration in the L, the following C statement: +#pod +#pod use Text::Tweaker +#pod reformat => { -as => 'make_narrow', width => 33 }, +#pod defaults => { eol => 'CR' }; +#pod +#pod would result in the following call to C<&build_reformatter>: +#pod +#pod my $code = build_reformatter( +#pod 'Text::Tweaker', +#pod 'reformat', +#pod { width => 33 }, # note that -as is not passed in +#pod { defaults => { eol => 'CR' } }, +#pod ); +#pod +#pod The returned coderef (C<$code>) would then be installed as C in the +#pod calling package. +#pod +#pod Instead of providing a coderef in the configuration, a reference to a method +#pod name may be provided. This method will then be called on the invocant of the +#pod C method. (In this case, we do not pass the C<$class> parameter, as it +#pod would be redundant.) +#pod +#pod =head2 Group Configuration +#pod +#pod The C list can be passed in the same forms as C. Groups must +#pod have values to be meaningful, which may either list exports that make up the +#pod group (optionally with arguments) or may provide a way to build the group. +#pod +#pod The simpler case is the first: a group definition is a list of exports. Here's +#pod the example that could go in exporter in the L. +#pod +#pod groups => { +#pod default => [ qw(reformat) ], +#pod shorteners => [ qw(squish trim) ], +#pod email_safe => [ +#pod 'indent', +#pod reformat => { -as => 'email_format', width => 72 } +#pod ], +#pod }, +#pod +#pod Groups are imported by specifying their name prefixed be either a dash or a +#pod colon. This line of code would import the C group: +#pod +#pod use Text::Tweaker qw(-shorteners); +#pod +#pod Arguments passed to a group when importing are merged into the groups options +#pod and passed to any relevant generators. Groups can contain other groups, but +#pod looping group structures are ignored. +#pod +#pod The other possible value for a group definition, a coderef, allows one +#pod generator to build several exportable routines simultaneously. This is useful +#pod when many routines must share enclosed lexical variables. The coderef must +#pod return a hash reference. The keys will be used as export names and the values +#pod are the subs that will be exported. +#pod +#pod This example shows a simple use of the group generator. +#pod +#pod package Data::Crypto; +#pod use Sub::Exporter -setup => { groups => { cipher => \&build_cipher_group } }; +#pod +#pod sub build_cipher_group { +#pod my ($class, $group, $arg) = @_; +#pod my ($encode, $decode) = build_codec($arg->{secret}); +#pod return { cipher => $encode, decipher => $decode }; +#pod } +#pod +#pod The C and C routines are built in a group because they are +#pod built together by code which encloses their secret in their environment. +#pod +#pod =head3 Default Groups +#pod +#pod If a module that uses Sub::Exporter is Cd with no arguments, it will try +#pod to export the group named C. If that group has not been specifically +#pod configured, it will be empty, and nothing will happen. +#pod +#pod Another group is also created if not defined: C. The C group +#pod contains all the exports from the exports list. +#pod +#pod =head2 Collector Configuration +#pod +#pod The C entry in the exporter configuration gives names which, when +#pod found in the import call, have their values collected and passed to every +#pod generator. +#pod +#pod For example, the C generator that we saw above could be +#pod rewritten as: +#pod +#pod sub build_analyzer { +#pod my ($class, $name, $arg, $col) = @_; +#pod +#pod return sub { +#pod my $data = shift; +#pod my $tolerance = shift || $arg->{tolerance} || $col->{defaults}{tolerance}; +#pod my $passes = shift || $arg->{passes} || $col->{defaults}{passes}; +#pod +#pod analyze($data, $tolerance, $passes); +#pod } +#pod } +#pod +#pod That would allow the importer to specify global defaults for his imports: +#pod +#pod use Data::Analyze +#pod 'analyze', +#pod analyze => { tolerance => 0.10, -as => analyze10 }, +#pod analyze => { tolerance => 0.15, passes => 50, -as => analyze50 }, +#pod defaults => { passes => 10 }; +#pod +#pod my $A = analyze10($data); # equivalent to analyze($data, 0.10, 10); +#pod my $C = analyze50($data); # equivalent to analyze($data, 0.15, 50); +#pod my $B = analyze($data, 0.20); # equivalent to analyze($data, 0.20, 10); +#pod +#pod If values are provided in the C list during exporter setup, they +#pod must be code references, and are used to validate the importer's values. The +#pod validator is called when the collection is found, and if it returns false, an +#pod exception is thrown. We could ensure that no one tries to set a global data +#pod default easily: +#pod +#pod collectors => { defaults => sub { return (exists $_[0]->{data}) ? 0 : 1 } } +#pod +#pod Collector coderefs can also be used as hooks to perform arbitrary actions +#pod before anything is exported. +#pod +#pod When the coderef is called, it is passed the value of the collection and a +#pod hashref containing the following entries: +#pod +#pod name - the name of the collector +#pod config - the exporter configuration (hashref) +#pod import_args - the arguments passed to the exporter, sans collections (aref) +#pod class - the package on which the importer was called +#pod into - the package into which exports will be exported +#pod +#pod Collectors with all-caps names (that is, made up of underscore or capital A +#pod through Z) are reserved for special use. The only currently implemented +#pod special collector is C, whose hook (if present in the exporter +#pod configuration) is always run before any other hook. +#pod +#pod =head1 CALLING THE EXPORTER +#pod +#pod Arguments to the exporter (that is, the arguments after the module name in a +#pod C statement) are parsed as follows: +#pod +#pod First, the collectors gather any collections found in the arguments. Any +#pod reference type may be given as the value for a collector. For each collection +#pod given in the arguments, its validator (if any) is called. +#pod +#pod Next, groups are expanded. If the group is implemented by a group generator, +#pod the generator is called. There are two special arguments which, if given to a +#pod group, have special meaning: +#pod +#pod -prefix - a string to prepend to any export imported from this group +#pod -suffix - a string to append to any export imported from this group +#pod +#pod Finally, individual export generators are called and all subs, generated or +#pod otherwise, are installed in the calling package. There is only one special +#pod argument for export generators: +#pod +#pod -as - where to install the exported sub +#pod +#pod Normally, C<-as> will contain an alternate name for the routine. It may, +#pod however, contain a reference to a scalar. If that is the case, a reference the +#pod generated routine will be placed in the scalar referenced by C<-as>. It will +#pod not be installed into the calling package. +#pod +#pod =head2 Special Exporter Arguments +#pod +#pod The generated exporter accept some special options, which may be passed as the +#pod first argument, in a hashref. +#pod +#pod These options are: +#pod +#pod into_level +#pod into +#pod generator +#pod installer +#pod +#pod These override the same-named configuration options described in L. +#pod +#pod =cut + +# Given a potential import name, this returns the group name -- if it's got a +# group prefix. +sub _group_name { + my ($name) = @_; + + return if (index q{-:}, (substr $name, 0, 1)) == -1; + return substr $name, 1; +} + +# \@groups is a canonicalized opt list of exports and groups this returns +# another canonicalized opt list with groups replaced with relevant exports. +# \%seen is groups we've already expanded and can ignore. +# \%merge is merged options from the group we're descending through. +sub _expand_groups { + my ($class, $config, $groups, $collection, $seen, $merge) = @_; + $seen ||= {}; + $merge ||= {}; + my @groups = @$groups; + + for my $i (reverse 0 .. $#groups) { + if (my $group_name = _group_name($groups[$i][0])) { + my $seen = { %$seen }; # faux-dynamic scoping + + splice @groups, $i, 1, + _expand_group($class, $config, $groups[$i], $collection, $seen, $merge); + } else { + # there's nothing to munge in this export's args + next unless my %merge = %$merge; + + # we have things to merge in; do so + my $prefix = (delete $merge{-prefix}) || ''; + my $suffix = (delete $merge{-suffix}) || ''; + + if ( + Params::Util::_CODELIKE($groups[$i][1]) ## no critic Private + or + Params::Util::_SCALAR0($groups[$i][1]) ## no critic Private + ) { + # this entry was build by a group generator + $groups[$i][0] = $prefix . $groups[$i][0] . $suffix; + } else { + my $as + = ref $groups[$i][1]{-as} ? $groups[$i][1]{-as} + : $groups[$i][1]{-as} ? $prefix . $groups[$i][1]{-as} . $suffix + : $prefix . $groups[$i][0] . $suffix; + + $groups[$i][1] = { %{ $groups[$i][1] }, %merge, -as => $as }; + } + } + } + + return \@groups; +} + +# \@group is a name/value pair from an opt list. +sub _expand_group { + my ($class, $config, $group, $collection, $seen, $merge) = @_; + $merge ||= {}; + + my ($group_name, $group_arg) = @$group; + $group_name = _group_name($group_name); + + Carp::croak qq(group "$group_name" is not exported by the $class module) + unless exists $config->{groups}{$group_name}; + + return if $seen->{$group_name}++; + + if (ref $group_arg) { + my $prefix = (delete $merge->{-prefix}||'') . ($group_arg->{-prefix}||''); + my $suffix = ($group_arg->{-suffix}||'') . (delete $merge->{-suffix}||''); + $merge = { + %$merge, + %$group_arg, + ($prefix ? (-prefix => $prefix) : ()), + ($suffix ? (-suffix => $suffix) : ()), + }; + } + + my $exports = $config->{groups}{$group_name}; + + if ( + Params::Util::_CODELIKE($exports) ## no critic Private + or + Params::Util::_SCALAR0($exports) ## no critic Private + ) { + # I'm not very happy with this code for hiding -prefix and -suffix, but + # it's needed, and I'm not sure, offhand, how to make it better. + # -- rjbs, 2006-12-05 + my $group_arg = $merge ? { %$merge } : {}; + delete $group_arg->{-prefix}; + delete $group_arg->{-suffix}; + + my $group = Params::Util::_CODELIKE($exports) ## no critic Private + ? $exports->($class, $group_name, $group_arg, $collection) + : $class->$$exports($group_name, $group_arg, $collection); + + Carp::croak qq(group generator "$group_name" did not return a hashref) + if ref $group ne 'HASH'; + + my $stuff = [ map { [ $_ => $group->{$_} ] } keys %$group ]; + return @{ + _expand_groups($class, $config, $stuff, $collection, $seen, $merge) + }; + } else { + $exports + = Data::OptList::mkopt($exports, "$group_name exports"); + + return @{ + _expand_groups($class, $config, $exports, $collection, $seen, $merge) + }; + } +} + +sub _mk_collection_builder { + my ($col, $etc) = @_; + my ($config, $import_args, $class, $into) = @$etc; + + my %seen; + sub { + my ($collection) = @_; + my ($name, $value) = @$collection; + + Carp::croak "collection $name provided multiple times in import" + if $seen{ $name }++; + + if (ref(my $hook = $config->{collectors}{$name})) { + my $arg = { + name => $name, + config => $config, + import_args => $import_args, + class => $class, + into => $into, + }; + + my $error_msg = "collection $name failed validation"; + if (Params::Util::_SCALAR0($hook)) { ## no critic Private + Carp::croak $error_msg unless $class->$$hook($value, $arg); + } else { + Carp::croak $error_msg unless $hook->($value, $arg); + } + } + + $col->{ $name } = $value; + } +} + +# Given a config and pre-canonicalized importer args, remove collections from +# the args and return them. +sub _collect_collections { + my ($config, $import_args, $class, $into) = @_; + + my @collections + = map { splice @$import_args, $_, 1 } + grep { exists $config->{collectors}{ $import_args->[$_][0] } } + reverse 0 .. $#$import_args; + + unshift @collections, [ INIT => {} ] if $config->{collectors}{INIT}; + + my $col = {}; + my $builder = _mk_collection_builder($col, \@_); + for my $collection (@collections) { + $builder->($collection) + } + + return $col; +} + +#pod =head1 SUBROUTINES +#pod +#pod =head2 setup_exporter +#pod +#pod This routine builds and installs an C routine. It is called with one +#pod argument, a hashref containing the exporter configuration. Using this, it +#pod builds an exporter and installs it into the calling package with the name +#pod "import." In addition to the normal exporter configuration, a few named +#pod arguments may be passed in the hashref: +#pod +#pod into - into what package should the exporter be installed +#pod into_level - into what level up the stack should the exporter be installed +#pod as - what name should the installed exporter be given +#pod +#pod By default the exporter is installed with the name C into the immediate +#pod caller of C. In other words, if your package calls +#pod C without providing any of the three above arguments, it will +#pod have an C routine installed. +#pod +#pod Providing both C and C will cause an exception to be thrown. +#pod +#pod The exporter is built by C>. +#pod +#pod =cut + +sub setup_exporter { + my ($config) = @_; + + Carp::croak 'into and into_level may not both be supplied to exporter' + if exists $config->{into} and exists $config->{into_level}; + + my $as = delete $config->{as} || 'import'; + my $into + = exists $config->{into} ? delete $config->{into} + : exists $config->{into_level} ? caller(delete $config->{into_level}) + : caller(0); + + my $import = build_exporter($config); + + Sub::Install::reinstall_sub({ + code => $import, + into => $into, + as => $as, + }); +} + +#pod =head2 build_exporter +#pod +#pod Given a standard exporter configuration, this routine builds and returns an +#pod exporter -- that is, a subroutine that can be installed as a class method to +#pod perform exporting on request. +#pod +#pod Usually, this method is called by C>, which then installs +#pod the exporter as a package's import routine. +#pod +#pod =cut + +sub _key_intersection { + my ($x, $y) = @_; + my %seen = map { $_ => 1 } keys %$x; + my @names = grep { $seen{$_} } keys %$y; +} + +# Given the config passed to setup_exporter, which contains sugary opt list +# data, rewrite the opt lists into hashes, catch a few kinds of invalid +# configurations, and set up defaults. Since the config is a reference, it's +# rewritten in place. +my %valid_config_key; +BEGIN { + %valid_config_key = + map { $_ => 1 } + qw(as collectors installer generator exports groups into into_level), + qw(exporter), # deprecated +} + +sub _assert_collector_names_ok { + my ($collectors) = @_; + + for my $reserved_name (grep { /\A[_A-Z]+\z/ } keys %$collectors) { + Carp::croak "unknown reserved collector name: $reserved_name" + if $reserved_name ne 'INIT'; + } +} + +sub _rewrite_build_config { + my ($config) = @_; + + if (my @keys = grep { not exists $valid_config_key{$_} } keys %$config) { + Carp::croak "unknown options (@keys) passed to Sub::Exporter"; + } + + Carp::croak q(into and into_level may not both be supplied to exporter) + if exists $config->{into} and exists $config->{into_level}; + + # XXX: Remove after deprecation period. + if ($config->{exporter}) { + Carp::cluck "'exporter' argument to build_exporter is deprecated. Use 'installer' instead; the semantics are identical."; + $config->{installer} = delete $config->{exporter}; + } + + Carp::croak q(into and into_level may not both be supplied to exporter) + if exists $config->{into} and exists $config->{into_level}; + + for (qw(exports collectors)) { + $config->{$_} = Data::OptList::mkopt_hash( + $config->{$_}, + $_, + [ 'CODE', 'SCALAR' ], + ); + } + + _assert_collector_names_ok($config->{collectors}); + + if (my @names = _key_intersection(@$config{qw(exports collectors)})) { + Carp::croak "names (@names) used in both collections and exports"; + } + + $config->{groups} = Data::OptList::mkopt_hash( + $config->{groups}, + 'groups', + [ + 'HASH', # standard opt list + 'ARRAY', # standard opt list + 'CODE', # group generator + 'SCALAR', # name of group generation method + ] + ); + + # by default, export nothing + $config->{groups}{default} ||= []; + + # by default, build an all-inclusive 'all' group + $config->{groups}{all} ||= [ keys %{ $config->{exports} } ]; + + $config->{generator} ||= \&default_generator; + $config->{installer} ||= \&default_installer; +} + +sub build_exporter { + my ($config) = @_; + + _rewrite_build_config($config); + + my $import = sub { + my ($class) = shift; + + # XXX: clean this up -- rjbs, 2006-03-16 + my $special = (ref $_[0]) ? shift(@_) : {}; + Carp::croak q(into and into_level may not both be supplied to exporter) + if exists $special->{into} and exists $special->{into_level}; + + if ($special->{exporter}) { + Carp::cluck "'exporter' special import argument is deprecated. Use 'installer' instead; the semantics are identical."; + $special->{installer} = delete $special->{exporter}; + } + + my $into + = defined $special->{into} ? delete $special->{into} + : defined $special->{into_level} ? caller(delete $special->{into_level}) + : defined $config->{into} ? $config->{into} + : defined $config->{into_level} ? caller($config->{into_level}) + : caller(0); + + my $generator = delete $special->{generator} || $config->{generator}; + my $installer = delete $special->{installer} || $config->{installer}; + + # this builds a AOA, where the inner arrays are [ name => value_ref ] + my $import_args = Data::OptList::mkopt([ @_ ]); + + # is this right? defaults first or collectors first? -- rjbs, 2006-06-24 + $import_args = [ [ -default => undef ] ] unless @$import_args; + + my $collection = _collect_collections($config, $import_args, $class, $into); + + my $to_import = _expand_groups($class, $config, $import_args, $collection); + + # now, finally $import_arg is really the "to do" list + _do_import( + { + class => $class, + col => $collection, + config => $config, + into => $into, + generator => $generator, + installer => $installer, + }, + $to_import, + ); + }; + + return $import; +} + +sub _do_import { + my ($arg, $to_import) = @_; + + my @todo; + + for my $pair (@$to_import) { + my ($name, $import_arg) = @$pair; + + my ($generator, $as); + + if ($import_arg and Params::Util::_CODELIKE($import_arg)) { ## no critic + # This is the case when a group generator has inserted name/code pairs. + $generator = sub { $import_arg }; + $as = $name; + } else { + $import_arg = { $import_arg ? %$import_arg : () }; + + Carp::croak qq("$name" is not exported by the $arg->{class} module) + unless exists $arg->{config}{exports}{$name}; + + $generator = $arg->{config}{exports}{$name}; + + $as = exists $import_arg->{-as} ? (delete $import_arg->{-as}) : $name; + } + + my $code = $arg->{generator}->( + { + class => $arg->{class}, + name => $name, + arg => $import_arg, + col => $arg->{col}, + generator => $generator, + } + ); + + push @todo, $as, $code; + } + + $arg->{installer}->( + { + class => $arg->{class}, + into => $arg->{into}, + col => $arg->{col}, + }, + \@todo, + ); +} + +## Cute idea, possibly for future use: also supply an "unimport" for: +## no Module::Whatever qw(arg arg arg); +# sub _unexport { +# my (undef, undef, undef, undef, undef, $as, $into) = @_; +# +# if (ref $as eq 'SCALAR') { +# undef $$as; +# } elsif (ref $as) { +# Carp::croak "invalid reference type for $as: " . ref $as; +# } else { +# no strict 'refs'; +# delete &{$into . '::' . $as}; +# } +# } + +#pod =head2 default_generator +#pod +#pod This is Sub::Exporter's default generator. It takes bits of configuration that +#pod have been gathered during the import and turns them into a coderef that can be +#pod installed. +#pod +#pod my $code = default_generator(\%arg); +#pod +#pod Passed arguments are: +#pod +#pod class - the class on which the import method was called +#pod name - the name of the export being generated +#pod arg - the arguments to the generator +#pod col - the collections +#pod +#pod generator - the generator to be used to build the export (code or scalar ref) +#pod +#pod =cut + +sub default_generator { + my ($arg) = @_; + my ($class, $name, $generator) = @$arg{qw(class name generator)}; + + if (not defined $generator) { + my $code = $class->can($name) + or Carp::croak "can't locate exported subroutine $name via $class"; + return $code; + } + + # I considered making this "$class->$generator(" but it seems that + # overloading precedence would turn an overloaded-as-code generator object + # into a string before code. -- rjbs, 2006-06-11 + return $generator->($class, $name, $arg->{arg}, $arg->{col}) + if Params::Util::_CODELIKE($generator); ## no critic Private + + # This "must" be a scalar reference, to a generator method name. + # -- rjbs, 2006-12-05 + return $class->$$generator($name, $arg->{arg}, $arg->{col}); +} + +#pod =head2 default_installer +#pod +#pod This is Sub::Exporter's default installer. It does what Sub::Exporter +#pod promises: it installs code into the target package. +#pod +#pod default_installer(\%arg, \@to_export); +#pod +#pod Passed arguments are: +#pod +#pod into - the package into which exports should be delivered +#pod +#pod C<@to_export> is a list of name/value pairs. The default exporter assigns code +#pod (the values) to named slots (the names) in the given package. If the name is a +#pod scalar reference, the scalar reference is made to point to the code reference +#pod instead. +#pod +#pod =cut + +sub default_installer { + my ($arg, $to_export) = @_; + + for (my $i = 0; $i < @$to_export; $i += 2) { + my ($as, $code) = @$to_export[ $i, $i+1 ]; + + # Allow as isa ARRAY to push onto an array? + # Allow into isa HASH to install name=>code into hash? + + if (ref $as eq 'SCALAR') { + $$as = $code; + } elsif (ref $as) { + Carp::croak "invalid reference type for $as: " . ref $as; + } else { + Sub::Install::reinstall_sub({ + code => $code, + into => $arg->{into}, + as => $as + }); + } + } +} + +sub default_exporter { + Carp::cluck "default_exporter is deprecated; call default_installer instead; the semantics are identical"; + goto &default_installer; +} + +#pod =head1 EXPORTS +#pod +#pod Sub::Exporter also offers its own exports: the C and +#pod C routines described above. It also provides a special "setup" +#pod collector, which will set up an exporter using the parameters passed to it. +#pod +#pod Note that the "setup" collector (seen in examples like the L above) +#pod uses C, not C. This means that the special +#pod arguments like "into" and "as" for C are not accepted here. +#pod Instead, you may write something like: +#pod +#pod use Sub::Exporter +#pod { into => 'Target::Package' }, +#pod -setup => { +#pod -as => 'do_import', +#pod exports => [ ... ], +#pod } +#pod ; +#pod +#pod Finding a good reason for wanting to do this is left as an exercise for the +#pod reader. +#pod +#pod =cut + +setup_exporter({ + exports => [ + qw(setup_exporter build_exporter), + _import => sub { build_exporter($_[2]) }, + ], + groups => { + all => [ qw(setup_exporter build_export) ], + }, + collectors => { -setup => \&_setup }, +}); + +sub _setup { + my ($value, $arg) = @_; + + if (ref $value eq 'HASH') { + push @{ $arg->{import_args} }, [ _import => { -as => 'import', %$value } ]; + return 1; + } elsif (ref $value eq 'ARRAY') { + push @{ $arg->{import_args} }, + [ _import => { -as => 'import', exports => $value } ]; + return 1; + } + return; +} + +#pod =head1 COMPARISONS +#pod +#pod There are a whole mess of exporters on the CPAN. The features included in +#pod Sub::Exporter set it apart from any existing Exporter. Here's a summary of +#pod some other exporters and how they compare. +#pod +#pod =over +#pod +#pod =item * L and co. +#pod +#pod This is the standard Perl exporter. Its interface is a little clunky, but it's +#pod fast and ubiquitous. It can do some things that Sub::Exporter can't: it can +#pod export things other than routines, it can import "everything in this group +#pod except this symbol," and some other more esoteric things. These features seem +#pod to go nearly entirely unused. +#pod +#pod It always exports things exactly as they appear in the exporting module; it +#pod can't rename or customize routines. Its groups ("tags") can't be nested. +#pod +#pod L is a whole lot like Exporter, but it does significantly less: +#pod it supports exporting symbols, but not groups, pattern matching, or negation. +#pod +#pod The fact that Sub::Exporter can't export symbols other than subroutines is +#pod a good idea, not a missing feature. +#pod +#pod For simple uses, setting up Sub::Exporter is about as easy as Exporter. For +#pod complex uses, Sub::Exporter makes hard things possible, which would not be +#pod possible with Exporter. +#pod +#pod When using a module that uses Sub::Exporter, users familiar with Exporter will +#pod probably see no difference in the basics. These two lines do about the same +#pod thing in whether the exporting module uses Exporter or Sub::Exporter. +#pod +#pod use Some::Module qw(foo bar baz); +#pod use Some::Module qw(foo :bar baz); +#pod +#pod The definition for exporting in Exporter.pm might look like this: +#pod +#pod package Some::Module; +#pod use base qw(Exporter); +#pod our @EXPORT_OK = qw(foo bar baz quux); +#pod our %EXPORT_TAGS = (bar => [ qw(bar baz) ]); +#pod +#pod Using Sub::Exporter, it would look like this: +#pod +#pod package Some::Module; +#pod use Sub::Exporter -setup => { +#pod exports => [ qw(foo bar baz quux) ], +#pod groups => { bar => [ qw(bar baz) ]} +#pod }; +#pod +#pod Sub::Exporter respects inheritance, so that a package may export inherited +#pod routines, and will export the most inherited version. Exporting methods +#pod without currying away the invocant is a bad idea, but Sub::Exporter allows you +#pod to do just that -- and anyway, there are other uses for this feature, like +#pod packages of exported subroutines which use inheritance specifically to allow +#pod more specialized, but similar, packages. +#pod +#pod L provides a wrapper around the standard Exporter. It makes it +#pod simpler to build groups, but doesn't provide any more functionality. Because +#pod it is a front-end to Exporter, it will store your exporter's configuration in +#pod global package variables. +#pod +#pod =item * Attribute-Based Exporters +#pod +#pod Some exporters use attributes to mark variables to export. L +#pod supports exporting any kind of symbol, and supports groups. Using a module +#pod like Exporter or Sub::Exporter, it's easy to look at one place and see what is +#pod exported, but it's impossible to look at a variable definition and see whether +#pod it is exported by that alone. Exporter::Simple makes this trade in reverse: +#pod each variable's declaration includes its export definition, but there is no one +#pod place to look to find a manifest of exports. +#pod +#pod More importantly, Exporter::Simple does not add any new features to those of +#pod Exporter. In fact, like Exporter::Easy, it is just a front-end to Exporter, so +#pod it ends up storing its configuration in global package variables. (This means +#pod that there is one place to look for your exporter's manifest, actually. You +#pod can inspect the C<@EXPORT> package variables, and other related package +#pod variables, at runtime.) +#pod +#pod L isn't actually attribute based, but looks similar. Its syntax +#pod is borrowed from Perl 6, and implemented by a source filter. It is a prototype +#pod of an interface that is still being designed. It should probably be avoided +#pod for production work. On the other hand, L implements +#pod Perl 6-like exporting, but translates it into Perl 5 by providing attributes. +#pod +#pod =item * Other Exporters +#pod +#pod L wraps the standard Exporter to allow it to export symbols +#pod with changed names. +#pod +#pod L performs a special kind of routine generation, giving each +#pod importing package an instance of your class, and then exporting the instance's +#pod methods as normal routines. (Sub::Exporter, of course, can easily emulate this +#pod behavior, as shown above.) +#pod +#pod L implements a form of renaming (using its C<_map> argument) +#pod and of prefixing, and implements groups. It also avoids using package +#pod variables for its configuration. +#pod +#pod =back +#pod +#pod =head1 TODO +#pod +#pod =cut + +#pod =over +#pod +#pod =item * write a set of longer, more demonstrative examples +#pod +#pod =item * solidify the "custom exporter" interface (see C<&default_exporter>) +#pod +#pod =item * add an "always" group +#pod +#pod =back +#pod +#pod =head1 THANKS +#pod +#pod Hans Dieter Pearcey provided helpful advice while I was writing Sub::Exporter. +#pod Ian Langworth and Shawn Sorichetti asked some good questions and helped me +#pod improve my documentation quite a bit. Yuval Kogman helped me find a bunch of +#pod little problems. +#pod +#pod Thanks, friends! +#pod +#pod =head1 BUGS +#pod +#pod Please report any bugs or feature requests through the web interface at +#pod L. I will be notified, and then you'll automatically be +#pod notified of progress on your bug as I make changes. +#pod +#pod =cut + +"jn8:32"; # <-- magic true value + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sub::Exporter - a sophisticated exporter for custom-built routines + +=head1 VERSION + +version 0.991 + +=head1 SYNOPSIS + +Sub::Exporter must be used in two places. First, in an exporting module: + + # in the exporting module: + package Text::Tweaker; + use Sub::Exporter -setup => { + exports => [ + qw(squish titlecase), # always works the same way + reformat => \&build_reformatter, # generator to build exported function + trim => \&build_trimmer, + indent => \&build_indenter, + ], + collectors => [ 'defaults' ], + }; + +Then, in an importing module: + + # in the importing module: + use Text::Tweaker + 'squish', + indent => { margin => 5 }, + reformat => { width => 79, justify => 'full', -as => 'prettify_text' }, + defaults => { eol => 'CRLF' }; + +With this setup, the importing module ends up with three routines: C, +C, and C. The latter two have been built to the +specifications of the importer -- they are not just copies of the code in the +exporting package. + +=head1 DESCRIPTION + +B If you're not familiar with Exporter or exporting, read +L first! + +=head2 Why Generators? + +The biggest benefit of Sub::Exporter over existing exporters (including the +ubiquitous Exporter.pm) is its ability to build new coderefs for export, rather +than to simply export code identical to that found in the exporting package. + +If your module's consumers get a routine that works like this: + + use Data::Analyze qw(analyze); + my $value = analyze($data, $tolerance, $passes); + +and they constantly pass only one or two different set of values for the +non-C<$data> arguments, your code can benefit from Sub::Exporter. By writing a +simple generator, you can let them do this, instead: + + use Data::Analyze + analyze => { tolerance => 0.10, passes => 10, -as => analyze10 }, + analyze => { tolerance => 0.15, passes => 50, -as => analyze50 }; + + my $value = analyze10($data); + +The package with the generator for that would look something like this: + + package Data::Analyze; + use Sub::Exporter -setup => { + exports => [ + analyze => \&build_analyzer, + ], + }; + + sub build_analyzer { + my ($class, $name, $arg) = @_; + + return sub { + my $data = shift; + my $tolerance = shift || $arg->{tolerance}; + my $passes = shift || $arg->{passes}; + + analyze($data, $tolerance, $passes); + } + } + +Your module's user now has to do less work to benefit from it -- and remember, +you're often your own user! Investing in customized subroutines is an +investment in future laziness. + +This also avoids a common form of ugliness seen in many modules: package-level +configuration. That is, you might have seen something like the above +implemented like so: + + use Data::Analyze qw(analyze); + $Data::Analyze::default_tolerance = 0.10; + $Data::Analyze::default_passes = 10; + +This might save time, until you have multiple modules using Data::Analyze. +Because there is only one global configuration, they step on each other's toes +and your code begins to have mysterious errors. + +Generators can also allow you to export class methods to be called as +subroutines: + + package Data::Methodical; + use Sub::Exporter -setup => { exports => { some_method => \&_curry_class } }; + + sub _curry_class { + my ($class, $name) = @_; + sub { $class->$name(@_); }; + } + +Because of the way that exporters and Sub::Exporter work, any package that +inherits from Data::Methodical can inherit its exporter and override its +C. If a user imports C from that package, he'll +receive a subroutine that calls the method on the subclass, rather than on +Data::Methodical itself. Keep in mind that if you re-setup Sub::Exporter in a +package that inherits from Data::Methodical you will, of course, be entirely +replacing the exporter from Data::Methodical. C is a method, and is +hidden by the same means as any other method. + +=head2 Other Customizations + +Building custom routines with generators isn't the only way that Sub::Exporters +allows the importing code to refine its use of the exported routines. They may +also be renamed to avoid naming collisions. + +Consider the following code: + + # this program determines to which circle of Hell you will be condemned + use Morality qw(sin virtue); # for calculating viciousness + use Math::Trig qw(:all); # for dealing with circles + +The programmer has inadvertently imported two C routines. The solution, +in Exporter.pm-based modules, would be to import only one and then call the +other by its fully-qualified name. Alternately, the importer could write a +routine that did so, or could mess about with typeglobs. + +How much easier to write: + + # this program determines to which circle of Hell you will be condemned + use Morality qw(virtue), sin => { -as => 'offense' }; + use Math::Trig -all => { -prefix => 'trig_' }; + +and to have at one's disposal C and C -- not to mention +C and C. + +=head1 PERL VERSION + +This library should run on perls released even a long time ago. It should +work on any version of perl released in the last five years. + +Although it may work on older versions of perl, no guarantee is made that the +minimum required version will not be increased. The version may be increased +for any reason, and there is no promise that patches will be accepted to +lower the minimum required perl. + +=head1 EXPORTER CONFIGURATION + +You can configure an exporter for your package by using Sub::Exporter like so: + + package Tools; + use Sub::Exporter + -setup => { exports => [ qw(function1 function2 function3) ] }; + +This is the simplest way to use the exporter, and is basically equivalent to +this: + + package Tools; + use base qw(Exporter); + our @EXPORT_OK = qw(function1 function2 function3); + +Any basic use of Sub::Exporter will look like this: + + package Tools; + use Sub::Exporter -setup => \%config; + +The following keys are valid in C<%config>: + + exports - a list of routines to provide for exporting; each routine may be + followed by generator + groups - a list of groups to provide for exporting; each must be followed by + either (a) a list of exports, possibly with arguments for each + export, or (b) a generator + + collectors - a list of names into which values are collected for use in + routine generation; each name may be followed by a validator + +In addition to the basic options above, a few more advanced options may be +passed: + + into_level - how far up the caller stack to look for a target (default 0) + into - an explicit target (package) into which to export routines + +In other words: Sub::Exporter installs a C routine which, when called, +exports routines to the calling namespace. The C and C +options change where those exported routines are installed. + + generator - a callback used to produce the code that will be installed + default: Sub::Exporter::default_generator + + installer - a callback used to install the code produced by the generator + default: Sub::Exporter::default_installer + +For information on how these callbacks are used, see the documentation for +C> and C>. + +=head2 Export Configuration + +The C list may be provided as an array reference or a hash reference. +The list is processed in such a way that the following are equivalent: + + { exports => [ qw(foo bar baz), quux => \&quux_generator ] } + + { exports => + { foo => undef, bar => undef, baz => undef, quux => \&quux_generator } } + +Generators are code that return coderefs. They are called with four +parameters: + + $class - the class whose exporter has been called (the exporting class) + $name - the name of the export for which the routine is being build + \%arg - the arguments passed for this export + \%col - the collections for this import + +Given the configuration in the L, the following C statement: + + use Text::Tweaker + reformat => { -as => 'make_narrow', width => 33 }, + defaults => { eol => 'CR' }; + +would result in the following call to C<&build_reformatter>: + + my $code = build_reformatter( + 'Text::Tweaker', + 'reformat', + { width => 33 }, # note that -as is not passed in + { defaults => { eol => 'CR' } }, + ); + +The returned coderef (C<$code>) would then be installed as C in the +calling package. + +Instead of providing a coderef in the configuration, a reference to a method +name may be provided. This method will then be called on the invocant of the +C method. (In this case, we do not pass the C<$class> parameter, as it +would be redundant.) + +=head2 Group Configuration + +The C list can be passed in the same forms as C. Groups must +have values to be meaningful, which may either list exports that make up the +group (optionally with arguments) or may provide a way to build the group. + +The simpler case is the first: a group definition is a list of exports. Here's +the example that could go in exporter in the L. + + groups => { + default => [ qw(reformat) ], + shorteners => [ qw(squish trim) ], + email_safe => [ + 'indent', + reformat => { -as => 'email_format', width => 72 } + ], + }, + +Groups are imported by specifying their name prefixed be either a dash or a +colon. This line of code would import the C group: + + use Text::Tweaker qw(-shorteners); + +Arguments passed to a group when importing are merged into the groups options +and passed to any relevant generators. Groups can contain other groups, but +looping group structures are ignored. + +The other possible value for a group definition, a coderef, allows one +generator to build several exportable routines simultaneously. This is useful +when many routines must share enclosed lexical variables. The coderef must +return a hash reference. The keys will be used as export names and the values +are the subs that will be exported. + +This example shows a simple use of the group generator. + + package Data::Crypto; + use Sub::Exporter -setup => { groups => { cipher => \&build_cipher_group } }; + + sub build_cipher_group { + my ($class, $group, $arg) = @_; + my ($encode, $decode) = build_codec($arg->{secret}); + return { cipher => $encode, decipher => $decode }; + } + +The C and C routines are built in a group because they are +built together by code which encloses their secret in their environment. + +=head3 Default Groups + +If a module that uses Sub::Exporter is Cd with no arguments, it will try +to export the group named C. If that group has not been specifically +configured, it will be empty, and nothing will happen. + +Another group is also created if not defined: C. The C group +contains all the exports from the exports list. + +=head2 Collector Configuration + +The C entry in the exporter configuration gives names which, when +found in the import call, have their values collected and passed to every +generator. + +For example, the C generator that we saw above could be +rewritten as: + + sub build_analyzer { + my ($class, $name, $arg, $col) = @_; + + return sub { + my $data = shift; + my $tolerance = shift || $arg->{tolerance} || $col->{defaults}{tolerance}; + my $passes = shift || $arg->{passes} || $col->{defaults}{passes}; + + analyze($data, $tolerance, $passes); + } + } + +That would allow the importer to specify global defaults for his imports: + + use Data::Analyze + 'analyze', + analyze => { tolerance => 0.10, -as => analyze10 }, + analyze => { tolerance => 0.15, passes => 50, -as => analyze50 }, + defaults => { passes => 10 }; + + my $A = analyze10($data); # equivalent to analyze($data, 0.10, 10); + my $C = analyze50($data); # equivalent to analyze($data, 0.15, 50); + my $B = analyze($data, 0.20); # equivalent to analyze($data, 0.20, 10); + +If values are provided in the C list during exporter setup, they +must be code references, and are used to validate the importer's values. The +validator is called when the collection is found, and if it returns false, an +exception is thrown. We could ensure that no one tries to set a global data +default easily: + + collectors => { defaults => sub { return (exists $_[0]->{data}) ? 0 : 1 } } + +Collector coderefs can also be used as hooks to perform arbitrary actions +before anything is exported. + +When the coderef is called, it is passed the value of the collection and a +hashref containing the following entries: + + name - the name of the collector + config - the exporter configuration (hashref) + import_args - the arguments passed to the exporter, sans collections (aref) + class - the package on which the importer was called + into - the package into which exports will be exported + +Collectors with all-caps names (that is, made up of underscore or capital A +through Z) are reserved for special use. The only currently implemented +special collector is C, whose hook (if present in the exporter +configuration) is always run before any other hook. + +=head1 CALLING THE EXPORTER + +Arguments to the exporter (that is, the arguments after the module name in a +C statement) are parsed as follows: + +First, the collectors gather any collections found in the arguments. Any +reference type may be given as the value for a collector. For each collection +given in the arguments, its validator (if any) is called. + +Next, groups are expanded. If the group is implemented by a group generator, +the generator is called. There are two special arguments which, if given to a +group, have special meaning: + + -prefix - a string to prepend to any export imported from this group + -suffix - a string to append to any export imported from this group + +Finally, individual export generators are called and all subs, generated or +otherwise, are installed in the calling package. There is only one special +argument for export generators: + + -as - where to install the exported sub + +Normally, C<-as> will contain an alternate name for the routine. It may, +however, contain a reference to a scalar. If that is the case, a reference the +generated routine will be placed in the scalar referenced by C<-as>. It will +not be installed into the calling package. + +=head2 Special Exporter Arguments + +The generated exporter accept some special options, which may be passed as the +first argument, in a hashref. + +These options are: + + into_level + into + generator + installer + +These override the same-named configuration options described in L. + +=head1 SUBROUTINES + +=head2 setup_exporter + +This routine builds and installs an C routine. It is called with one +argument, a hashref containing the exporter configuration. Using this, it +builds an exporter and installs it into the calling package with the name +"import." In addition to the normal exporter configuration, a few named +arguments may be passed in the hashref: + + into - into what package should the exporter be installed + into_level - into what level up the stack should the exporter be installed + as - what name should the installed exporter be given + +By default the exporter is installed with the name C into the immediate +caller of C. In other words, if your package calls +C without providing any of the three above arguments, it will +have an C routine installed. + +Providing both C and C will cause an exception to be thrown. + +The exporter is built by C>. + +=head2 build_exporter + +Given a standard exporter configuration, this routine builds and returns an +exporter -- that is, a subroutine that can be installed as a class method to +perform exporting on request. + +Usually, this method is called by C>, which then installs +the exporter as a package's import routine. + +=head2 default_generator + +This is Sub::Exporter's default generator. It takes bits of configuration that +have been gathered during the import and turns them into a coderef that can be +installed. + + my $code = default_generator(\%arg); + +Passed arguments are: + + class - the class on which the import method was called + name - the name of the export being generated + arg - the arguments to the generator + col - the collections + + generator - the generator to be used to build the export (code or scalar ref) + +=head2 default_installer + +This is Sub::Exporter's default installer. It does what Sub::Exporter +promises: it installs code into the target package. + + default_installer(\%arg, \@to_export); + +Passed arguments are: + + into - the package into which exports should be delivered + +C<@to_export> is a list of name/value pairs. The default exporter assigns code +(the values) to named slots (the names) in the given package. If the name is a +scalar reference, the scalar reference is made to point to the code reference +instead. + +=head1 EXPORTS + +Sub::Exporter also offers its own exports: the C and +C routines described above. It also provides a special "setup" +collector, which will set up an exporter using the parameters passed to it. + +Note that the "setup" collector (seen in examples like the L above) +uses C, not C. This means that the special +arguments like "into" and "as" for C are not accepted here. +Instead, you may write something like: + + use Sub::Exporter + { into => 'Target::Package' }, + -setup => { + -as => 'do_import', + exports => [ ... ], + } + ; + +Finding a good reason for wanting to do this is left as an exercise for the +reader. + +=head1 COMPARISONS + +There are a whole mess of exporters on the CPAN. The features included in +Sub::Exporter set it apart from any existing Exporter. Here's a summary of +some other exporters and how they compare. + +=over + +=item * L and co. + +This is the standard Perl exporter. Its interface is a little clunky, but it's +fast and ubiquitous. It can do some things that Sub::Exporter can't: it can +export things other than routines, it can import "everything in this group +except this symbol," and some other more esoteric things. These features seem +to go nearly entirely unused. + +It always exports things exactly as they appear in the exporting module; it +can't rename or customize routines. Its groups ("tags") can't be nested. + +L is a whole lot like Exporter, but it does significantly less: +it supports exporting symbols, but not groups, pattern matching, or negation. + +The fact that Sub::Exporter can't export symbols other than subroutines is +a good idea, not a missing feature. + +For simple uses, setting up Sub::Exporter is about as easy as Exporter. For +complex uses, Sub::Exporter makes hard things possible, which would not be +possible with Exporter. + +When using a module that uses Sub::Exporter, users familiar with Exporter will +probably see no difference in the basics. These two lines do about the same +thing in whether the exporting module uses Exporter or Sub::Exporter. + + use Some::Module qw(foo bar baz); + use Some::Module qw(foo :bar baz); + +The definition for exporting in Exporter.pm might look like this: + + package Some::Module; + use base qw(Exporter); + our @EXPORT_OK = qw(foo bar baz quux); + our %EXPORT_TAGS = (bar => [ qw(bar baz) ]); + +Using Sub::Exporter, it would look like this: + + package Some::Module; + use Sub::Exporter -setup => { + exports => [ qw(foo bar baz quux) ], + groups => { bar => [ qw(bar baz) ]} + }; + +Sub::Exporter respects inheritance, so that a package may export inherited +routines, and will export the most inherited version. Exporting methods +without currying away the invocant is a bad idea, but Sub::Exporter allows you +to do just that -- and anyway, there are other uses for this feature, like +packages of exported subroutines which use inheritance specifically to allow +more specialized, but similar, packages. + +L provides a wrapper around the standard Exporter. It makes it +simpler to build groups, but doesn't provide any more functionality. Because +it is a front-end to Exporter, it will store your exporter's configuration in +global package variables. + +=item * Attribute-Based Exporters + +Some exporters use attributes to mark variables to export. L +supports exporting any kind of symbol, and supports groups. Using a module +like Exporter or Sub::Exporter, it's easy to look at one place and see what is +exported, but it's impossible to look at a variable definition and see whether +it is exported by that alone. Exporter::Simple makes this trade in reverse: +each variable's declaration includes its export definition, but there is no one +place to look to find a manifest of exports. + +More importantly, Exporter::Simple does not add any new features to those of +Exporter. In fact, like Exporter::Easy, it is just a front-end to Exporter, so +it ends up storing its configuration in global package variables. (This means +that there is one place to look for your exporter's manifest, actually. You +can inspect the C<@EXPORT> package variables, and other related package +variables, at runtime.) + +L isn't actually attribute based, but looks similar. Its syntax +is borrowed from Perl 6, and implemented by a source filter. It is a prototype +of an interface that is still being designed. It should probably be avoided +for production work. On the other hand, L implements +Perl 6-like exporting, but translates it into Perl 5 by providing attributes. + +=item * Other Exporters + +L wraps the standard Exporter to allow it to export symbols +with changed names. + +L performs a special kind of routine generation, giving each +importing package an instance of your class, and then exporting the instance's +methods as normal routines. (Sub::Exporter, of course, can easily emulate this +behavior, as shown above.) + +L implements a form of renaming (using its C<_map> argument) +and of prefixing, and implements groups. It also avoids using package +variables for its configuration. + +=back + +=head1 TODO + +=over + +=item * write a set of longer, more demonstrative examples + +=item * solidify the "custom exporter" interface (see C<&default_exporter>) + +=item * add an "always" group + +=back + +=head1 THANKS + +Hans Dieter Pearcey provided helpful advice while I was writing Sub::Exporter. +Ian Langworth and Shawn Sorichetti asked some good questions and helped me +improve my documentation quite a bit. Yuval Kogman helped me find a bunch of +little problems. + +Thanks, friends! + +=head1 BUGS + +Please report any bugs or feature requests through the web interface at +L. I will be notified, and then you'll automatically be +notified of progress on your bug as I make changes. + +=head1 AUTHOR + +Ricardo Signes + +=head1 CONTRIBUTORS + +=for stopwords David Steinbrunner everybody George Hartzell Hans Dieter Pearcey Karen Etheridge Ricardo Signes Yves Orton + +=over 4 + +=item * + +David Steinbrunner + +=item * + +everybody + +=item * + +George Hartzell + +=item * + +Hans Dieter Pearcey + +=item * + +Karen Etheridge + +=item * + +Ricardo Signes + +=item * + +Ricardo Signes + +=item * + +Yves Orton + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2007 by 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/src/main/perl/lib/Sub/Exporter/Progressive.pm b/src/main/perl/lib/Sub/Exporter/Progressive.pm new file mode 100644 index 000000000..2f1dd189d --- /dev/null +++ b/src/main/perl/lib/Sub/Exporter/Progressive.pm @@ -0,0 +1,174 @@ +package Sub::Exporter::Progressive; +$Sub::Exporter::Progressive::VERSION = '0.001013'; +use strict; +use warnings; + +# ABSTRACT: Only use Sub::Exporter if you need it + +sub _croak { + require Carp; + &Carp::croak; +} + +sub import { + my ($self, @args) = @_; + + my $inner_target = caller; + my $export_data = sub_export_options($inner_target, @args); + + my $full_exporter; + no strict 'refs'; + no warnings 'once'; + @{"${inner_target}::EXPORT_OK"} = @{$export_data->{exports}}; + @{"${inner_target}::EXPORT"} = @{$export_data->{defaults}}; + %{"${inner_target}::EXPORT_TAGS"} = %{$export_data->{tags}}; + *{"${inner_target}::import"} = sub { + use strict; + my ($self, @args) = @_; + + if ( grep { + length ref $_ + or + $_ !~ / \A [:-]? \w+ \z /xm + } @args ) { + _croak 'your usage of Sub::Exporter::Progressive requires Sub::Exporter to be installed' + unless eval { require Sub::Exporter }; + $full_exporter ||= Sub::Exporter::build_exporter($export_data->{original}); + + goto $full_exporter; + } elsif ( defined( (my ($num) = grep { m/^\d/ } @args)[0] ) ) { + _croak "cannot export symbols with a leading digit: '$num'"; + } else { + require Exporter; + s/ \A - /:/xm for @args; + @_ = ($self, @args); + goto \&Exporter::import; + } + }; + return; +} + +my $too_complicated = <<'DEATH'; +You are using Sub::Exporter::Progressive, but the features your program uses from +Sub::Exporter cannot be implemented without Sub::Exporter, so you might as well +just use vanilla Sub::Exporter +DEATH + +sub sub_export_options { + my ($inner_target, $setup, $options) = @_; + + my @exports; + my @defaults; + my %tags; + + if ( ($setup||'') eq '-setup') { + my %options = %$options; + + OPTIONS: + for my $opt (keys %options) { + if ($opt eq 'exports') { + + _croak $too_complicated if ref $options{exports} ne 'ARRAY'; + @exports = @{$options{exports}}; + _croak $too_complicated if grep { length ref $_ } @exports; + + } elsif ($opt eq 'groups') { + %tags = %{$options{groups}}; + for my $tagset (values %tags) { + _croak $too_complicated if grep { + length ref $_ + or + $_ =~ / \A - (?! all \b ) /x + } @{$tagset}; + } + @defaults = @{$tags{default} || [] }; + } else { + _croak $too_complicated; + } + } + @{$_} = map { / \A [:-] all \z /x ? @exports : $_ } @{$_} for \@defaults, values %tags; + $tags{all} ||= [ @exports ]; + my %exports = map { $_ => 1 } @exports; + my @errors = grep { not $exports{$_} } @defaults; + _croak join(', ', @errors) . " is not exported by the $inner_target module\n" if @errors; + } + + return { + exports => \@exports, + defaults => \@defaults, + original => $options, + tags => \%tags, + }; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sub::Exporter::Progressive - Only use Sub::Exporter if you need it + +=head1 VERSION + +version 0.001013 + +=head1 SYNOPSIS + + package Syntax::Keyword::Gather; + + use Sub::Exporter::Progressive -setup => { + exports => [qw( break gather gathered take )], + groups => { + default => [qw( break gather gathered take )], + }, + }; + + # elsewhere + + # uses Exporter for speed + use Syntax::Keyword::Gather; + + # somewhere else + + # uses Sub::Exporter for features + use Syntax::Keyword::Gather 'gather', take => { -as => 'grab' }; + +=head1 DESCRIPTION + +L is an incredibly powerful module, but with that power comes +great responsibility, er- as well as some runtime penalties. This module +is a C wrapper that will let your users just use L +if all they are doing is picking exports, but use C if your +users try to use C's more advanced features, like +renaming exports, if they try to use them. + +Note that this module will export C<@EXPORT>, C<@EXPORT_OK> and +C<%EXPORT_TAGS> package variables for C to work. Additionally, if +your package uses advanced C features like currying, this module +will only ever use C, so you might as well use it directly. + +=head1 CONTRIBUTORS + +ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) + +mst - Matt S. Trout (cpan:MSTROUT) + +leont - Leon Timmermans (cpan:LEONT) + +=head1 AUTHOR + +Arthur Axel "fREW" Schmidt + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2016 by Arthur Axel "fREW" Schmidt. + +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/src/main/perl/lib/Sub/Install.pm b/src/main/perl/lib/Sub/Install.pm new file mode 100644 index 000000000..8b7f49502 --- /dev/null +++ b/src/main/perl/lib/Sub/Install.pm @@ -0,0 +1,486 @@ +use v5.8.0; +use strict; +use warnings; +package Sub::Install; +# ABSTRACT: install subroutines into packages easily +$Sub::Install::VERSION = '0.929'; +use Carp; +use Scalar::Util (); + +#pod =head1 SYNOPSIS +#pod +#pod use Sub::Install; +#pod +#pod Sub::Install::install_sub({ +#pod code => sub { ... }, +#pod into => $package, +#pod as => $subname +#pod }); +#pod +#pod =head1 DESCRIPTION +#pod +#pod This module makes it easy to install subroutines into packages without the +#pod unsightly mess of C or typeglobs lying about where just anyone can +#pod see them. +#pod +#pod =func install_sub +#pod +#pod Sub::Install::install_sub({ +#pod code => \&subroutine, +#pod into => "Finance::Shady", +#pod as => 'launder', +#pod }); +#pod +#pod This routine installs a given code reference into a package as a normal +#pod subroutine. The above is equivalent to: +#pod +#pod no strict 'refs'; +#pod *{"Finance::Shady" . '::' . "launder"} = \&subroutine; +#pod +#pod If C is not given, the sub is installed into the calling package. +#pod +#pod If C is not a code reference, it is looked for as an existing sub in the +#pod package named in the C parameter. If C is not given, it will look +#pod in the calling package. +#pod +#pod If C is not given, and if C is a name, C will default to C. +#pod If C is not given, but if C is a code ref, Sub::Install will try to +#pod find the name of the given code ref and use that as C. +#pod +#pod That means that this code: +#pod +#pod Sub::Install::install_sub({ +#pod code => 'twitch', +#pod from => 'Person::InPain', +#pod into => 'Person::Teenager', +#pod as => 'dance', +#pod }); +#pod +#pod is the same as: +#pod +#pod package Person::Teenager; +#pod +#pod Sub::Install::install_sub({ +#pod code => Person::InPain->can('twitch'), +#pod as => 'dance', +#pod }); +#pod +#pod =func reinstall_sub +#pod +#pod This routine behaves exactly like C>, but does not emit a +#pod warning if warnings are on and the destination is already defined. +#pod +#pod =cut + +sub _name_of_code { + my ($code) = @_; + require B; + my $name = B::svref_2object($code)->GV->NAME; + return $name unless $name =~ /\A__ANON__/; + return; +} + +# See also Params::Util, to which this code was donated. +sub _CODELIKE { + (Scalar::Util::reftype($_[0])||'') eq 'CODE' + || Scalar::Util::blessed($_[0]) + && (overload::Method($_[0],'&{}') ? $_[0] : undef); +} + +# do the heavy lifting +sub _build_public_installer { + my ($installer) = @_; + + sub { + my ($arg) = @_; + my ($calling_pkg) = caller(0); + + # I'd rather use ||= but I'm whoring for Devel::Cover. + for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} } + + # This is the only absolutely required argument, in many cases. + Carp::croak "named argument 'code' is not optional" unless $arg->{code}; + + if (_CODELIKE($arg->{code})) { + $arg->{as} ||= _name_of_code($arg->{code}); + } else { + Carp::croak + "couldn't find subroutine named $arg->{code} in package $arg->{from}" + unless my $code = $arg->{from}->can($arg->{code}); + + $arg->{as} = $arg->{code} unless $arg->{as}; + $arg->{code} = $code; + } + + Carp::croak "couldn't determine name under which to install subroutine" + unless $arg->{as}; + + $installer->(@$arg{qw(into as code) }); + } +} + +# do the ugly work + +my $_misc_warn_re; +my $_redef_warn_re; +BEGIN { + $_misc_warn_re = qr/ + Prototype\ mismatch:\ sub\ .+? | + Constant subroutine .+? redefined + /x; + $_redef_warn_re = qr/Subroutine\ .+?\ redefined/x; +} + +my $eow_re; +BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ }; + +sub _do_with_warn { + my ($arg) = @_; + my $code = delete $arg->{code}; + my $wants_code = sub { + my $code = shift; + sub { + my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic + local $SIG{__WARN__} = sub { + my ($error) = @_; + for (@{ $arg->{suppress} }) { + return if $error =~ $_; + } + for (@{ $arg->{croak} }) { + if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { + Carp::croak $base_error; + } + } + for (@{ $arg->{carp} }) { + if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { + return $warn->(Carp::shortmess $base_error); + } + } + ($arg->{default} || $warn)->($error); + }; + $code->(@_); + }; + }; + return $wants_code->($code) if $code; + return $wants_code; +} + +sub _installer { + sub { + my ($pkg, $name, $code) = @_; + no strict 'refs'; ## no critic ProhibitNoStrict + *{"$pkg\::$name"} = $code; + return $code; + } +} + +BEGIN { + *_ignore_warnings = _do_with_warn({ + carp => [ $_misc_warn_re, $_redef_warn_re ] + }); + + *install_sub = _build_public_installer(_ignore_warnings(_installer)); + + *_carp_warnings = _do_with_warn({ + carp => [ $_misc_warn_re ], + suppress => [ $_redef_warn_re ], + }); + + *reinstall_sub = _build_public_installer(_carp_warnings(_installer)); + + *_install_fatal = _do_with_warn({ + code => _installer, + croak => [ $_redef_warn_re ], + }); +} + +#pod =func install_installers +#pod +#pod This routine is provided to allow Sub::Install compatibility with +#pod Sub::Installer. It installs C and C methods into +#pod the package named by its argument. +#pod +#pod Sub::Install::install_installers('Code::Builder'); # just for us, please +#pod Code::Builder->install_sub({ name => $code_ref }); +#pod +#pod Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk? +#pod Anything::At::All->install_sub({ name => $code_ref }); +#pod +#pod The installed installers are similar, but not identical, to those provided by +#pod Sub::Installer. They accept a single hash as an argument. The key/value pairs +#pod are used as the C and C parameters to the C routine +#pod detailed above. The package name on which the method is called is used as the +#pod C parameter. +#pod +#pod Unlike Sub::Installer's C will not eval strings into code, but +#pod will look for named code in the calling package. +#pod +#pod =cut + +sub install_installers { + my ($into) = @_; + + for my $method (qw(install_sub reinstall_sub)) { + my $code = sub { + my ($package, $subs) = @_; + my ($caller) = caller(0); + my $return; + for (my ($name, $sub) = %$subs) { + $return = Sub::Install->can($method)->({ + code => $sub, + from => $caller, + into => $package, + as => $name + }); + } + return $return; + }; + install_sub({ code => $code, into => $into, as => $method }); + } +} + +#pod =head1 EXPORTS +#pod +#pod Sub::Install exports C and C only if they are +#pod requested. +#pod +#pod =head2 exporter +#pod +#pod Sub::Install has a never-exported subroutine called C, which is used +#pod to implement its C routine. It takes a hashref of named arguments, +#pod only one of which is currently recognize: C. This must be an arrayref +#pod of subroutines to offer for export. +#pod +#pod This routine is mainly for Sub::Install's own consumption. Instead, consider +#pod L. +#pod +#pod =cut + +sub exporter { + my ($arg) = @_; + + my %is_exported = map { $_ => undef } @{ $arg->{exports} }; + + sub { + my $class = shift; + my $target = caller; + for (@_) { + Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_}; + install_sub({ code => $_, from => $class, into => $target }); + } + } +} + +BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); } + +#pod =head1 SEE ALSO +#pod +#pod =over +#pod +#pod =item L +#pod +#pod This module is (obviously) a reaction to Damian Conway's Sub::Installer, which +#pod does the same thing, but does it by getting its greasy fingers all over +#pod UNIVERSAL. I was really happy about the idea of making the installation of +#pod coderefs less ugly, but I couldn't bring myself to replace the ugliness of +#pod typeglobs and loosened strictures with the ugliness of UNIVERSAL methods. +#pod +#pod =item L +#pod +#pod This is a complete Exporter.pm replacement, built atop Sub::Install. +#pod +#pod =back +#pod +#pod =head1 EXTRA CREDITS +#pod +#pod Several of the tests are adapted from tests that shipped with Damian Conway's +#pod Sub-Installer distribution. +#pod +#pod =cut + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Sub::Install - install subroutines into packages easily + +=head1 VERSION + +version 0.929 + +=head1 SYNOPSIS + + use Sub::Install; + + Sub::Install::install_sub({ + code => sub { ... }, + into => $package, + as => $subname + }); + +=head1 DESCRIPTION + +This module makes it easy to install subroutines into packages without the +unsightly mess of C or typeglobs lying about where just anyone can +see them. + +=head1 PERL VERSION + +This library should run on perls released even an extremely long time ago. It +should work on any version of perl released in the last ten years. + +Although it may work on older versions of perl, no guarantee is made that the +minimum required version will not be increased. The version may be increased +for any reason, and there is no promise that patches will be accepted to lower +the minimum required perl. + +=head1 FUNCTIONS + +=head2 install_sub + + Sub::Install::install_sub({ + code => \&subroutine, + into => "Finance::Shady", + as => 'launder', + }); + +This routine installs a given code reference into a package as a normal +subroutine. The above is equivalent to: + + no strict 'refs'; + *{"Finance::Shady" . '::' . "launder"} = \&subroutine; + +If C is not given, the sub is installed into the calling package. + +If C is not a code reference, it is looked for as an existing sub in the +package named in the C parameter. If C is not given, it will look +in the calling package. + +If C is not given, and if C is a name, C will default to C. +If C is not given, but if C is a code ref, Sub::Install will try to +find the name of the given code ref and use that as C. + +That means that this code: + + Sub::Install::install_sub({ + code => 'twitch', + from => 'Person::InPain', + into => 'Person::Teenager', + as => 'dance', + }); + +is the same as: + + package Person::Teenager; + + Sub::Install::install_sub({ + code => Person::InPain->can('twitch'), + as => 'dance', + }); + +=head2 reinstall_sub + +This routine behaves exactly like C>, but does not emit a +warning if warnings are on and the destination is already defined. + +=head2 install_installers + +This routine is provided to allow Sub::Install compatibility with +Sub::Installer. It installs C and C methods into +the package named by its argument. + + Sub::Install::install_installers('Code::Builder'); # just for us, please + Code::Builder->install_sub({ name => $code_ref }); + + Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk? + Anything::At::All->install_sub({ name => $code_ref }); + +The installed installers are similar, but not identical, to those provided by +Sub::Installer. They accept a single hash as an argument. The key/value pairs +are used as the C and C parameters to the C routine +detailed above. The package name on which the method is called is used as the +C parameter. + +Unlike Sub::Installer's C will not eval strings into code, but +will look for named code in the calling package. + +=head1 EXPORTS + +Sub::Install exports C and C only if they are +requested. + +=head2 exporter + +Sub::Install has a never-exported subroutine called C, which is used +to implement its C routine. It takes a hashref of named arguments, +only one of which is currently recognize: C. This must be an arrayref +of subroutines to offer for export. + +This routine is mainly for Sub::Install's own consumption. Instead, consider +L. + +=head1 SEE ALSO + +=over + +=item L + +This module is (obviously) a reaction to Damian Conway's Sub::Installer, which +does the same thing, but does it by getting its greasy fingers all over +UNIVERSAL. I was really happy about the idea of making the installation of +coderefs less ugly, but I couldn't bring myself to replace the ugliness of +typeglobs and loosened strictures with the ugliness of UNIVERSAL methods. + +=item L + +This is a complete Exporter.pm replacement, built atop Sub::Install. + +=back + +=head1 EXTRA CREDITS + +Several of the tests are adapted from tests that shipped with Damian Conway's +Sub-Installer distribution. + +=head1 AUTHOR + +Ricardo SIGNES + +=head1 CONTRIBUTORS + +=for stopwords Chad Granum David Steinbrunner Ricardo SIGNES Signes + +=over 4 + +=item * + +Chad Granum + +=item * + +David Steinbrunner + +=item * + +Ricardo SIGNES + +=item * + +Ricardo Signes + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2005 by 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