Файловый менеджер - Редактировать - /home/lakoyani/lakoyani.com.fj/share.tar
Назад
perl5/cPanelUserConfig.pm 0000644 00000001026 14711217501 0011316 0 ustar 00 # cpanel - cPanelUserConfig.pm Copyright(c) 2021 cPanel, L.L.C. # All Rights Reserved. # copyright@cpanel.net http://cpanel.net # This code is subject to the cPanel license. Unauthorized copying is prohibited if ( $> != 0 ) { my $b__dir = ( getpwuid($>) )[7] . '/perl'; unshift @INC, $b__dir . '5/lib/perl5', $b__dir . '5/lib/perl5/x86_64-linux-thread-multi', map { $b__dir . $_ } grep {$_ ne '.'} @INC; } 1; perl5/lib/core/only.pm 0000444 00000006235 14711217501 0010613 0 ustar 00 package lib::core::only; use strict; use warnings FATAL => 'all'; use Config; sub import { @INC = @Config{qw(privlibexp archlibexp)}; return } =head1 NAME lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs =head1 SYNOPSIS use lib::core::only; # now @INC contains only the two core directories To get only the core directories plus the ones for the local::lib in scope: $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl To attempt to do a self-contained build (but note this will not reliably propagate into subprocesses, see the CAVEATS below): $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan Please note that it is necessary to use C<local::lib> twice for this to work. First so that C<lib::core::only> doesn't prevent C<local::lib> from loading (it's not currently in core) and then again after C<lib::core::only> so that the local paths are not removed. =head1 DESCRIPTION lib::core::only is simply a shortcut to say "please reduce my @INC to only the core lib and archlib (architecture-specific lib) directories of this perl". You might want to do this to ensure a local::lib contains only the code you need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known bad vendor packages. You might want to use this to try and install a self-contained tree of perl modules. Be warned that that probably won't work (see L</CAVEATS>). This module was extracted from L<local::lib|local::lib>'s --self-contained feature, and contains the only part that ever worked. I apologise to anybody who thought anything else did. =head1 CAVEATS This does B<not> propagate properly across perl invocations like local::lib's stuff does. It can't. It's only a module import, so it B<only affects the specific perl VM instance in which you load and import() it>. If you want to cascade it across invocations, you can set the PERL5OPT environment variable to '-Mlib::core::only' and it'll sort of work. But be aware that taint mode ignores this, so some modules' build and test code probably will as well. You also need to be aware that perl's command line options are not processed in order - -I options take effect before -M options, so perl -Mlib::core::only -Ilib is unlike to do what you want - it's exactly equivalent to: perl -Mlib::core::only If you want to combine a core-only @INC with additional paths, you need to add the additional paths using -M options and the L<lib|lib> module: perl -Mlib::core::only -Mlib=lib # or if you're trying to test compiled code: perl -Mlib::core::only -Mblib For more information on the impossibility of sanely propagating this across module builds without help from the build program, see L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways to achieve the old --self-contained feature's results, look at L<App::FatPacker|App::FatPacker>'s tree function, and at L<App::cpanminus|cpanm>'s --local-lib-contained feature. =head1 AUTHOR Matt S. Trout <mst@shadowcat.co.uk> =head1 LICENSE This library is free software under the same terms as perl itself. =head1 COPYRIGHT (c) 2010 the lib::core::only L</AUTHOR> as specified above. =cut 1; perl5/Test2/Hub/Interceptor/Terminator.pm 0000444 00000001340 14711217502 0014266 0 ustar 00 package Test2::Hub::Interceptor::Terminator; use strict; use warnings; our $VERSION = '1.302186'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor::Terminator - Exception class used by Test2::Hub::Interceptor =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Hub/Interceptor.pm 0000444 00000005246 14711217502 0012153 0 ustar 00 package Test2::Hub::Interceptor; use strict; use warnings; our $VERSION = '1.302186'; use Test2::Hub::Interceptor::Terminator(); BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; sub init { my $self = shift; $self->SUPER::init(); $self->{+NESTED} = 0; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+NESTED} = 0; if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } if (my $ls = $from->{+_LISTENERS}) { push @{$self->{+_LISTENERS}} => grep { $_->{intercept_inherit} } @$ls; } if (my $pfs = $from->{+_PRE_FILTERS}) { push @{$self->{+_PRE_FILTERS}} => grep { $_->{intercept_inherit} } @$pfs; } if (my $fs = $from->{+_FILTERS}) { push @{$self->{+_FILTERS}} => grep { $_->{intercept_inherit} } @$fs; } } sub clean_inherited { my $self = shift; my %params = @_; my @sets = ( $self->{+_LISTENERS}, $self->{+_PRE_FILTERS}, $self->{+_FILTERS}, ); for my $set (@sets) { next unless $set; for my $i (@$set) { my $cbs = $i->{intercept_inherit} or next; next unless ref($cbs) eq 'HASH'; my $cb = $cbs->{clean} or next; $cb->(%params); } } } sub restore_inherited { my $self = shift; my %params = @_; my @sets = ( $self->{+_FILTERS}, $self->{+_PRE_FILTERS}, $self->{+_LISTENERS}, ); for my $set (@sets) { next unless $set; for my $i (@$set) { my $cbs = $i->{intercept_inherit} or next; next unless ref($cbs) eq 'HASH'; my $cb = $cbs->{restore} or next; $cb->(%params); } } } sub terminate { my $self = shift; my ($code) = @_; eval { no warnings 'exiting'; last T2_SUBTEST_WRAPPER; }; my $err = $@; # Fallback die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Interceptor - Hub used by interceptor to grab results. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Hub/Subtest.pm 0000444 00000005120 14711217503 0011276 0 ustar 00 package Test2::Hub::Subtest; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; use Test2::Util qw/get_tid/; sub is_subtest { 1 } sub inherit { my $self = shift; my ($from) = @_; $self->SUPER::inherit($from); $self->{+NESTED} = $from->nested + 1; } { # Legacy no warnings 'once'; *ID = \&Test2::Hub::HID; *id = \&Test2::Hub::hid; *set_id = \&Test2::Hub::set_hid; } sub send { my $self = shift; my ($e) = @_; my $out = $self->SUPER::send($e); return $out if $self->{+MANUAL_SKIP_ALL}; my $f = $e->facet_data; my $plan = $f->{plan} or return $out; return $out unless $plan->{skip}; my $trace = $f->{trace} or die "Missing Trace!"; return $out unless $trace->{pid} != $self->pid || $trace->{tid} != $self->tid; no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } sub terminate { my $self = shift; my ($code, $e, $f) = @_; $self->set_exit_code($code); return if $self->{+MANUAL_SKIP_ALL}; $f ||= $e->facet_data; if(my $plan = $f->{plan}) { my $trace = $f->{trace} or die "Missing Trace!"; return if $plan->{skip} && ($trace->{pid} != $$ || $trace->{tid} != get_tid); } no warnings 'exiting'; last T2_SUBTEST_WRAPPER; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub::Subtest - Hub used by subtests =head1 DESCRIPTION Subtests make use of this hub to route events. =head1 TOGGLES =over 4 =item $bool = $hub->manual_skip_all =item $hub->set_manual_skip_all($bool) The default is false. Normally a skip-all plan event will cause a subtest to stop executing. This is accomplished via C<last LABEL> to a label inside the subtest code. Most of the time this is perfectly fine. There are times however where this flow control causes bad things to happen. This toggle lets you turn off the abort logic for the hub. When this is toggled to true B<you> are responsible for ensuring no additional events are generated. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/IPC.pm 0000444 00000006146 14711217503 0007553 0 ustar 00 package Test2::IPC; use strict; use warnings; our $VERSION = '1.302186'; use Test2::API::Instance; use Test2::Util qw/get_tid/; use Test2::API qw{ test2_in_preload test2_init_done test2_ipc test2_has_ipc test2_ipc_enable_polling test2_pid test2_stack test2_tid context }; # Make sure stuff is finalized before anyone tried to fork or start a new thread. { # Avoid warnings if things are loaded at run-time no warnings 'void'; INIT { use warnings 'void'; context()->release() unless test2_in_preload(); } } use Carp qw/confess/; our @EXPORT_OK = qw/cull/; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub unimport { Test2::API::test2_ipc_disable() } sub import { goto &Exporter::import if test2_has_ipc || !test2_init_done(); confess "IPC is disabled" if Test2::API::test2_ipc_disabled(); confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); Test2::API::_set_ipc(_make_ipc()); apply_ipc(test2_stack()); goto &Exporter::import; } sub _make_ipc { # Find a driver my ($driver) = Test2::API::test2_ipc_drivers(); unless ($driver) { require Test2::IPC::Driver::Files; $driver = 'Test2::IPC::Driver::Files'; } return $driver->new(); } sub apply_ipc { my $stack = shift; my ($root) = @$stack; return unless $root; confess "Cannot add IPC in a child process" if $root->pid != $$; confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); my $ipc = $root->ipc || test2_ipc() || _make_ipc(); # Add the IPC to all hubs for my $hub (@$stack) { my $has = $hub->ipc; confess "IPC Mismatch!" if $has && $has != $ipc; next if $has; $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } test2_ipc_enable_polling(); return $ipc; } sub cull { my $ctx = context(); $ctx->hub->cull; $ctx->release; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC - Turn on IPC for threading or forking support. =head1 SYNOPSIS You should C<use Test2::IPC;> as early as possible in your test file. If you import this module after API initialization it will attempt to retrofit IPC onto the existing hubs. =head2 DISABLING IT You can use C<no Test2::IPC;> to disable IPC for good. You can also use the T2_NO_IPC env var. =head1 EXPORTS All exports are optional. =over 4 =item cull() Cull allows you to collect results from other processes or threads on demand. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Formatter/TAP.pm 0000444 00000032644 14711217503 0011531 0 ustar 00 package Test2::Formatter::TAP; use strict; use warnings; our $VERSION = '1.302186'; use Test2::Util qw/clone_io/; use Test2::Util::HashBase qw{ no_numbers handles _encoding _last_fh -made_assertion }; sub OUT_STD() { 0 } sub OUT_ERR() { 1 } BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } my $supports_tables; sub supports_tables { if (!defined $supports_tables) { local $SIG{__DIE__} = 'DEFAULT'; local $@; $supports_tables = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'}) || eval { require Term::Table; require Term::Table::Util; 1 } || 0; } return $supports_tables; } sub _autoflush { my($fh) = pop; my $old_fh = select $fh; $| = 1; select $old_fh; } _autoflush(\*STDOUT); _autoflush(\*STDERR); sub hide_buffered { 1 } sub init { my $self = shift; $self->{+HANDLES} ||= $self->_open_handles; if(my $enc = delete $self->{encoding}) { $self->encoding($enc); } } sub _open_handles { my $self = shift; require Test2::API; my $out = clone_io(Test2::API::test2_stdout()); my $err = clone_io(Test2::API::test2_stderr()); _autoflush($out); _autoflush($err); return [$out, $err]; } sub encoding { my $self = shift; if ($] ge "5.007003" and @_) { my ($enc) = @_; my $handles = $self->{+HANDLES}; # https://rt.perl.org/Public/Bug/Display.html?id=31923 # If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in # order to avoid the thread segfault. if ($enc =~ m/^utf-?8$/i) { binmode($_, ":utf8") for @$handles; } else { binmode($_, ":encoding($enc)") for @$handles; } $self->{+_ENCODING} = $enc; } return $self->{+_ENCODING}; } if ($^C) { no warnings 'redefine'; *write = sub {}; } sub write { my ($self, $e, $num, $f) = @_; # The most common case, a pass event with no amnesty and a normal name. return if $self->print_optimal_pass($e, $num); $f ||= $e->facet_data; $self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding}; my @tap = $self->event_tap($f, $num) or return; $self->{+MADE_ASSERTION} = 1 if $f->{assert}; my $nesting = $f->{trace}->{nested} || 0; my $handles = $self->{+HANDLES}; my $indent = ' ' x $nesting; # Local is expensive! Only do it if we really need to. local($\, $,) = (undef, '') if $\ || $,; for my $set (@tap) { no warnings 'uninitialized'; my ($hid, $msg) = @$set; next unless $msg; my $io = $handles->[$hid] or next; print $io "\n" if $ENV{HARNESS_ACTIVE} && $hid == OUT_ERR && $self->{+_LAST_FH} != $io && $msg =~ m/^#\s*Failed( \(TODO\))? test /; $msg =~ s/^/$indent/mg if $nesting; print $io $msg; $self->{+_LAST_FH} = $io; } } sub print_optimal_pass { my ($self, $e, $num) = @_; my $type = ref($e); # Only optimal if this is a Pass or a passing Ok return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass}); # Amnesty requires further processing (todo is a form of amnesty) return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo}); # A name with a newline or hash symbol needs extra processing return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#')); my $ok = 'ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; $ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n"; if (my $nesting = $e->{trace}->{nested}) { my $indent = ' ' x $nesting; $ok = "$indent$ok"; } my $io = $self->{+HANDLES}->[OUT_STD]; local($\, $,) = (undef, '') if $\ || $,; print $io $ok; $self->{+_LAST_FH} = $io; return 1; } sub event_tap { my ($self, $f, $num) = @_; my @tap; # If this IS the first event the plan should come first # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION}; # The assertion is most important, if present. if ($f->{assert}) { push @tap => $self->assert_tap($f, $num); push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass}; } # Almost as important as an assertion push @tap => $self->error_tap($f) if $f->{errors}; # Now lets see the diagnostics messages push @tap => $self->info_tap($f) if $f->{info}; # If this IS NOT the first event the plan should come last # (plan must be before or after assertions, not in the middle) push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan}; # Bail out push @tap => $self->halt_tap($f) if $f->{control}->{halt}; return @tap if @tap; return @tap if $f->{control}->{halt}; return @tap if grep { $f->{$_} } qw/assert plan info errors/; # Use the summary as a fallback if nothing else is usable. return $self->summary_tap($f, $num); } sub error_tap { my $self = shift; my ($f) = @_; my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR; return map { my $details = $_->{details}; my $msg; if (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{errors}}; } sub plan_tap { my $self = shift; my ($f) = @_; my $plan = $f->{plan} or return; return if $plan->{none}; if ($plan->{skip}) { my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"]; chomp($reason); return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"]; } return [OUT_STD, "1.." . $plan->{count} . "\n"]; } sub no_subtest_space { 0 } sub assert_tap { my $self = shift; my ($f, $num) = @_; my $assert = $f->{assert} or return; my $pass = $assert->{pass}; my $name = $assert->{details}; my $ok = $pass ? 'ok' : 'not ok'; $ok .= " $num" if $num && !$self->{+NO_NUMBERS}; # The regex form is ~250ms, the index form is ~50ms my @extra; defined($name) && ( (index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))), ((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g))) ); my $extra_space = @extra ? ' ' x (length($ok) + 2) : ''; my $extra_indent = ''; my ($directives, $reason, $is_skip); if ($f->{amnesty}) { my %directives; for my $am (@{$f->{amnesty}}) { next if $am->{inherited}; my $tag = $am->{tag} or next; $is_skip = 1 if $tag eq 'skip'; $directives{$tag} ||= $am->{details}; } my %seen; # Sort so that TODO comes before skip even on systems where lc sorts # before uc, as other code depends on that ordering. my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives; $directives = ' # ' . join ' & ' => @order; for my $tag ('skip', @order) { next unless defined($directives{$tag}) && length($directives{$tag}); $reason = $directives{$tag}; last; } } $ok .= " - $name" if defined $name && !($is_skip && !$name); my @subtap; if ($f->{parent} && $f->{parent}->{buffered}) { $ok .= ' {'; # In a verbose harness we indent the extra since they will appear # inside the subtest braces. This helps readability. In a non-verbose # harness we do not do this because it is less readable. if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) { $extra_indent = " "; $extra_space = ' '; } # Render the sub-events, we use our own counter for these. my $count = 0; @subtap = map { my $f2 = $_; # Bump the count for any event that should bump it. $count++ if $f2->{assert}; # This indents all output lines generated for the sub-events. # index 0 is the filehandle, index 1 is the message we want to indent. map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count); } @{$f->{parent}->{children}}; push @subtap => [OUT_STD, "}\n"]; } if ($directives) { $directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip'; $ok .= $directives; $ok .= " $reason" if defined($reason); } $extra_space = ' ' if $self->no_subtest_space; my @out = ([OUT_STD, "$ok\n"]); push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra; push @out => @subtap; return @out; } sub debug_tap { my ($self, $f, $num) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $f->{assert}->{details}; my $trace = $f->{trace}; my $debug = "[No trace info available]"; if ($trace->{details}) { $debug = $trace->{details}; } elsif ($trace->{frame}) { my ($pkg, $file, $line) = @{$trace->{frame}}; $debug = "at $file line $line." if $file && $line; } my $amnesty = $f->{amnesty} && @{$f->{amnesty}} ? ' (with amnesty)' : ''; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[# Failed test${amnesty} '$name'\n# $debug\n] : qq[# Failed test${amnesty} $debug\n]; my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR; return [$IO, $msg]; } sub halt_tap { my ($self, $f) = @_; return if $f->{trace}->{nested} && !$f->{trace}->{buffered}; my $details = $f->{control}->{details}; return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details); return [OUT_STD, "Bail out! $details\n"]; } sub info_tap { my ($self, $f) = @_; return map { my $details = $_->{details}; my $table = $_->{table}; my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD; my $msg; if ($table && $self->supports_tables) { $msg = join "\n" => map { "# $_" } Term::Table->new( header => $table->{header}, rows => $table->{rows}, collapse => $table->{collapse}, no_collapse => $table->{no_collapse}, sanitize => 1, mark_tail => 1, max_width => $self->calc_table_size($f), )->render(); } elsif (ref($details)) { require Data::Dumper; my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1); chomp($msg = $dumper->Dump); } else { chomp($msg = $details); $msg =~ s/^/# /; $msg =~ s/\n/\n# /g; } [$IO, "$msg\n"]; } @{$f->{info}}; } sub summary_tap { my ($self, $f, $num) = @_; return if $f->{about}->{no_display}; my $summary = $f->{about}->{details} or return; chomp($summary); $summary =~ s/^/# /smg; return [OUT_STD, "$summary\n"]; } sub calc_table_size { my $self = shift; my ($f) = @_; my $term = Term::Table::Util::term_size(); my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix my $total = $term - $nesting; # Sane minimum width, any smaller and we are asking for pain return 50 if $total < 50; return $total; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter::TAP - Standard TAP formatter =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test2::Formatter::TAP; my $tap = Test2::Formatter::TAP->new(); # Switch to utf8 $tap->encoding('utf8'); $tap->write($event, $number); # Output an event =head1 METHODS =over 4 =item $bool = $tap->no_numbers =item $tap->set_no_numbers($bool) Use to turn numbers on and off. =item $arrayref = $tap->handles =item $tap->set_handles(\@handles); Can be used to get/set the filehandles. Indexes are identified by the C<OUT_STD> and C<OUT_ERR> constants. =item $encoding = $tap->encoding =item $tap->encoding($encoding) Get or set the encoding. By default no encoding is set, the original settings of STDOUT and STDERR are used. This directly modifies the stored filehandles, it does not create new ones. =item $tap->write($e, $num) Write an event to the console. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =item Kent Fredric E<lt>kentnl@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Formatter.pm 0000444 00000007561 14711217504 0011106 0 ustar 00 package Test2::Formatter; use strict; use warnings; our $VERSION = '1.302186'; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; require Test2::API; Test2::API::test2_formatter_add($class); } sub new_root { my $class = shift; return $class->new(@_); } sub supports_tables { 0 } sub hide_buffered { 1 } sub terminate { } sub finalize { } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Formatter - Namespace for formatters. =head1 DESCRIPTION This is the namespace for formatters. This is an empty package. =head1 CREATING FORMATTERS A formatter is any package or object with a C<write($event, $num)> method. package Test2::Formatter::Foo; use strict; use warnings; sub write { my $self_or_class = shift; my ($event, $assert_num) = @_; ... } sub hide_buffered { 1 } sub terminate { } sub finalize { } sub supports_tables { return $BOOL } sub new_root { my $class = shift; ... $class->new(@_); } 1; The C<write> method is a method, so it either gets a class or instance. The two arguments are the C<$event> object it should record, and the C<$assert_num> which is the number of the current assertion (ok), or the last assertion if this event is not itself an assertion. The assertion number may be any integer 0 or greater, and may be undefined in some cases. The C<hide_buffered()> method must return a boolean. This is used to tell buffered subtests whether or not to send it events as they are being buffered. See L<Test2::API/"run_subtest(...)"> for more information. The C<terminate> and C<finalize> methods are optional methods called that you can implement if the format you're generating needs to handle these cases, for example if you are generating XML and need close open tags. The C<terminate> method is called when an event's C<terminate> method returns true, for example when a L<Test2::Event::Plan> has a C<'skip_all'> plan, or when a L<Test2::Event::Bail> event is sent. The C<terminate> method is passed a single argument, the L<Test2::Event> object which triggered the terminate. The C<finalize> method is always the last thing called on the formatter, I<< except when C<terminate> is called for a Bail event >>. It is passed the following arguments: The C<supports_tables> method should be true if the formatter supports directly rendering table data from the C<info> facets. This is a newer feature and many older formatters may not support it. When not supported the formatter falls back to rendering C<detail> instead of the C<table> data. The C<new_root> method is used when constructing a root formatter. The default is to just delegate to the regular C<new()> method, most formatters can ignore this. =over 4 =item * The number of tests that were planned =item * The number of tests actually seen =item * The number of tests which failed =item * A boolean indicating whether or not the test suite passed =item * A boolean indicating whether or not this call is for a subtest =back The C<new_root> method is called when C<Test2::API::Stack> Initializes the root hub for the first time. Most formatters will simply have this call C<< $class->new >>, which is the default behavior. Some formatters however may want to take extra action during construction of the root formatter, this is where they can do that. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API.pm 0000444 00000136622 14711217504 0007555 0 ustar 00 package Test2::API; use strict; use warnings; use Test2::Util qw/USE_THREADS/; BEGIN { $ENV{TEST_ACTIVE} ||= 1; $ENV{TEST2_ACTIVE} = 1; } our $VERSION = '1.302186'; my $INST; my $ENDING = 0; sub test2_unset_is_end { $ENDING = 0 } sub test2_get_is_end { $ENDING } sub test2_set_is_end { my $before = $ENDING; ($ENDING) = @_ ? @_ : (1); # Only send the event in a transition from false to true return if $before; return unless $ENDING; return unless $INST; my $stack = $INST->stack or return; my $root = $stack->root or return; return unless $root->count; return unless $$ == $INST->pid; return unless get_tid() == $INST->tid; my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'], ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $root, ); $ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' }); 1; } use Test2::API::Instance(\$INST); # Set the exit status END { test2_set_is_end(); # See gh #16 $INST->set_exit(); } sub CLONE { my $init = test2_init_done(); my $load = test2_load_done(); return if $init && $load; require Carp; Carp::croak "Test2 must be fully loaded before you start a new thread!\n"; } # See gh #16 { no warnings; INIT { eval 'END { test2_set_is_end() }; 1' or die $@ } } BEGIN { no warnings 'once'; if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) { *DO_DEPTH_CHECK = sub() { 1 }; } else { *DO_DEPTH_CHECK = sub() { 0 }; } } use Test2::EventFacet::Trace(); use Test2::Util::Trace(); # Legacy use Test2::Hub::Subtest(); use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); use Test2::Event::Ok(); use Test2::Event::Diag(); use Test2::Event::Note(); use Test2::Event::Plan(); use Test2::Event::Bail(); use Test2::Event::Exception(); use Test2::Event::Waiting(); use Test2::Event::Skip(); use Test2::Event::Subtest(); use Carp qw/carp croak confess/; use Scalar::Util qw/blessed weaken/; use Test2::Util qw/get_tid clone_io pkg_to_file gen_uid/; our @EXPORT_OK = qw{ context release context_do no_context intercept intercept_deep run_subtest test2_init_done test2_load_done test2_load test2_start_preload test2_stop_preload test2_in_preload test2_is_testing_done test2_set_is_end test2_unset_is_end test2_get_is_end test2_pid test2_tid test2_stack test2_no_wait test2_ipc_wait_enable test2_ipc_wait_disable test2_ipc_wait_enabled test2_add_uuid_via test2_add_callback_testing_done test2_add_callback_context_aquire test2_add_callback_context_acquire test2_add_callback_context_init test2_add_callback_context_release test2_add_callback_exit test2_add_callback_post_load test2_add_callback_pre_subtest test2_list_context_aquire_callbacks test2_list_context_acquire_callbacks test2_list_context_init_callbacks test2_list_context_release_callbacks test2_list_exit_callbacks test2_list_post_load_callbacks test2_list_pre_subtest_callbacks test2_ipc test2_has_ipc test2_ipc_disable test2_ipc_disabled test2_ipc_drivers test2_ipc_add_driver test2_ipc_polling test2_ipc_disable_polling test2_ipc_enable_polling test2_ipc_get_pending test2_ipc_set_pending test2_ipc_get_timeout test2_ipc_set_timeout test2_formatter test2_formatters test2_formatter_add test2_formatter_set test2_stdout test2_stderr test2_reset_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } my $STACK = $INST->stack; my $CONTEXTS = $INST->contexts; my $INIT_CBS = $INST->context_init_callbacks; my $ACQUIRE_CBS = $INST->context_acquire_callbacks; my $STDOUT = clone_io(\*STDOUT); my $STDERR = clone_io(\*STDERR); sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) } sub test2_stderr { $STDERR ||= clone_io(\*STDERR) } sub test2_post_preload_reset { test2_reset_io(); $INST->post_preload_reset; } sub test2_reset_io { $STDOUT = clone_io(\*STDOUT); $STDERR = clone_io(\*STDERR); } sub test2_init_done { $INST->finalized } sub test2_load_done { $INST->loaded } sub test2_load { $INST->load } sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload } sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload } sub test2_in_preload { $INST->preload } sub test2_pid { $INST->pid } sub test2_tid { $INST->tid } sub test2_stack { $INST->stack } sub test2_ipc_wait_enable { $INST->set_no_wait(0) } sub test2_ipc_wait_disable { $INST->set_no_wait(1) } sub test2_ipc_wait_enabled { !$INST->no_wait } sub test2_is_testing_done { # No instance? VERY DONE! return 1 unless $INST; # No stack? tests must be done, it is created pretty early my $stack = $INST->stack or return 1; # Nothing on the stack, no root hub yet, likely have not started testing return 0 unless @$stack; # Stack has a slot for the root hub (see above) but it is undefined, likely # garbage collected, test is done my $root_hub = $stack->[0] or return 1; # If the root hub is ended than testing is done. return 1 if $root_hub->ended; # Looks like we are still testing! return 0; } sub test2_no_wait { $INST->set_no_wait(@_) if @_; $INST->no_wait; } sub test2_add_callback_testing_done { my $cb = shift; test2_add_callback_post_load(sub { my $stack = test2_stack(); $stack->top; # Insure we have a hub my ($hub) = Test2::API::test2_stack->all; $hub->set_active(1); $hub->follow_up($cb); }); return; } sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) } sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) } sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) } sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) } sub test2_add_callback_exit { $INST->add_exit_callback(@_) } sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) } sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) } sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} } sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} } sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} } sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} } sub test2_list_exit_callbacks { @{$INST->exit_callbacks} } sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} } sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} } sub test2_add_uuid_via { $INST->set_add_uuid_via(@_) if @_; $INST->add_uuid_via(); } sub test2_ipc { $INST->ipc } sub test2_has_ipc { $INST->has_ipc } sub test2_ipc_disable { $INST->ipc_disable } sub test2_ipc_disabled { $INST->ipc_disabled } sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) } sub test2_ipc_drivers { @{$INST->ipc_drivers} } sub test2_ipc_polling { $INST->ipc_polling } sub test2_ipc_enable_polling { $INST->enable_ipc_polling } sub test2_ipc_disable_polling { $INST->disable_ipc_polling } sub test2_ipc_get_pending { $INST->get_ipc_pending } sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) } sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) } sub test2_ipc_get_timeout { $INST->ipc_timeout() } sub test2_ipc_enable_shm { 0 } sub test2_formatter { if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { my $formatter = $1 ? $2 : "Test2::Formatter::$2"; my $file = pkg_to_file($formatter); require $file; return $formatter; } return $INST->formatter; } sub test2_formatters { @{$INST->formatters} } sub test2_formatter_add { $INST->add_formatter(@_) } sub test2_formatter_set { my ($formatter) = @_; croak "No formatter specified" unless $formatter; croak "Global Formatter already set" if $INST->formatter_set; $INST->set_formatter($formatter); } # Private, for use in Test2::API::Context sub _contexts_ref { $INST->contexts } sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks } sub _context_init_callbacks_ref { $INST->context_init_callbacks } sub _context_release_callbacks_ref { $INST->context_release_callbacks } sub _add_uuid_via_ref { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) } # Private, for use in Test2::IPC sub _set_ipc { $INST->set_ipc(@_) } sub context_do(&;@) { my $code = shift; my @args = @_; my $ctx = context(level => 1); my $want = wantarray; my @out; my $ok = eval { $want ? @out = $code->($ctx, @args) : defined($want) ? $out[0] = $code->($ctx, @args) : $code->($ctx, @args) ; 1; }; my $err = $@; $ctx->release; die $err unless $ok; return @out if $want; return $out[0] if defined $want; return; } sub no_context(&;$) { my ($code, $hid) = @_; $hid ||= $STACK->top->hid; my $ctx = $CONTEXTS->{$hid}; delete $CONTEXTS->{$hid}; my $ok = eval { $code->(); 1 }; my $err = $@; $CONTEXTS->{$hid} = $ctx; weaken($CONTEXTS->{$hid}); die $err unless $ok; return; }; my $UUID_VIA = _add_uuid_via_ref(); sub context { # We need to grab these before anything else to ensure they are not # changed. my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E); my %params = (level => 0, wrapped => 0, @_); # If something is getting a context then the sync system needs to be # considered loaded... $INST->load unless $INST->{loaded}; croak "context() called, but return value is ignored" unless defined wantarray; my $stack = $params{stack} || $STACK; my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); # Catch an edge case where we try to get context after the root hub has # been garbage collected resulting in a stack that has a single undef # hub if (!$hub && !exists($params{hub}) && @$stack) { my $msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)"); # The error message is usually masked by the global destruction, so we have to print to STDER print STDERR $msg; # Make sure this is a failure, we are probably already in END, so set $? to change the exit code $? = 1; # Now we actually die to interrupt the program flow and avoid undefined his warnings die $msg; } my $hid = $hub->{hid}; my $current = $CONTEXTS->{$hid}; $_->(\%params) for @$ACQUIRE_CBS; map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire}; # This is for https://github.com/Test-More/test-more/issues/16 # and https://rt.perl.org/Public/Bug/Display.html?id=127774 my $phase = ${^GLOBAL_PHASE} || 'NA'; my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT'; my $level = 1 + $params{level}; my ($pkg, $file, $line, $sub, @other) = $end_phase ? caller(0) : caller($level); unless ($pkg || $end_phase) { confess "Could not find context at depth $level" unless $params{fudge}; ($pkg, $file, $line, $sub, @other) = caller(--$level) while ($level >= 0 && !$pkg); } my $depth = $level; $depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1); $depth -= $params{wrapped}; my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth; if ($current && $params{on_release} && $depth_ok) { $current->{_on_release} ||= []; push @{$current->{_on_release}} => $params{on_release}; } # I know this is ugly.... ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless( { %$current, _is_canon => undef, errno => $errno, eval_error => $eval_error, child_error => $child_error, _is_spawn => [$pkg, $file, $line, $sub], }, 'Test2::API::Context' ) if $current && $depth_ok; # Handle error condition of bad level if ($current) { unless (${$current->{_aborted}}) { _canon_error($current, [$pkg, $file, $line, $sub, $depth]) unless $current->{_is_canon}; _depth_error($current, [$pkg, $file, $line, $sub, $depth]) unless $depth_ok; } $current->release if $current->{_is_canon}; delete $CONTEXTS->{$hid}; } # Directly bless the object here, calling new is a noticeable performance # hit with how often this needs to be called. my $trace = bless( { frame => [$pkg, $file, $line, $sub], pid => $$, tid => get_tid(), cid => gen_uid(), hid => $hid, nested => $hub->{nested}, buffered => $hub->{buffered}, full_caller => [$pkg, $file, $line, $sub, @other], $$UUID_VIA ? ( huuid => $hub->{uuid}, uuid => ${$UUID_VIA}->('context'), ) : (), }, 'Test2::EventFacet::Trace' ); # Directly bless the object here, calling new is a noticeable performance # hit with how often this needs to be called. my $aborted = 0; $current = bless( { _aborted => \$aborted, stack => $stack, hub => $hub, trace => $trace, _is_canon => 1, _depth => $depth, errno => $errno, eval_error => $eval_error, child_error => $child_error, $params{on_release} ? (_on_release => [$params{on_release}]) : (), }, 'Test2::API::Context' ); $CONTEXTS->{$hid} = $current; weaken($CONTEXTS->{$hid}); $_->($current) for @$INIT_CBS; map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init}; $params{on_init}->($current) if $params{on_init}; ($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error); return $current; } sub _depth_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context was created in a stack frame at the same, or deeper level. This usually means that a tool failed to release the context when it was finished. EOT } sub _canon_error { _existing_error(@_, <<" EOT"); context() was called to retrieve an existing context, however the existing context has an invalid internal state (!_canon_count). This should not normally happen unless something is mucking about with internals... EOT } sub _existing_error { my ($ctx, $details, $msg) = @_; my ($pkg, $file, $line, $sub, $depth) = @$details; my $oldframe = $ctx->{trace}->frame; my $olddepth = $ctx->{_depth}; # Older versions of Carp do not export longmess() function, so it needs to be called with package name my $mess = Carp::longmess(); warn <<" EOT"; $msg Old context details: File: $oldframe->[1] Line: $oldframe->[2] Tool: $oldframe->[3] Depth: $olddepth New context details: File: $file Line: $line Tool: $sub Depth: $depth Trace: $mess Removing the old context and creating a new one... EOT } sub release($;$) { $_[0]->release; return $_[1]; } sub intercept(&) { my $code = shift; my $ctx = context(); my $events = _intercept($code, deep => 0); $ctx->release; return $events; } sub intercept_deep(&) { my $code = shift; my $ctx = context(); my $events = _intercept($code, deep => 1); $ctx->release; return $events; } sub _intercept { my $code = shift; my %params = @_; my $ctx = context(); my $ipc; if (my $global_ipc = test2_ipc()) { my $driver = blessed($global_ipc); $ipc = $driver->new; } my $hub = Test2::Hub::Interceptor->new( ipc => $ipc, no_ending => 1, ); my @events; $hub->listen(sub { push @events => $_[1] }, inherit => $params{deep}); $ctx->stack->top; # Make sure there is a top hub before we begin. $ctx->stack->push($hub); my $trace = $ctx->trace; my $state = {}; $hub->clean_inherited(trace => $trace, state => $state); my ($ok, $err) = (1, undef); T2_SUBTEST_WRAPPER: { # Do not use 'try' cause it localizes __DIE__ $ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 }; $err = $@; # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) { $ok = 1; $err = undef; } } $hub->cull; $ctx->stack->pop($hub); $hub->restore_inherited(trace => $trace, state => $state); $ctx->release; die $err unless $ok; $hub->finalize($trace, 1) if $ok && !$hub->no_ending && !$hub->ended; require Test2::API::InterceptResult; return Test2::API::InterceptResult->new_from_ref(\@events); } sub run_subtest { my ($name, $code, $params, @args) = @_; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $params = {buffered => $params} unless ref $params; my $inherit_trace = delete $params->{inherit_trace}; my $ctx = context(); my $parent = $ctx->hub; # If a parent is buffered then the child must be as well. my $buffered = $params->{buffered} || $parent->{buffered}; $ctx->note($name) unless $buffered; my $stack = $ctx->stack || $STACK; my $hub = $stack->new_hub( class => 'Test2::Hub::Subtest', %$params, buffered => $buffered, ); my @events; $hub->listen(sub { push @events => $_[1] }); if ($buffered) { if (my $format = $hub->format) { my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1; $hub->format(undef) if $hide; } } if ($inherit_trace) { my $orig = $code; $code = sub { my $base_trace = $ctx->trace; my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested); my $st_ctx = Test2::API::Context->new( trace => $trace, hub => $hub, ); $st_ctx->do_in_context($orig, @args); }; } my $start_stamp = time; my ($ok, $err, $finished); T2_SUBTEST_WRAPPER: { # Do not use 'try' cause it localizes __DIE__ $ok = eval { $code->(@args); 1 }; $err = $@; # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } my $stop_stamp = time; if ($params->{no_fork}) { if ($$ != $ctx->trace->pid) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } if (get_tid() != $ctx->trace->tid) { warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err; exit 255; } } elsif (!$parent->is_local && !$parent->ipc) { warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err; exit 255; } $stack->pop($hub); my $trace = $ctx->trace; my $bailed = $hub->bailed_out; if (!$finished) { if ($bailed && !$buffered) { $ctx->bail($bailed->reason); } elsif ($bailed && $buffered) { $ok = 1; } else { my $code = $hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } } $hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1) if $ok && !$hub->no_ending && !$hub->ended; my $pass = $ok && $hub->is_passing; my $e = $ctx->build_event( 'Subtest', pass => $pass, name => $name, subtest_id => $hub->id, subtest_uuid => $hub->uuid, buffered => $buffered, subevents => \@events, start_stamp => $start_stamp, stop_stamp => $stop_stamp, ); my $plan_ok = $hub->check_plan; $ctx->hub->send($e); $ctx->failure_diag($e) unless $e->pass; $ctx->diag("Caught exception in subtest: $err") unless $ok; $ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count) if defined($plan_ok) && !$plan_ok; $ctx->bail($bailed->reason) if $bailed && $buffered; $ctx->release; return $pass; } # There is a use-cycle between API and API/Context. Context needs to use some # API functions as the package is compiling. Test2::API::context() needs # Test2::API::Context to be loaded, but we cannot 'require' the module there as # it causes a very noticeable performance impact with how often context() is # called. require Test2::API::Context; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API - Primary interface for writing Test2 based testing tools. =head1 ***INTERNALS NOTE*** B<The internals of this package are subject to change at any time!> The public methods provided will not change in backwards-incompatible ways (once there is a stable release), but the underlying implementation details might. B<Do not break encapsulation here!> Currently the implementation is to create a single instance of the L<Test2::API::Instance> Object. All class methods defer to the single instance. There is no public access to the singleton, and that is intentional. The class methods provided by this package provide the only functionality publicly exposed. This is done primarily to avoid the problems Test::Builder had by exposing its singleton. We do not want anyone to replace this singleton, rebless it, or directly muck with its internals. If you need to do something and cannot because of the restrictions placed here, then please report it as an issue. If possible, we will create a way for you to implement your functionality without exposing things that should not be exposed. =head1 DESCRIPTION This package exports all the functions necessary to write and/or verify testing tools. Using these building blocks you can begin writing test tools very quickly. You are also provided with tools that help you to test the tools you write. =head1 SYNOPSIS =head2 WRITING A TOOL The C<context()> method is your primary interface into the Test2 framework. package My::Ok; use Test2::API qw/context/; our @EXPORT = qw/my_ok/; use base 'Exporter'; # Just like ok() from Test::More sub my_ok($;$) { my ($bool, $name) = @_; my $ctx = context(); # Get a context $ctx->ok($bool, $name); $ctx->release; # Release the context return $bool; } See L<Test2::API::Context> for a list of methods available on the context object. =head2 TESTING YOUR TOOLS The C<intercept { ... }> tool lets you temporarily intercept all events generated by the test system: use Test2::API qw/intercept/; use My::Ok qw/my_ok/; my $events = intercept { # These events are not displayed my_ok(1, "pass"); my_ok(0, "fail"); }; As of version 1.302178 this now returns an arrayref that is also an instance of L<Test2::API::InterceptResult>. See the L<Test2::API::InterceptResult> documentation for details on how to best use it. =head2 OTHER API FUNCTIONS use Test2::API qw{ test2_init_done test2_stack test2_set_is_end test2_get_is_end test2_ipc test2_formatter_set test2_formatter test2_is_testing_done }; my $init = test2_init_done(); my $stack = test2_stack(); my $ipc = test2_ipc(); test2_formatter_set($FORMATTER) my $formatter = test2_formatter(); ... And others ... =head1 MAIN API EXPORTS All exports are optional. You must specify subs to import. use Test2::API qw/context intercept run_subtest/; This is the list of exports that are most commonly needed. If you are simply writing a tool, then this is probably all you need. If you need something and you cannot find it here, then you can also look at L</OTHER API EXPORTS>. These exports lack the 'test2_' prefix because of how important/common they are. Exports in the L</OTHER API EXPORTS> section have the 'test2_' prefix to ensure they stand out. =head2 context(...) Usage: =over 4 =item $ctx = context() =item $ctx = context(%params) =back The C<context()> function will always return the current context. If there is already a context active, it will be returned. If there is not an active context, one will be generated. When a context is generated it will default to using the file and line number where the currently running sub was called from. Please see L<Test2::API::Context/"CRITICAL DETAILS"> for important rules about what you can and cannot do with a context once it is obtained. B<Note> This function will throw an exception if you ignore the context object it returns. B<Note> On perls 5.14+ a depth check is used to insure there are no context leaks. This cannot be safely done on older perls due to L<https://rt.perl.org/Public/Bug/Display.html?id=127774> You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or C<$Test2::API::DO_DEPTH_CHECK = 1> B<BEFORE> loading L<Test2::API>. =head3 OPTIONAL PARAMETERS All parameters to C<context> are optional. =over 4 =item level => $int If you must obtain a context in a sub deeper than your entry point you can use this to tell it how many EXTRA stack frames to look back. If this option is not provided the default of C<0> is used. sub third_party_tool { my $sub = shift; ... # Does not obtain a context $sub->(); ... } third_party_tool(sub { my $ctx = context(level => 1); ... $ctx->release; }); =item wrapped => $int Use this if you need to write your own tool that wraps a call to C<context()> with the intent that it should return a context object. sub my_context { my %params = ( wrapped => 0, @_ ); $params{wrapped}++; my $ctx = context(%params); ... return $ctx; } sub my_tool { my $ctx = my_context(); ... $ctx->release; } If you do not do this, then tools you call that also check for a context will notice that the context they grabbed was created at the same stack depth, which will trigger protective measures that warn you and destroy the existing context. =item stack => $stack Normally C<context()> looks at the global hub stack. If you are maintaining your own L<Test2::API::Stack> instance you may pass it in to be used instead of the global one. =item hub => $hub Use this parameter if you want to obtain the context for a specific hub instead of whatever one happens to be at the top of the stack. =item on_init => sub { ... } This lets you provide a callback sub that will be called B<ONLY> if your call to C<context()> generated a new context. The callback B<WILL NOT> be called if C<context()> is returning an existing context. The only argument passed into the callback will be the context object itself. sub foo { my $ctx = context(on_init => sub { 'will run' }); my $inner = sub { # This callback is not run since we are getting the existing # context from our parent sub. my $ctx = context(on_init => sub { 'will NOT run' }); $ctx->release; } $inner->(); $ctx->release; } =item on_release => sub { ... } This lets you provide a callback sub that will be called when the context instance is released. This callback will be added to the returned context even if an existing context is returned. If multiple calls to context add callbacks, then all will be called in reverse order when the context is finally released. sub foo { my $ctx = context(on_release => sub { 'will run second' }); my $inner = sub { my $ctx = context(on_release => sub { 'will run first' }); # Neither callback runs on this release $ctx->release; } $inner->(); # Both callbacks run here. $ctx->release; } =back =head2 release($;$) Usage: =over 4 =item release $ctx; =item release $ctx, ...; =back This is intended as a shortcut that lets you release your context and return a value in one statement. This function will get your context, and an optional return value. It will release your context, then return your value. Scalar context is always assumed. sub tool { my $ctx = context(); ... return release $ctx, 1; } This tool is most useful when you want to return the value you get from calling a function that needs to see the current context: my $ctx = context(); my $out = some_tool(...); $ctx->release; return $out; We can combine the last 3 lines of the above like so: my $ctx = context(); release $ctx, some_tool(...); =head2 context_do(&;@) Usage: sub my_tool { context_do { my $ctx = shift; my (@args) = @_; $ctx->ok(1, "pass"); ... # No need to call $ctx->release, done for you on scope exit. } @_; } Using this inside your test tool takes care of a lot of boilerplate for you. It will ensure a context is acquired. It will capture and rethrow any exception. It will insure the context is released when you are done. It preserves the subroutine call context (array, scalar, void). This is the safest way to write a test tool. The only two downsides to this are a slight performance decrease, and some extra indentation in your source. If the indentation is a problem for you then you can take a peek at the next section. =head2 no_context(&;$) Usage: =over 4 =item no_context { ... }; =item no_context { ... } $hid; sub my_tool(&) { my $code = shift; my $ctx = context(); ... no_context { # Things in here will not see our current context, they get a new # one. $code->(); }; ... $ctx->release; }; =back This tool will hide a context for the provided block of code. This means any tools run inside the block will get a completely new context if they acquire one. The new context will be inherited by tools nested below the one that acquired it. This will normally hide the current context for the top hub. If you need to hide the context for a different hub you can pass in the optional C<$hid> parameter. =head2 intercept(&) Usage: my $events = intercept { ok(1, "pass"); ok(0, "fail"); ... }; This function takes a codeblock as its only argument, and it has a prototype. It will execute the codeblock, intercepting any generated events in the process. It will return an array reference with all the generated event objects. All events should be subclasses of L<Test2::Event>. As of version 1.302178 the events array that is returned is blssed as an L<Test2::API::InterceptResult> instance. L<Test2::API::InterceptResult> Provides a helpful interface for filtering and/or inspecting the events list overall, or individual events within the list. This is intended to help you test your test code. This is not intended for people simply writing tests. =head2 run_subtest(...) Usage: run_subtest($NAME, \&CODE, $BUFFERED, @ARGS) # or run_subtest($NAME, \&CODE, \%PARAMS, @ARGS) This will run the provided codeblock with the args in C<@args>. This codeblock will be run as a subtest. A subtest is an isolated test state that is condensed into a single L<Test2::Event::Subtest> event, which contains all events generated inside the subtest. =head3 ARGUMENTS: =over 4 =item $NAME The name of the subtest. =item \&CODE The code to run inside the subtest. =item $BUFFERED or \%PARAMS If this is a simple scalar then it will be treated as a boolean for the 'buffered' setting. If this is a hash reference then it will be used as a parameters hash. The param hash will be used for hub construction (with the specified keys removed). Keys that are removed and used by run_subtest: =over 4 =item 'buffered' => $bool Toggle buffered status. =item 'inherit_trace' => $bool Normally the subtest hub is pushed and the sub is allowed to generate its own root context for the hub. When this setting is turned on a root context will be created for the hub that shares the same trace as the current context. Set this to true if your tool is producing subtests without user-specified subs. =item 'no_fork' => $bool Defaults to off. Normally forking inside a subtest will actually fork the subtest, resulting in 2 final subtest events. This parameter will turn off that behavior, only the original process/thread will return a final subtest event. =back =item @ARGS Any extra arguments you want passed into the subtest code. =back =head3 BUFFERED VS UNBUFFERED (OR STREAMED) Normally all events inside and outside a subtest are sent to the formatter immediately by the hub. Sometimes it is desirable to hold off sending events within a subtest until the subtest is complete. This usually depends on the formatter being used. =over 4 =item Things not effected by this flag In both cases events are generated and stored in an array. This array is eventually used to populate the C<subevents> attribute on the L<Test2::Event::Subtest> event that is generated at the end of the subtest. This flag has no effect on this part, it always happens. At the end of the subtest, the final L<Test2::Event::Subtest> event is sent to the formatter. =item Things that are effected by this flag The C<buffered> attribute of the L<Test2::Event::Subtest> event will be set to the value of this flag. This means any formatter, listener, etc which looks at the event will know if it was buffered. =item Things that are formatter dependant Events within a buffered subtest may or may not be sent to the formatter as they happen. If a formatter fails to specify then the default is to B<NOT SEND> the events as they are generated, instead the formatter can pull them from the C<subevents> attribute. A formatter can specify by implementing the C<hide_buffered()> method. If this method returns true then events generated inside a buffered subtest will not be sent independently of the final subtest event. =back An example of how this is used is the L<Test2::Formatter::TAP> formatter. For unbuffered subtests the events are rendered as they are generated. At the end of the subtest, the final subtest event is rendered, but the C<subevents> attribute is ignored. For buffered subtests the opposite occurs, the events are NOT rendered as they are generated, instead the C<subevents> attribute is used to render them all at once. This is useful when running subtests tests in parallel, since without it the output from subtests would be interleaved together. =head1 OTHER API EXPORTS Exports in this section are not commonly needed. These all have the 'test2_' prefix to help ensure they stand out. You should look at the L</MAIN API EXPORTS> section before looking here. This section is one where "Great power comes with great responsibility". It is possible to break things badly if you are not careful with these. All exports are optional. You need to list which ones you want at import time: use Test2::API qw/test2_init_done .../; =head2 STATUS AND INITIALIZATION STATE These provide access to internal state and object instances. =over 4 =item $bool = test2_init_done() This will return true if the stack and IPC instances have already been initialized. It will return false if they have not. Init happens as late as possible. It happens as soon as a tool requests the IPC instance, the formatter, or the stack. =item $bool = test2_load_done() This will simply return the boolean value of the loaded flag. If Test2 has finished loading this will be true, otherwise false. Loading is considered complete the first time a tool requests a context. =item test2_set_is_end() =item test2_set_is_end($bool) This is used to toggle Test2's belief that the END phase has already started. With no arguments this will set it to true. With arguments it will set it to the first argument's value. This is used to prevent the use of C<caller()> in END blocks which can cause segfaults. This is only necessary in some persistent environments that may have multiple END phases. =item $bool = test2_get_is_end() Check if Test2 believes it is the END phase. =item $stack = test2_stack() This will return the global L<Test2::API::Stack> instance. If this has not yet been initialized it will be initialized now. =item $bool = test2_is_testing_done() This will return true if testing is complete and no other events should be sent. This is useful in things like warning handlers where you might want to turn warnings into events, but need them to start acting like normal warnings when testing is done. $SIG{__WARN__} = sub { my ($warning) = @_; if (test2_is_testing_done()) { warn @_; } else { my $ctx = context(); ... $ctx->release } } =item test2_ipc_disable Disable IPC. =item $bool = test2_ipc_diabled Check if IPC is disabled. =item test2_ipc_wait_enable() =item test2_ipc_wait_disable() =item $bool = test2_ipc_wait_enabled() These can be used to turn IPC waiting on and off, or check the current value of the flag. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =item $bool = test2_no_wait() =item test2_no_wait($bool) B<DISCOURAGED>: This is a confusing interface, it is better to use C<test2_ipc_wait_enable()>, C<test2_ipc_wait_disable()> and C<test2_ipc_wait_enabled()>. This can be used to get/set the no_wait status. Waiting is turned on by default. Waiting will cause the parent process/thread to wait until all child processes and threads are finished before exiting. You will almost never want to turn this off. =item $fh = test2_stdout() =item $fh = test2_stderr() These functions return the filehandles that test output should be written to. They are primarily useful when writing a custom formatter and code that turns events into actual output (TAP, etc.). They will return a dupe of the original filehandles that formatted output can be sent to regardless of whatever state the currently running test may have left STDOUT and STDERR in. =item test2_reset_io() Re-dupe the internal filehandles returned by C<test2_stdout()> and C<test2_stderr()> from the current STDOUT and STDERR. You shouldn't need to do this except in very peculiar situations (for example, you're testing a new formatter and you need control over where the formatter is sending its output.) =back =head2 BEHAVIOR HOOKS These are hooks that allow you to add custom behavior to actions taken by Test2 and tools built on top of it. =over 4 =item test2_add_callback_exit(sub { ... }) This can be used to add a callback that is called after all testing is done. This is too late to add additional results, the main use of this callback is to set the exit code. test2_add_callback_exit( sub { my ($context, $exit, \$new_exit) = @_; ... } ); The C<$context> passed in will be an instance of L<Test2::API::Context>. The C<$exit> argument will be the original exit code before anything modified it. C<$$new_exit> is a reference to the new exit code. You may modify this to change the exit code. Please note that C<$$new_exit> may already be different from C<$exit> =item test2_add_callback_post_load(sub { ... }) Add a callback that will be called when Test2 is finished loading. This means the callback will be run once, the first time a context is obtained. If Test2 has already finished loading then the callback will be run immediately. =item test2_add_callback_testing_done(sub { ... }) This adds your coderef as a follow-up to the root hub after Test2 is finished loading. This is essentially a helper to do the following: test2_add_callback_post_load(sub { my $stack = test2_stack(); $stack->top; # Insure we have a hub my ($hub) = Test2::API::test2_stack->all; $hub->set_active(1); $hub->follow_up(sub { ... }); # <-- Your coderef here }); =item test2_add_callback_context_acquire(sub { ... }) Add a callback that will be called every time someone tries to acquire a context. This will be called on EVERY call to C<context()>. It gets a single argument, a reference to the hash of parameters being used the construct the context. This is your chance to change the parameters by directly altering the hash. test2_add_callback_context_acquire(sub { my $params = shift; $params->{level}++; }); This is a very scary API function. Please do not use this unless you need to. This is here for L<Test::Builder> and backwards compatibility. This has you directly manipulate the hash instead of returning a new one for performance reasons. =item test2_add_callback_context_init(sub { ... }) Add a callback that will be called every time a new context is created. The callback will receive the newly created context as its only argument. =item test2_add_callback_context_release(sub { ... }) Add a callback that will be called every time a context is released. The callback will receive the released context as its only argument. =item test2_add_callback_pre_subtest(sub { ... }) Add a callback that will be called every time a subtest is going to be run. The callback will receive the subtest name, coderef, and any arguments. =item @list = test2_list_context_acquire_callbacks() Return all the context acquire callback references. =item @list = test2_list_context_init_callbacks() Returns all the context init callback references. =item @list = test2_list_context_release_callbacks() Returns all the context release callback references. =item @list = test2_list_exit_callbacks() Returns all the exit callback references. =item @list = test2_list_post_load_callbacks() Returns all the post load callback references. =item @list = test2_list_pre_subtest_callbacks() Returns all the pre-subtest callback references. =item test2_add_uuid_via(sub { ... }) =item $sub = test2_add_uuid_via() This allows you to provide a UUID generator. If provided UUIDs will be attached to all events, hubs, and contexts. This is useful for storing, tracking, and linking these objects. The sub you provide should always return a unique identifier. Most things will expect a proper UUID string, however nothing in Test2::API enforces this. The sub will receive exactly 1 argument, the type of thing being tagged 'context', 'hub', or 'event'. In the future additional things may be tagged, in which case new strings will be passed in. These are purely informative, you can (and usually should) ignore them. =back =head2 IPC AND CONCURRENCY These let you access, or specify, the IPC system internals. =over 4 =item $bool = test2_has_ipc() Check if IPC is enabled. =item $ipc = test2_ipc() This will return the global L<Test2::IPC::Driver> instance. If this has not yet been initialized it will be initialized now. =item test2_ipc_add_driver($DRIVER) Add an IPC driver to the list. This will add the driver to the start of the list. =item @drivers = test2_ipc_drivers() Get the list of IPC drivers. =item $bool = test2_ipc_polling() Check if polling is enabled. =item test2_ipc_enable_polling() Turn on polling. This will cull events from other processes and threads every time a context is created. =item test2_ipc_disable_polling() Turn off IPC polling. =item test2_ipc_enable_shm() Legacy, this is currently a no-op that returns 0; =item test2_ipc_set_pending($uniq_val) Tell other processes and events that an event is pending. C<$uniq_val> should be a unique value no other thread/process will generate. B<Note:> After calling this C<test2_ipc_get_pending()> will return 1. This is intentional, and not avoidable. =item $pending = test2_ipc_get_pending() This returns -1 if there is no way to check (assume yes) This returns 0 if there are (most likely) no pending events. This returns 1 if there are (likely) pending events. Upon return it will reset, nothing else will be able to see that there were pending events. =item $timeout = test2_ipc_get_timeout() =item test2_ipc_set_timeout($timeout) Get/Set the timeout value for the IPC system. This timeout is how long the IPC system will wait for child processes and threads to finish before aborting. The default value is C<30> seconds. =back =head2 MANAGING FORMATTERS These let you access, or specify, the formatters that can/should be used. =over 4 =item $formatter = test2_formatter This will return the global formatter class. This is not an instance. By default the formatter is set to L<Test2::Formatter::TAP>. You can override this default using the C<T2_FORMATTER> environment variable. Normally 'Test2::Formatter::' is prefixed to the value in the environment variable: $ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter $ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter If you want to specify a full module name you use the '+' prefix: $ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter =item test2_formatter_set($class_or_instance) Set the global formatter class. This can only be set once. B<Note:> This will override anything specified in the 'T2_FORMATTER' environment variable. =item @formatters = test2_formatters() Get a list of all loaded formatters. =item test2_formatter_add($class_or_instance) Add a formatter to the list. Last formatter added is used at initialization. If this is called after initialization a warning will be issued. =back =head1 OTHER EXAMPLES See the C</Examples/> directory included in this distribution. =head1 SEE ALSO L<Test2::API::Context> - Detailed documentation of the context object. L<Test2::IPC> - The IPC system used for threading/fork support. L<Test2::Formatter> - Formatters such as TAP live here. L<Test2::Event> - Events live in this namespace. L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how C<intercept()> and C<run_subtest()> are implemented. =head1 MAGIC This package has an END block. This END block is responsible for setting the exit code based on the test results. This end block also calls the callbacks that can be added to this package. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Transition.pod 0000444 00000032267 14711217505 0011445 0 ustar 00 =pod =head1 NAME Test2::Transition - Transition notes when upgrading to Test2 =head1 DESCRIPTION This is where gotchas and breakages related to the Test2 upgrade are documented. The upgrade causes Test::Builder to defer to Test2 under the hood. This transition is mostly transparent, but there are a few cases that can trip you up. =head1 THINGS THAT BREAK This is the list of scenarios that break with the new internals. =head2 Test::Builder1.5/2 conditionals =head3 The Problem a few years back there were two attempts to upgrade/replace Test::Builder. Confusingly these were called Test::Builder2 and Test::Builder1.5, in that order. Many people put conditionals in their code to check the Test::Builder version number and adapt their code accordingly. The Test::Builder2/1.5 projects both died out. Now the conditional code people added has become a mine field. A vast majority of modules broken by Test2 fall into this category. =head3 The Fix The fix is to remove all Test::Builder1.5/2 related code. Either use the legacy Test::Builder API, or use Test2 directly. =head2 Replacing the Test::Builder singleton =head3 The Problem Some test modules would replace the Test::Builder singleton instance with their own instance or subclass. This was usually done to intercept or modify results as they happened. The Test::Builder singleton is now a simple compatibility wrapper around Test2. The Test::Builder singleton is no longer the central place for results. Many results bypass the Test::Builder singleton completely, which breaks and behavior intended when replacing the singleton. =head3 The Fix If you simply want to intercept all results instead of letting them go to TAP, you should look at the L<Test2::API> docs and read about pushing a new hub onto the hub stack. Replacing the hub temporarily is now the correct way to intercept results. If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >> method exported by Test::More to watch events as they are fired. If you wish to modify results before they go to TAP look at the C<< Test2::Hub->filter() >> method. =head2 Directly Accessing Hash Elements =head3 The Problem Some modules look directly at hash keys on the Test::Builder singleton. The problem here is that the Test::Builder singleton no longer holds anything important. =head3 The Fix The fix is to use the API specified in L<Test2::API> to look at or modify state as needed. =head2 Subtest indentation =head3 The Problem An early change, in fact the change that made Test2 an idea, was a change to the indentation of the subtest note. It was decided it would be more readable to outdent the subtest note instead of having it inline with the subtest: # subtest foo ok 1 - blah 1..1 ok 1 - subtest foo The old style indented the note: # subtest foo ok 1 - blah 1..1 ok 1 - subtest foo This breaks tests that do string comparison of TAP output. =head3 The Fix my $indent = $INC{'Test2/API.pm'} ? '' : ' '; is( $subtest_output, "${indent}# subtest foo", "Got subtest note" ); Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be expected. If it is not set, then the old Test::Builder is in use, indentation should be expected. =head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED This is a list of cpan modules that have been known to have been broken by the upgrade at one point. =head2 WORKS BUT TESTS WILL FAIL These modules still function correctly, but their test suites will not pass. If you already have these modules installed then you can continue to use them. If you are trying to install them after upgrading Test::Builder you will need to force installation, or bypass the broken tests. =over 4 =item Test::DBIx::Class::Schema This module has a test that appears to work around a Test::Builder bug. The bug appears to have been fixed by Test2, which means the workaround causes a failure. This can be easily updated, but nobody has done so yet. Known broken in versions: 1.0.9 and older =item Device::Chip Tests break due to subtest indentation. Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has been submitted to fix the issue. =back =head2 UPGRADE SUGGESTED These are modules that did not break, but had broken test suites that have since been fixed. =over 4 =item Test::Exception Old versions work fine, but have a minor test name behavior that breaks with Test2. Old versions will no longer install because of this. The latest version on CPAN will install just fine. Upgrading is not required, but is recommended. Fixed in version: 0.43 =item Data::Peek Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch was applied to correct things that changed. The module itself works fine, there is no need to upgrade. Fixed in version: 0.45 =item circular::require Some tests were fragile and required base.pm to be loaded at a late stage. Test2 was loading base.pm too early. The tests were updated to fix this. The module itself never broke, you do not need to upgrade. Fixed in version: 0.12 =item Test::Module::Used A test worked around a now-fixed planning bug. There is no need to upgrade if you have an old version installed. New versions install fine if you want them. Fixed in version: 0.2.5 =item Test::Moose::More Some tests were fragile, but have been fixed. The actual breakage was from the subtest comment indentation change. No need to upgrade, old versions work fine. Only new versions will install. Fixed in version: 0.025 =item Test::FITesque This was broken by a bugfix to how planning is done. The test was updated after the bugfix. Fixed in version: 0.04 =item Test::Kit Old versions work fine, but would not install because L<Test::Aggregate> was in the dependency chain. An upgrade should not be needed. Fixed in version: 2.15 =item autouse A test broke because it depended on Scalar::Util not being loaded. Test2 loads Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's load status. There is no need to upgrade if you already have it installed. Fixed in version: 1.11 =back =head2 NEED TO UPGRADE =over 4 =item Test::SharedFork Old versions need to directly access Test::Builder singleton hash elements. The latest version on CPAN will still do this on old Test::Builder, but will defer to L<Test2::IPC> on Test2. Fixed in version: 0.35 =item Test::Builder::Clutch This works by doing overriding methods on the singleton, and directly accessing hash values on the singleton. A new version has been released that uses the Test2 API to accomplish the same result in a saner way. Fixed in version: 0.07 =item Test::Dist::VersionSync This had Test::Builder2 conditionals. This was fixed by removing the conditionals. Fixed in version: 1.1.4 =item Test::Modern This relied on C<< Test::Builder->_try() >> which was a private method, documented as something nobody should use. This was fixed by using a different tool. Fixed in version: 0.012 =item Test::UseAllModules Version 0.14 relied on C<< Test::Builder->history >> which was available in Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder internals. Fixed in version: 0.15 =item Test::More::Prefix Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>. Fixed by adding an event filter that modifies the message instead when running under Test2. Fixed in version: 0.007 =back =head2 STILL BROKEN =over 4 =item Test::Aggregate This distribution directly accesses the hash keys in the L<Test::Builder> singleton. It also approaches the problem from the wrong angle, please consider using L<Test2::Aggregate> for similar functionality and L<Test2::Harness> which allows module preloading at the harness level. Still broken as of version: 0.373 =item Test::Wrapper This module directly uses hash keys in the L<Test::Builder> singleton. This module is also obsolete thanks to the benefits of L<Test2>. Use C<intercept()> from L<Test2::API> to achieve a similar result. Still broken as of version: 0.3.0 =item Test::ParallelSubtest This module overrides C<Test::Builder::subtest()> and C<Test::Builder::done_testing()>. It also directly accesses hash elements of the singleton. It has not yet been fixed. Alternatives: L<Test2::AsyncSubtest> and L<Test2::Workflow> (not stable). Still broken as of version: 0.05 =item Test::Pretty See https://github.com/tokuhirom/Test-Pretty/issues/25 The author admits the module is crazy, and he is awaiting a stable release of something new (Test2) to completely rewrite it in a sane way. Still broken as of version: 0.32 =item Net::BitTorrent The tests for this module directly access L<Test::Builder> hash keys. Most, if not all of these hash keys have public API methods that could be used instead to avoid the problem. Still broken in version: 0.052 =item Test::Group It monkeypatches Test::Builder, and calls it "black magic" in the code. Still broken as of version: 0.20 =item Test::Flatten This modifies the Test::Builder internals in many ways. A better was to accomplish the goal of this module is to write your own subtest function. Still broken as of version: 0.11 =item Log::Dispatch::Config::TestLog Modifies Test::Builder internals. Still broken as of version: 0.02 =item Test::Able Modifies Test::Builder internals. Still broken as of version: 0.11 =back =head1 MAKE ASSERTIONS -> SEND EVENTS =head2 LEGACY use Test::Builder; # A majority of tools out there do this: # my $TB = Test::Builder->new; # This works, but has always been wrong, forcing Test::Builder to implement # subtests as a horrific hack. It also causes problems for tools that try # to replace the singleton (also discouraged). sub my_ok($;$) { my ($bool, $name) = @_; my $TB = Test::Builder->new; $TB->ok($bool, $name); } sub my_diag($) { my ($msg) = @_; my $TB = Test::Builder->new; $TB->diag($msg); } =head2 TEST2 use Test2::API qw/context/; sub my_ok($;$) { my ($bool, $name) = @_; my $ctx = context(); $ctx->ok($bool, $name); $ctx->release; } sub my_diag($) { my ($msg) = @_; my $ctx = context(); $ctx->diag($msg); $ctx->release; } The context object has API compatible implementations of the following methods: =over 4 =item ok($bool, $name) =item diag(@messages) =item note(@messages) =item subtest($name, $code) =back If you are looking for helpers with C<is>, C<like>, and others, see L<Test2::Suite>. =head1 WRAP EXISTING TOOLS =head2 LEGACY use Test::More; sub exclusive_ok { my ($bool1, $bool2, $name) = @_; # Ensure errors are reported 1 level higher local $Test::Builder::Level = $Test::Builder::Level + 1; $ok = $bool1 || $bool2; $ok &&= !($bool1 && $bool2); ok($ok, $name); return $bool; } Every single tool in the chain from this, to C<ok>, to anything C<ok> calls needs to increment the C<$Level> variable. When an error occurs Test::Builder will do a trace to the stack frame determined by C<$Level>, and report that file+line as the one where the error occurred. If you or any other tool you use forgets to set C<$Level> then errors will be reported to the wrong place. =head2 TEST2 use Test::More; sub exclusive_ok { my ($bool1, $bool2, $name) = @_; # Grab and store the context, even if you do not need to use it # directly. my $ctx = context(); $ok = $bool1 || $bool2; $ok &&= !($bool1 && $bool2); ok($ok, $name); $ctx->release; return $bool; } Instead of using C<$Level> to perform a backtrace, Test2 uses a context object. In this sample you create a context object and store it. This locks the context (errors report 1 level up from here) for all wrapped tools to find. You do not need to use the context object, but you do need to store it in a variable. Once the sub ends the C<$ctx> variable is destroyed which lets future tools find their own. =head1 USING UTF8 =head2 LEGACY # Set the mode BEFORE anything loads Test::Builder use open ':std', ':encoding(utf8)'; use Test::More; Or # Modify the filehandles my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; binmode $builder->todo_output, ":encoding(utf8)"; =head2 TEST2 use Test2::API qw/test2_stack/; test2_stack->top->format->encoding('utf8'); Though a much better way is to use the L<Test2::Plugin::UTF8> plugin, which is part of L<Test2::Suite>. =head1 AUTHORS, CONTRIBUTORS AND REVIEWERS The following people have all contributed to this document in some way, even if only for review. =over 4 =item Chad Granum (EXODIST) E<lt>exodist@cpan.orgE<gt> =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINER =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> =cut perl5/Test2/Util.pm 0000444 00000024404 14711217506 0010055 0 ustar 00 package Test2::Util; use strict; use warnings; our $VERSION = '1.302186'; use POSIX(); use Config qw/%Config/; use Carp qw/croak/; BEGIN { local ($@, $!, $SIG{__DIE__}); *HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 }; } our @EXPORT_OK = qw{ try pkg_to_file get_tid USE_THREADS CAN_THREAD CAN_REALLY_FORK CAN_FORK CAN_SIGSYS IS_WIN32 ipc_separator gen_uid do_rename do_unlink try_sig_mask clone_io }; BEGIN { require Exporter; our @ISA = qw(Exporter) } BEGIN { *IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 }; } sub _can_thread { return 0 unless $] >= 5.008001; return 0 unless $Config{'useithreads'}; # Threads are broken on perl 5.10.0 built with gcc 4.8+ if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) { my @parts = split /\./, $Config{'gccversion'}; return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8); } # Change to a version check if this ever changes return 0 if $INC{'Devel/Cover.pm'}; return 1; } sub _can_fork { return 1 if $Config{d_fork}; return 0 unless IS_WIN32 || $^O eq 'NetWare'; return 0 unless $Config{useithreads}; return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/; return _can_thread(); } BEGIN { no warnings 'once'; *CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 }; } my $can_fork; sub CAN_FORK () { return $can_fork if defined $can_fork; $can_fork = !!_can_fork(); no warnings 'redefine'; *CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 }; $can_fork; } my $can_really_fork; sub CAN_REALLY_FORK () { return $can_really_fork if defined $can_really_fork; $can_really_fork = !!$Config{d_fork}; no warnings 'redefine'; *CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 }; $can_really_fork; } sub _manual_try(&;@) { my $code = shift; my $args = \@_; my $err; my $die = delete $SIG{__DIE__}; eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; $die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__}; return (!defined($err), $err); } sub _local_try(&;@) { my $code = shift; my $args = \@_; my $err; no warnings; local $SIG{__DIE__}; eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n"; return (!defined($err), $err); } # Older versions of perl have a nasty bug on win32 when localizing a variable # before forking or starting a new thread. So for those systems we use the # non-local form. When possible though we use the faster 'local' form. BEGIN { if (IS_WIN32 && $] < 5.020002) { *try = \&_manual_try; } else { *try = \&_local_try; } } BEGIN { if (CAN_THREAD) { if ($INC{'threads.pm'}) { # Threads are already loaded, so we do not need to check if they # are loaded each time *USE_THREADS = sub() { 1 }; *get_tid = sub() { threads->tid() }; } else { # :-( Need to check each time to see if they have been loaded. *USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 }; *get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 }; } } else { # No threads, not now, not ever! *USE_THREADS = sub() { 0 }; *get_tid = sub() { 0 }; } } sub pkg_to_file { my $pkg = shift; my $file = $pkg; $file =~ s{(::|')}{/}g; $file .= '.pm'; return $file; } sub ipc_separator() { "~" } my $UID = 1; sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) } sub _check_for_sig_sys { my $sig_list = shift; return $sig_list =~ m/\bSYS\b/; } BEGIN { if (_check_for_sig_sys($Config{sig_name})) { *CAN_SIGSYS = sub() { 1 }; } else { *CAN_SIGSYS = sub() { 0 }; } } my %PERLIO_SKIP = ( unix => 1, via => 1, ); sub clone_io { my ($fh) = @_; my $fileno = eval { fileno($fh) }; return $fh if !defined($fileno) || !length($fileno) || $fileno < 0; open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!"; my %seen; my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : (); binmode($out, join(":", "", "raw", @layers)); my $old = select $fh; my $af = $|; select $out; $| = $af; select $old; return $out; } BEGIN { if (IS_WIN32) { my $max_tries = 5; *do_rename = sub { my ($from, $to) = @_; my $err; for (1 .. $max_tries) { return (1) if rename($from, $to); $err = "$!"; last if $_ == $max_tries; sleep 1; } return (0, $err); }; *do_unlink = sub { my ($file) = @_; my $err; for (1 .. $max_tries) { return (1) if unlink($file); $err = "$!"; last if $_ == $max_tries; sleep 1; } return (0, "$!"); }; } else { *do_rename = sub { my ($from, $to) = @_; return (1) if rename($from, $to); return (0, "$!"); }; *do_unlink = sub { my ($file) = @_; return (1) if unlink($file); return (0, "$!"); }; } } sub try_sig_mask(&) { my $code = shift; my ($old, $blocked); unless(IS_WIN32) { my $to_block = POSIX::SigSet->new( POSIX::SIGINT(), POSIX::SIGALRM(), POSIX::SIGHUP(), POSIX::SIGTERM(), POSIX::SIGUSR1(), POSIX::SIGUSR2(), ); $old = POSIX::SigSet->new; $blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old); # Silently go on if we failed to log signals, not much we can do. } my ($ok, $err) = &try($code); # If our block was successful we want to restore the old mask. POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked; return ($ok, $err); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util - Tools used by Test2 and friends. =head1 DESCRIPTION Collection of tools used by L<Test2> and friends. =head1 EXPORTS All exports are optional. You must specify subs to import. =over 4 =item ($success, $error) = try { ... } Eval the codeblock, return success or failure, and the error message. This code protects $@ and $!, they will be restored by the end of the run. This code also temporarily blocks $SIG{DIE} handlers. =item protect { ... } Similar to try, except that it does not catch exceptions. The idea here is to protect $@ and $! from changes. $@ and $! will be restored to whatever they were before the run so long as it is successful. If the run fails $! will still be restored, but $@ will contain the exception being thrown. =item CAN_FORK True if this system is capable of true or pseudo-fork. =item CAN_REALLY_FORK True if the system can really fork. This will be false for systems where fork is emulated. =item CAN_THREAD True if this system is capable of using threads. =item USE_THREADS Returns true if threads are enabled, false if they are not. =item get_tid This will return the id of the current thread when threads are enabled, otherwise it returns 0. =item my $file = pkg_to_file($package) Convert a package name to a filename. =item $string = ipc_separator() Get the IPC separator. Currently this is always the string C<'~'>. =item $string = gen_uid() Generate a unique id (NOT A UUID). This will typically be the process id, the thread id, the time, and an incrementing integer all joined with the C<ipc_separator()>. These ID's are unique enough for most purposes. For identical ids to be generated you must have 2 processes with the same PID generate IDs at the same time with the same current state of the incrementing integer. This is a perfectly reasonable thing to expect to happen across multiple machines, but is quite unlikely to happen on one machine. This can fail to be unique if a process generates an id, calls exec, and does it again after the exec and it all happens in less than a second. It can also happen if the systems process id's cycle in less than a second allowing 2 different programs that use this generator to run with the same PID in less than a second. Both these cases are sufficiently unlikely. If you need universally unique ids, or ids that are unique in these conditions, look at L<Data::UUID>. =item ($ok, $err) = do_rename($old_name, $new_name) Rename a file, this wraps C<rename()> in a way that makes it more reliable cross-platform when trying to rename files you recently altered. =item ($ok, $err) = do_unlink($filename) Unlink a file, this wraps C<unlink()> in a way that makes it more reliable cross-platform when trying to unlink files you recently altered. =item ($ok, $err) = try_sig_mask { ... } Complete an action with several signals masked, they will be unmasked at the end allowing any signals that were intercepted to get handled. This is primarily used when you need to make several actions atomic (against some signals anyway). Signals that are intercepted: =over 4 =item SIGINT =item SIGALRM =item SIGHUP =item SIGTERM =item SIGUSR1 =item SIGUSR2 =back =back =head1 NOTES && CAVEATS =over 4 =item 5.10.0 Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a segfault whenever a new thread is launched. Test2 will attempt to detect this, and note that the system is not capable of forking when it is detected. =item Devel::Cover Devel::Cover does not support threads. CAN_THREAD will return false if Devel::Cover is loaded before the check is first run. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =item Kent Fredric E<lt>kentnl@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Note.pm 0000444 00000002611 14711217506 0011122 0 ustar 00 package Test2::Event::Note; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } sub summary { $_[0]->{+MESSAGE} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{info} = [ { tag => 'NOTE', debug => 0, details => $self->{+MESSAGE}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Note - Note event type =head1 DESCRIPTION Notes, typically rendered to STDOUT. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Note; my $ctx = context(); my $event = $ctx->Note($message); =head1 ACCESSORS =over 4 =item $note->message The message for the note. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Waiting.pm 0000444 00000002326 14711217506 0011622 0 ustar 00 package Test2::Event::Waiting; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; sub global { 1 }; sub summary { "IPC is waiting for children to finish..." } sub facet_data { my $self = shift; my $out = $self->common_facet_data; push @{$out->{info}} => { tag => 'INFO', debug => 0, details => $self->summary, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Waiting - Tell all procs/threads it is time to be done =head1 DESCRIPTION This event has no data of its own. This event is sent out by the IPC system when the main process/thread is ready to end. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Pass.pm 0000444 00000003616 14711217507 0011132 0 ustar 00 package Test2::Event::Pass; use strict; use warnings; our $VERSION = '1.302186'; use Test2::EventFacet::Info; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event); *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; } use Test2::Util::HashBase qw{ -name -info }; ############## # Old API sub summary { "pass" } sub increments_count { 1 } sub causes_fail { 0 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub terminate { () } sub global { () } sub sets_plan { () } ############## # New API sub add_info { my $self = shift; for my $in (@_) { $in = {%$in} if ref($in) ne 'ARRAY'; $in = Test2::EventFacet::Info->new($in); push @{$self->{+INFO}} => $in; } } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = 'pass'; $out->{assert} = {pass => 1, details => $self->{+NAME}}; $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Pass - Event for a simple passing assertion =head1 DESCRIPTION This is an optimal representation of a passing assertion. =head1 SYNOPSIS use Test2::API qw/context/; sub pass { my ($name) = @_; my $ctx = context(); $ctx->pass($name); $ctx->release; } =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Ok.pm 0000444 00000006132 14711217507 0010571 0 ustar 00 package Test2::Event::Ok; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{ pass effective_pass name todo }; sub init { my $self = shift; # Do not store objects here, only true or false $self->{+PASS} = $self->{+PASS} ? 1 : 0; $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); } { no warnings 'redefine'; sub set_todo { my $self = shift; my ($todo) = @_; $self->{+TODO} = $todo; $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; } } sub increments_count { 1 }; sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } sub summary { my $self = shift; my $name = $self->{+NAME} || "Nameless Assertion"; my $todo = $self->{+TODO}; if ($todo) { $name .= " (TODO: $todo)"; } elsif (defined $todo) { $name .= " (TODO)" } return $name; } sub extra_amnesty { my $self = shift; return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); return { tag => 'TODO', details => $self->{+TODO}, }; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{assert} = { no_debug => 1, # Legacy behavior pass => $self->{+PASS}, details => $self->{+NAME}, }; if (my @exra_amnesty = $self->extra_amnesty) { my %seen; # It is possible the extra amnesty can be a duplicate, so filter it. $out->{amnesty} = [ grep { !$seen{defined($_->{tag}) ? $_->{tag} : ''}->{defined($_->{details}) ? $_->{details} : ''}++ } @exra_amnesty, @{$out->{amnesty}}, ]; } return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Ok - Ok event type =head1 DESCRIPTION Ok events are generated whenever you run a test that produces a result. Examples are C<ok()>, and C<is()>. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Ok; my $ctx = context(); my $event = $ctx->ok($bool, $name, \@diag); or: my $ctx = context(); my $event = $ctx->send_event( 'Ok', pass => $bool, name => $name, ); =head1 ACCESSORS =over 4 =item $rb = $e->pass The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =item $name = $e->name Name of the test. =item $b = $e->effective_pass This is the true/false value of the test after TODO and similar modifiers are taken into account. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Encoding.pm 0000444 00000003351 14711217507 0011746 0 ustar 00 package Test2::Event::Encoding; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/encoding/; sub init { my $self = shift; defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; } sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control}->{encoding} = $self->{+ENCODING}; $out->{about}->{details} = $self->summary; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Encoding - Set the encoding for the output stream =head1 DESCRIPTION The encoding event is generated when a test file wants to specify the encoding to be used when formatting its output. This event is intended to be produced by formatter classes and used for interpreting test names, message contents, etc. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Encoding; my $ctx = context(); my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); =head1 METHODS Inherits from L<Test2::Event>. Also defines: =over 4 =item $encoding = $e->encoding The encoding being specified. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Exception.pm 0000444 00000003365 14711217507 0012163 0 ustar 00 package Test2::Event::Exception; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{error}; sub init { my $self = shift; $self->{+ERROR} = "$self->{+ERROR}"; } sub causes_fail { 1 } sub summary { my $self = shift; chomp(my $msg = "Exception: " . $self->{+ERROR}); return $msg; } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{errors} = [ { tag => 'ERROR', fail => 1, details => $self->{+ERROR}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Exception - Exception event =head1 DESCRIPTION An exception event will display to STDERR, and will prevent the overall test file from passing. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Exception; my $ctx = context(); my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); =head1 METHODS Inherits from L<Test2::Event>. Also defines: =over 4 =item $reason = $e->error The reason for the exception. =back =head1 CAVEATS Be aware that all exceptions are stringified during construction. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Skip.pm 0000444 00000003732 14711217510 0011123 0 ustar 00 package Test2::Event::Skip; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{reason}; sub init { my $self = shift; $self->SUPER::init; $self->{+EFFECTIVE_PASS} = 1; } sub causes_fail { 0 } sub summary { my $self = shift; my $out = $self->SUPER::summary(@_); if (my $reason = $self->reason) { $out .= " (SKIP: $reason)"; } else { $out .= " (SKIP)"; } return $out; } sub extra_amnesty { my $self = shift; my @out; push @out => { tag => 'TODO', details => $self->{+TODO}, } if defined $self->{+TODO}; push @out => { tag => 'skip', details => $self->{+REASON}, inherited => 0, }; return @out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Skip - Skip event type =head1 DESCRIPTION Skip events bump test counts just like L<Test2::Event::Ok> events, but they can never fail. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Skip; my $ctx = context(); my $event = $ctx->skip($name, $reason); or: my $ctx = context(); my $event = $ctx->send_event( 'Skip', name => $name, reason => $reason, ); =head1 ACCESSORS =over 4 =item $reason = $e->reason The original true/false value of whatever was passed into the event (but reduced down to 1 or 0). =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> =cut perl5/Test2/Event/Bail.pm 0000444 00000003240 14711217510 0011056 0 ustar 00 package Test2::Event::Bail; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{reason buffered}; # Make sure the tests terminate sub terminate { 255 }; sub global { 1 }; sub causes_fail { 1 } sub summary { my $self = shift; return "Bail out! " . $self->{+REASON} if $self->{+REASON}; return "Bail out!"; } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control} = { global => 1, halt => 1, details => $self->{+REASON}, terminate => 255, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Bail - Bailout! =head1 DESCRIPTION The bailout event is generated when things go horribly wrong and you need to halt all testing in the current file. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Bail; my $ctx = context(); my $event = $ctx->bail('Stuff is broken'); =head1 METHODS Inherits from L<Test2::Event>. Also defines: =over 4 =item $reason = $e->reason The reason for the bailout. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Subtest.pm 0000444 00000006472 14711217510 0011652 0 ustar 00 package Test2::Event::Subtest; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid start_stamp stop_stamp}; sub init { my $self = shift; $self->SUPER::init(); $self->{+SUBEVENTS} ||= []; if ($self->{+EFFECTIVE_PASS}) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; } } { no warnings 'redefine'; sub set_subevents { my $self = shift; my @subevents = @_; if ($self->{+EFFECTIVE_PASS}) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; } $self->{+SUBEVENTS} = \@subevents; } sub set_effective_pass { my $self = shift; my ($pass) = @_; if ($pass) { $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; } elsif ($self->{+EFFECTIVE_PASS} && !$pass) { for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; } } $self->{+EFFECTIVE_PASS} = $pass; } } sub summary { my $self = shift; my $name = $self->{+NAME} || "Nameless Subtest"; my $todo = $self->{+TODO}; if ($todo) { $name .= " (TODO: $todo)"; } elsif (defined $todo) { $name .= " (TODO)"; } return $name; } sub facet_data { my $self = shift; my $out = $self->SUPER::facet_data(); my $start = $self->start_stamp; my $stop = $self->stop_stamp; $out->{parent} = { hid => $self->subtest_id, children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], buffered => $self->{+BUFFERED}, $start ? (start_stamp => $start) : (), $stop ? (stop_stamp => $stop) : (), }; return $out; } sub add_amnesty { my $self = shift; for my $am (@_) { $am = {%$am} if ref($am) ne 'ARRAY'; $am = Test2::EventFacet::Amnesty->new($am); push @{$self->{+AMNESTY}} => $am; for my $e (@{$self->{+SUBEVENTS}}) { $e->add_amnesty($am->clone(inherited => 1)); } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Subtest - Event for subtest types =head1 DESCRIPTION This class represents a subtest. This class is a subclass of L<Test2::Event::Ok>. =head1 ACCESSORS This class inherits from L<Test2::Event::Ok>. =over 4 =item $arrayref = $e->subevents Returns the arrayref containing all the events from the subtest =item $bool = $e->buffered True if the subtest is buffered, that is all subevents render at once. If this is false it means all subevents render as they are produced. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/V2.pm 0000444 00000011453 14711217510 0010503 0 ustar 00 package Test2::Event::V2; use strict; use warnings; our $VERSION = '1.302186'; use Scalar::Util qw/reftype/; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::Facets2Legacy qw{ causes_fail diagnostics global increments_count no_display sets_plan subtest_id summary terminate }; use Test2::Util::HashBase qw/-about/; sub non_facet_keys { return ( +UUID, Test2::Util::ExternalMeta::META_KEY(), ); } sub init { my $self = shift; my $uuid; if ($uuid = $self->{+UUID}) { croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet" if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid; $self->{+ABOUT}->{uuid} = $uuid; } elsif ($self->{+ABOUT} && $self->{+ABOUT}->{uuid}) { $uuid = $self->{+ABOUT}->{uuid}; $self->SUPER::set_uuid($uuid); } # Clone the trace, make sure it is blessed if (my $trace = $self->{+TRACE}) { $self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace); } } sub set_uuid { my $self = shift; my ($uuid) = @_; $self->{+ABOUT}->{uuid} = $uuid; $self->SUPER::set_uuid($uuid); } sub facet_data { my $self = shift; my $f = { %{$self} }; delete $f->{$_} for $self->non_facet_keys; my %out; for my $k (keys %$f) { next if substr($k, 0, 1) eq '_'; my $data = $f->{$k} or next; # Key is there, but no facet my $is_list = 'ARRAY' eq (reftype($data) || ''); $out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data}; } if (my $meta = $self->meta_facet_data) { $out{meta} = {%$meta, %{$out{meta} || {}}}; } return \%out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::V2 - Second generation event. =head1 DESCRIPTION This is the event type that should be used instead of L<Test2::Event> or its legacy subclasses. =head1 SYNOPSIS =head2 USING A CONTEXT use Test2::API qw/context/; sub my_tool { my $ctx = context(); my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]); $ctx->release; return $event; } =head2 USING THE CONSTRUCTOR use Test2::Event::V2; my $e = Test2::Event::V2->new( trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]}, info => [{tag => 'NOTE', details => "This is a note"}], ); =head1 METHODS This class inherits from L<Test2::Event>. =over 4 =item $fd = $e->facet_data() This will return a hashref of facet data. Each facet hash will be a shallow copy of the original. =item $about = $e->about() This will return the 'about' facet hashref. B<NOTE:> This will return the internal hashref, not a copy. =item $trace = $e->trace() This will return the 'trace' facet, normally blessed (but this is not enforced when the trace is set using C<set_trace()>. B<NOTE:> This will return the internal trace, not a copy. =back =head2 MUTATION =over 4 =item $e->add_amnesty({...}) Inherited from L<Test2::Event>. This can be used to add 'amnesty' facets to an existing event. Each new item is added to the B<END> of the list. B<NOTE:> Items B<ARE> blessed when added. =item $e->add_hub({...}) Inherited from L<Test2::Event>. This is used by hubs to stamp events as they pass through. New items are added to the B<START> of the list. B<NOTE:> Items B<ARE NOT> blessed when added. =item $e->set_uuid($UUID) Inherited from L<Test2::Event>, overridden to also vivify/mutate the 'about' facet. =item $e->set_trace($trace) Inherited from L<Test2::Event> which allows you to change the trace. B<Note:> This method does not bless/clone the trace for you. Many things will expect the trace to be blessed, so you should probably do that. =back =head2 LEGACY SUPPORT METHODS These are all imported from L<Test2::Util::Facets2Legacy>, see that module or L<Test2::Event> for documentation on what they do. =over 4 =item causes_fail =item diagnostics =item global =item increments_count =item no_display =item sets_plan =item subtest_id =item summary =item terminate =back =head1 THIRD PARTY META-DATA This object consumes L<Test2::Util::ExternalMeta> which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Fail.pm 0000444 00000003742 14711217510 0011071 0 ustar 00 package Test2::Event::Fail; use strict; use warnings; our $VERSION = '1.302186'; use Test2::EventFacet::Info; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event); *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; } use Test2::Util::HashBase qw{ -name -info }; ############# # Old API sub summary { "fail" } sub increments_count { 1 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub terminate { () } sub global { () } sub sets_plan { () } sub causes_fail { my $self = shift; return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; return 1; } ############# # New API sub add_info { my $self = shift; for my $in (@_) { $in = {%$in} if ref($in) ne 'ARRAY'; $in = Test2::EventFacet::Info->new($in); push @{$self->{+INFO}} => $in; } } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = 'fail'; $out->{assert} = {pass => 0, details => $self->{+NAME}}; $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Fail - Event for a simple failed assertion =head1 DESCRIPTION This is an optimal representation of a failed assertion. =head1 SYNOPSIS use Test2::API qw/context/; sub fail { my ($name) = @_; my $ctx = context(); $ctx->fail($name); $ctx->release; } =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Generic.pm 0000444 00000013425 14711217511 0011572 0 ustar 00 package Test2::Event::Generic; use strict; use warnings; use Carp qw/croak/; use Scalar::Util qw/reftype/; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; my @FIELDS = qw{ causes_fail increments_count diagnostics no_display callback terminate global sets_plan summary facet_data }; my %DEFAULTS = ( causes_fail => 0, increments_count => 0, diagnostics => 0, no_display => 0, ); sub init { my $self = shift; for my $field (@FIELDS) { my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field}; next unless defined $val; my $set = "set_$field"; $self->$set($val); } } for my $field (@FIELDS) { no strict 'refs'; *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () } unless exists &{$field}; *{"set_$field"} = sub { $_[0]->{$field} = $_[1] } unless exists &{"set_$field"}; } sub can { my $self = shift; my ($name) = @_; return $self->SUPER::can($name) unless $name eq 'callback'; return $self->{callback} || \&Test2::Event::callback; } sub facet_data { my $self = shift; return $self->{facet_data} || $self->SUPER::facet_data(); } sub summary { my $self = shift; return $self->{summary} if defined $self->{summary}; $self->SUPER::summary(); } sub sets_plan { my $self = shift; return unless $self->{sets_plan}; return @{$self->{sets_plan}}; } sub callback { my $self = shift; my $cb = $self->{callback} || return; $self->$cb(@_); } sub set_global { my $self = shift; my ($bool) = @_; if(!defined $bool) { delete $self->{global}; return undef; } $self->{global} = $bool; } sub set_callback { my $self = shift; my ($cb) = @_; if(!defined $cb) { delete $self->{callback}; return undef; } croak "callback must be a code reference" unless ref($cb) && reftype($cb) eq 'CODE'; $self->{callback} = $cb; } sub set_terminate { my $self = shift; my ($exit) = @_; if(!defined $exit) { delete $self->{terminate}; return undef; } croak "terminate must be a positive integer" unless $exit =~ m/^\d+$/; $self->{terminate} = $exit; } sub set_sets_plan { my $self = shift; my ($plan) = @_; if(!defined $plan) { delete $self->{sets_plan}; return undef; } croak "'sets_plan' must be an array reference" unless ref($plan) && reftype($plan) eq 'ARRAY'; $self->{sets_plan} = $plan; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Generic - Generic event type. =head1 DESCRIPTION This is a generic event that lets you customize all fields in the event API. This is useful if you have need for a custom event that does not make sense as a published reusable event subclass. =head1 SYNOPSIS use Test2::API qw/context/; sub send_custom_fail { my $ctx = shift; $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling'); $ctx->release; } send_custom_fail(); =head1 METHODS =over 4 =item $e->facet_data($data) =item $data = $e->facet_data Get or set the facet data (see L<Test2::Event>). If no facet_data is set then C<< Test2::Event->facet_data >> will be called to produce facets from the other data. =item $e->callback($hub) Call the custom callback if one is set, otherwise this does nothing. =item $e->set_callback(sub { ... }) Set the custom callback. The custom callback must be a coderef. The first argument to your callback will be the event itself, the second will be the L<Test2::Event::Hub> that is using the callback. =item $bool = $e->causes_fail =item $e->set_causes_fail($bool) Get/Set the C<causes_fail> attribute. This defaults to C<0>. =item $bool = $e->diagnostics =item $e->set_diagnostics($bool) Get/Set the C<diagnostics> attribute. This defaults to C<0>. =item $bool_or_undef = $e->global =item @bool_or_empty = $e->global =item $e->set_global($bool_or_undef) Get/Set the C<diagnostics> attribute. This defaults to an empty list which is undef in scalar context. =item $bool = $e->increments_count =item $e->set_increments_count($bool) Get/Set the C<increments_count> attribute. This defaults to C<0>. =item $bool = $e->no_display =item $e->set_no_display($bool) Get/Set the C<no_display> attribute. This defaults to C<0>. =item @plan = $e->sets_plan Get the plan if this event sets one. The plan is a list of up to 3 items: C<($count, $directive, $reason)>. C<$count> must be defined, the others may be undef, or may not exist at all. =item $e->set_sets_plan(\@plan) Set the plan. You must pass in an arrayref with up to 3 elements. =item $summary = $e->summary =item $e->set_summary($summary_or_undef) Get/Set the summary. This will default to the event package C<'Test2::Event::Generic'>. You can set it to any value. Setting this to C<undef> will reset it to the default. =item $int_or_undef = $e->terminate =item @int_or_empty = $e->terminate =item $e->set_terminate($int_or_undef) This will get/set the C<terminate> attribute. This defaults to undef in scalar context, or an empty list in list context. Setting this to undef will clear it completely. This must be set to a positive integer (0 or larger). =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Plan.pm 0000444 00000006474 14711217511 0011116 0 ustar 00 package Test2::Event::Plan; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw{max directive reason}; use Carp qw/confess/; my %ALLOWED = ( 'SKIP' => 1, 'NO PLAN' => 1, ); sub init { if ($_[0]->{+DIRECTIVE}) { $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all'; $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan'; confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive" unless $ALLOWED{$_[0]->{+DIRECTIVE}}; } else { confess "Cannot have a reason without a directive!" if defined $_[0]->{+REASON}; confess "No number of tests specified" unless defined $_[0]->{+MAX}; confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" unless $_[0]->{+MAX} =~ m/^\d+$/; $_[0]->{+DIRECTIVE} = ''; } } sub sets_plan { my $self = shift; return ( $self->{+MAX}, $self->{+DIRECTIVE}, $self->{+REASON}, ); } sub terminate { my $self = shift; # On skip_all we want to terminate the hub return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; return undef; } sub summary { my $self = shift; my $max = $self->{+MAX}; my $directive = $self->{+DIRECTIVE}; my $reason = $self->{+REASON}; return "Plan is $max assertions" if $max || !$directive; return "Plan is '$directive', $reason" if $reason; return "Plan is '$directive'"; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef unless defined $out->{control}->{terminate}; $out->{plan} = {count => $self->{+MAX}}; $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; if (my $dir = $self->{+DIRECTIVE}) { $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; } return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Plan - The event of a plan =head1 DESCRIPTION Plan events are fired off whenever a plan is declared, done testing is called, or a subtext completes. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Plan; my $ctx = context(); # Plan for 10 tests to run my $event = $ctx->plan(10); # Plan to skip all tests (will exit 0) $ctx->plan(0, skip_all => "These tests need to be skipped"); =head1 ACCESSORS =over 4 =item $num = $plan->max Get the number of expected tests =item $dir = $plan->directive Get the directive (such as TODO, skip_all, or no_plan). =item $reason = $plan->reason Get the reason for the directive. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/Diag.pm 0000444 00000002657 14711217511 0011067 0 ustar 00 package Test2::Event::Diag; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/message/; sub init { $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; } sub summary { $_[0]->{+MESSAGE} } sub diagnostics { 1 } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{info} = [ { tag => 'DIAG', debug => 1, details => $self->{+MESSAGE}, } ]; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::Diag - Diag event type =head1 DESCRIPTION Diagnostics messages, typically rendered to STDERR. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Diag; my $ctx = context(); my $event = $ctx->diag($message); =head1 ACCESSORS =over 4 =item $diag->message The message for the diag. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event/TAP/Version.pm 0000444 00000003154 14711217512 0012266 0 ustar 00 package Test2::Event::TAP::Version; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/croak/; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase qw/version/; sub init { my $self = shift; defined $self->{+VERSION} or croak "'version' is a required attribute"; } sub summary { 'TAP version ' . $_[0]->{+VERSION} } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = $self->summary; push @{$out->{info}} => { tag => 'INFO', debug => 0, details => $self->summary, }; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event::TAP::Version - Event for TAP version. =head1 DESCRIPTION This event is used if a TAP formatter wishes to set a version. =head1 SYNOPSIS use Test2::API qw/context/; use Test2::Event::Encoding; my $ctx = context(); my $event = $ctx->send_event('TAP::Version', version => 42); =head1 METHODS Inherits from L<Test2::Event>. Also defines: =over 4 =item $version = $e->version The TAP version being parsed. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/About.pm 0000444 00000002714 14711217513 0012234 0 ustar 00 package Test2::EventFacet::About; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -package -no_display -uuid -eid }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::About - Facet with event details. =head1 DESCRIPTION This facet has information about the event, such as event package. =head1 FIELDS =over 4 =item $string = $about->{details} =item $string = $about->details() Summary about the event. =item $package = $about->{package} =item $package = $about->package() Event package name. =item $bool = $about->{no_display} =item $bool = $about->no_display() True if the event should be skipped by formatters. =item $uuid = $about->{uuid} =item $uuid = $about->uuid() Will be set to a uuid if uuid tagging was enabled. =item $uuid = $about->{eid} =item $uuid = $about->eid() A unique (for the test job) identifier for the event. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Info.pm 0000444 00000006066 14711217513 0012061 0 ustar 00 package Test2::EventFacet::Info; use strict; use warnings; our $VERSION = '1.302186'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-tag -debug -important -table}; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Info - Facet for information a developer might care about. =head1 DESCRIPTION This facet represents messages intended for humans that will help them either understand a result, or diagnose a failure. =head1 NOTES This facet appears in a list instead of being a single item. =head1 FIELDS =over 4 =item $string_or_structure = $info->{details} =item $string_or_structure = $info->details() Human readable string or data structure, this is the information to display. Formatters are free to render the structures however they please. This may contain a blessed object. If the C<table> attribute (see below) is set then a renderer may choose to display the table instead of the details. =item $structure = $info->{table} =item $structure = $info->table() If the data the C<info> facet needs to convey can be represented as a table then the data may be placed in this attribute in a more raw form for better display. The data must also be represented in the C<details> attribute for renderers which do not support rendering tables directly. The table structure: my %table = { header => [ 'column 1 header', 'column 2 header', ... ], # Optional rows => [ ['row 1 column 1', 'row 1, column 2', ... ], ['row 2 column 1', 'row 2, column 2', ... ], ... ], # Allow the renderer to hide empty columns when true, Optional collapse => $BOOL, # List by name or number columns that should never be collapsed no_collapse => \@LIST, } =item $short_string = $info->{tag} =item $short_string = $info->tag() Short tag to categorize the info. This is usually 10 characters or less, formatters may truncate longer tags. =item $bool = $info->{debug} =item $bool = $info->debug() Set this to true if the message is critical, or explains a failure. This is info that should be displayed by formatters even in less-verbose modes. When false the information is not considered critical and may not be rendered in less-verbose modes. =item $bool = $info->{important} =item $bool = $info->important This should be set for non debug messages that are still important enough to show when a formatter is in quiet mode. A formatter should send these to STDOUT not STDERR, but should show them even in non-verbose mode. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Meta.pm 0000444 00000003506 14711217513 0012050 0 ustar 00 package Test2::EventFacet::Meta; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use vars qw/$AUTOLOAD/; # replace set_details { no warnings 'redefine'; sub set_details { $_[0]->{'set_details'} } } sub can { my $self = shift; my ($name) = @_; my $existing = $self->SUPER::can($name); return $existing if $existing; # Only vivify when called on an instance, do not vivify for a class. There # are a lot of magic class methods used in things like serialization (or # the forks.pm module) which cause problems when vivified. return undef unless ref($self); my $sub = sub { $_[0]->{$name} }; { no strict 'refs'; *$name = $sub; } return $sub; } sub AUTOLOAD { my $name = $AUTOLOAD; $name =~ s/^.*:://g; my $sub = $_[0]->can($name); goto &$sub; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Meta - Facet for meta-data =head1 DESCRIPTION This facet can contain any random meta-data that has been attached to the event. =head1 METHODS AND FIELDS Any/all fields and accessors are autovivified into existence. There is no way to know what metadata may be added, so any is allowed. =over 4 =item $anything = $meta->{anything} =item $anything = $meta->anything() =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Info/Table.pm 0000444 00000005447 14711217514 0013113 0 ustar 00 package Test2::EventFacet::Info::Table; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/confess/; use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string}; sub init { my $self = shift; confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}}; $self->{+AS_STRING} ||= '<TABLE NOT DISPLAYED>'; } sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out } sub info_args { my $self = shift; my $hash = $self->as_hash; my $desc = $self->as_string; return (table => $hash, details => $desc); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Info::Table - Intermediary representation of a table. =head1 DESCRIPTION Intermediary representation of a table for use in specialized L<Test::API::Context> methods which generate L<Test2::EventFacet::Info> facets. =head1 SYNOPSIS use Test2::EventFacet::Info::Table; use Test2::API qw/context/; sub my_tool { my $ctx = context(); ... $ctx->fail( $name, "failure diag message", Test2::EventFacet::Info::Table->new( # Required rows => [['a', 'b'], ['c', 'd'], ...], # Strongly Recommended as_string => "... string to print when table cannot be rendered ...", # Optional header => ['col1', 'col2'], collapse => $bool, no_collapse => ['col1', ...], ), ); ... $ctx->release; } my_tool(); =head1 ATTRIBUTES =over 4 =item $header_aref = $t->header() =item $rows_aref = $t->rows() =item $bool = $t->collapse() =item $aref = $t->no_collapse() The above are all directly tied to the table hashref structure described in L<Test2::EventFacet::Info>. =item $str = $t->as_string() This returns the string form of the table if it was set, otherwise it returns the string C<< "<TABLE NOT DISPLAYED>" >>. =item $href = $t->as_hash() This returns the data structure used for tables by L<Test2::EventFacet::Info>. =item %args = $t->info_args() This returns the arguments that should be used to construct the proper L<Test2::EventFacet::Info> structure. return (table => $t->as_hash(), details => $t->as_string()); =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Assert.pm 0000444 00000003260 14711217514 0012421 0 ustar 00 package Test2::EventFacet::Assert; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -pass -no_debug -number }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Assert - Facet representing an assertion. =head1 DESCRIPTION The assertion facet is provided by any event representing an assertion that was made. =head1 FIELDS =over 4 =item $string = $assert->{details} =item $string = $assert->details() Human readable description of the assertion. =item $bool = $assert->{pass} =item $bool = $assert->pass() True if the assertion passed. =item $bool = $assert->{no_debug} =item $bool = $assert->no_debug() Set this to true if you have provided custom diagnostics and do not want the defaults to be displayed. =item $int = $assert->{number} =item $int = $assert->number() (Optional) assertion number. This may be omitted or ignored. This is usually only useful when parsing/processing TAP. B<Note>: This is not set by the Test2 system, assertion number is not known until AFTER the assertion has been processed. This attribute is part of the spec only for harnesses. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Render.pm 0000444 00000003777 14711217514 0012414 0 ustar 00 package Test2::EventFacet::Render; use strict; use warnings; our $VERSION = '1.302186'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -facet -mode }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Render - Facet that dictates how to render an event. =head1 DESCRIPTION This facet is used to dictate how the event should be rendered by the standard test2 rendering tools. If this facet is present then ONLY what is specified by it will be rendered. It is assumed that anything important or note-worthy will be present here, no other facets will be considered for rendering/display. This facet is a list type, you can add as many items as needed. =head1 FIELDS =over 4 =item $string = $render->[#]->{details} =item $string = $render->[#]->details() Human readable text for display. =item $string = $render->[#]->{tag} =item $string = $render->[#]->tag() Tag that should prefix/identify the main text. =item $string = $render->[#]->{facet} =item $string = $render->[#]->facet() Optional, if the display text was generated from another facet this should state what facet it was. =item $mode = $render->[#]->{mode} =item $mode = $render->[#]->mode() =over 4 =item calculated Calculated means the facet was generated from another facet. Calculated facets may be cleared and regenerated whenever the event state changes. =item replace Replace means the facet is intended to replace the normal rendering of the event. =back =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Amnesty.pm 0000444 00000003153 14711217514 0012601 0 ustar 00 package Test2::EventFacet::Amnesty; use strict; use warnings; our $VERSION = '1.302186'; sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -inherited }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Amnesty - Facet for assertion amnesty. =head1 DESCRIPTION This package represents what is expected in units of amnesty. =head1 NOTES This facet appears in a list instead of being a single item. =head1 FIELDS =over 4 =item $string = $amnesty->{details} =item $string = $amnesty->details() Human readable explanation of why amnesty was granted. Example: I<Not implemented yet, will fix> =item $short_string = $amnesty->{tag} =item $short_string = $amnesty->tag() Short string (usually 10 characters or less, not enforced, but may be truncated by renderers) categorizing the amnesty. =item $bool = $amnesty->{inherited} =item $bool = $amnesty->inherited() This will be true if the amnesty was granted to a parent event and inherited by this event, which is a child, such as an assertion within a subtest that is marked todo. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Error.pm 0000444 00000003413 14711217514 0012251 0 ustar 00 package Test2::EventFacet::Error; use strict; use warnings; our $VERSION = '1.302186'; sub facet_key { 'errors' } sub is_list { 1 } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -tag -fail }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Error - Facet for errors that need to be shown. =head1 DESCRIPTION This facet is used when an event needs to convey errors. =head1 NOTES This facet has the hash key C<'errors'>, and is a list of facets instead of a single item. =head1 FIELDS =over 4 =item $string = $error->{details} =item $string = $error->details() Explanation of the error, or the error itself (such as an exception). In perl exceptions may be blessed objects, so this field may contain a blessed object. =item $short_string = $error->{tag} =item $short_string = $error->tag() Short tag to categorize the error. This is usually 10 characters or less, formatters may truncate longer tags. =item $bool = $error->{fail} =item $bool = $error->fail() Not all errors are fatal, some are displayed having already been handled. Set this to true if you want the error to cause the test to fail. Without this the error is simply a diagnostics message that has no effect on the overall pass/fail result. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Control.pm 0000444 00000003730 14711217514 0012602 0 ustar 00 package Test2::EventFacet::Control; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Control - Facet for hub actions and behaviors. =head1 DESCRIPTION This facet is used when the event needs to give instructions to the Test2 internals. =head1 FIELDS =over 4 =item $string = $control->{details} =item $string = $control->details() Human readable explanation for the special behavior. =item $bool = $control->{global} =item $bool = $control->global() True if the event is global in nature and should be seen by all hubs. =item $exit = $control->{terminate} =item $exit = $control->terminate() Defined if the test should immediately exit, the value is the exit code and may be C<0>. =item $bool = $control->{halt} =item $bool = $control->halt() True if all testing should be halted immediately. =item $bool = $control->{has_callback} =item $bool = $control->has_callback() True if the C<callback($hub)> method on the event should be called. =item $encoding = $control->{encoding} =item $encoding = $control->encoding() This can be used to change the encoding from this event onward. =item $phase = $control->{phase} =item $phase = $control->phase() Used to signal that a phase change has occurred. Currently only the perl END phase is signaled. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Trace.pm 0000444 00000015265 14711217514 0012226 0 ustar 00 package Test2::EventFacet::Trace; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util qw/get_tid pkg_to_file gen_uid/; use Carp qw/confess/; use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid <full_caller}; { no warnings 'once'; *DETAIL = \&DETAILS; *detail = \&details; *set_detail = \&set_details; } sub init { confess "The 'frame' attribute is required" unless $_[0]->{+FRAME}; $_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail}; unless (defined($_[0]->{+PID}) || defined($_[0]->{+TID}) || defined($_[0]->{+CID})) { $_[0]->{+PID} = $$ unless defined $_[0]->{+PID}; $_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID}; } } sub snapshot { my ($orig, @override) = @_; bless {%$orig, @override}, __PACKAGE__; } sub signature { my $self = shift; # Signature is only valid if all of these fields are defined, there is no # signature if any is missing. '0' is ok, but '' is not. return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } ( $self->{+CID}, $self->{+PID}, $self->{+TID}, $self->{+FRAME}->[1], $self->{+FRAME}->[2], ); } sub debug { my $self = shift; return $self->{+DETAILS} if $self->{+DETAILS}; my ($pkg, $file, $line) = $self->call; return "at $file line $line"; } sub alert { my $self = shift; my ($msg) = @_; warn $msg . ' ' . $self->debug . ".\n"; } sub throw { my $self = shift; my ($msg) = @_; die $msg . ' ' . $self->debug . ".\n"; } sub call { @{$_[0]->{+FRAME}} } sub full_call { @{$_[0]->{+FULL_CALLER}} } sub package { $_[0]->{+FRAME}->[0] } sub file { $_[0]->{+FRAME}->[1] } sub line { $_[0]->{+FRAME}->[2] } sub subname { $_[0]->{+FRAME}->[3] } sub warning_bits { $_[0]->{+FULL_CALLER} ? $_[0]->{+FULL_CALLER}->[9] : undef } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Trace - Debug information for events =head1 DESCRIPTION The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to have access to information about where they were created. This object represents that information. =head1 SYNOPSIS use Test2::EventFacet::Trace; my $trace = Test2::EventFacet::Trace->new( frame => [$package, $file, $line, $subname], ); =head1 FACET FIELDS =over 4 =item $string = $trace->{details} =item $string = $trace->details() Used as a custom trace message that will be used INSTEAD of C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>. =item $frame = $trace->{frame} =item $frame = $trace->frame() Get the call frame arrayref. [$package, $file, $line, $subname] =item $int = $trace->{pid} =item $int = $trace->pid() The process ID in which the event was generated. =item $int = $trace->{tid} =item $int = $trace->tid() The thread ID in which the event was generated. =item $id = $trace->{cid} =item $id = $trace->cid() The ID of the context that was used to create the event. =item $uuid = $trace->{uuid} =item $uuid = $trace->uuid() The UUID of the context that was used to create the event. (If uuid tagging was enabled) =item ($pkg, $file, $line, $subname) = $trace->call Get the basic call info as a list. =item @caller = $trace->full_call Get the full caller(N) results. =item $warning_bits = $trace->warning_bits Get index 9 from the full caller info. This is the warnings_bits field. The value of this is not portable across perl versions or even processes. However it can be used in the process that generated it to reproduce the warnings settings in a new scope. eval <<EOT; BEGIN { ${^WARNING_BITS} = $trace->warning_bits }; ... context's warning settings apply here ... EOT =back =head2 DISCOURAGED HUB RELATED FIELDS These fields were not always set properly by tools. These are B<MOSTLY> deprecated by the L<Test2::EventFacet::Hub> facets. These fields are not required, and may only reflect the hub that was current when the event was created, which is not necessarily the same as the hub the event was sent through. Some tools did do a good job setting these to the correct hub, but you cannot always rely on that. Use the 'hubs' facet list instead. =over 4 =item $hid = $trace->{hid} =item $hid = $trace->hid() The ID of the hub that was current when the event was created. =item $huuid = $trace->{huuid} =item $huuid = $trace->huuid() The UUID of the hub that was current when the event was created. (If uuid tagging was enabled). =item $int = $trace->{nested} =item $int = $trace->nested() How deeply nested the event is. =item $bool = $trace->{buffered} =item $bool = $trace->buffered() True if the event was buffered and not sent to the formatter independent of a parent (This should never be set when nested is C<0> or C<undef>). =back =head1 METHODS B<Note:> All facet frames are also methods. =over 4 =item $trace->set_detail($msg) =item $msg = $trace->detail Used to get/set a custom trace message that will be used INSTEAD of C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>. C<detail()> is an alias to the C<details> facet field for backwards compatibility. =item $str = $trace->debug Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set then its value will be returned instead. =item $trace->alert($MESSAGE) This issues a warning at the frame (filename and line number where errors should be reported). =item $trace->throw($MESSAGE) This throws an exception at the frame (filename and line number where errors should be reported). =item ($package, $file, $line, $subname) = $trace->call() Get the caller details for the debug-info. This is where errors should be reported. =item $pkg = $trace->package Get the debug-info package. =item $file = $trace->file Get the debug-info filename. =item $line = $trace->line Get the debug-info line number. =item $subname = $trace->subname Get the debug-info subroutine name. =item $sig = trace->signature Get a signature string that identifies this trace. This is used to check if multiple events are related. The signature includes pid, tid, file, line number, and the cid. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Plan.pm 0000444 00000003536 14711217514 0012060 0 ustar 00 package Test2::EventFacet::Plan; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -count -skip -none }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Plan - Facet for setting the plan =head1 DESCRIPTION Events use this facet when they need to set the plan. =head1 FIELDS =over 4 =item $string = $plan->{details} =item $string = $plan->details() Human readable explanation for the plan being set. This is normally not rendered by most formatters except when the C<skip> field is also set. =item $positive_int = $plan->{count} =item $positive_int = $plan->count() Set the number of expected assertions. This should usually be set to C<0> when C<skip> or C<none> are also set. =item $bool = $plan->{skip} =item $bool = $plan->skip() When true the entire test should be skipped. This is usually paired with an explanation in the C<details> field, and a C<control> facet that has C<terminate> set to C<0>. =item $bool = $plan->{none} =item $bool = $plan->none() This is mainly used by legacy L<Test::Builder> tests which set the plan to C<no plan>, a construct that predates the much better C<done_testing()>. If you are using this in non-legacy code you may need to reconsider the course of your life, maybe a hermitage would suite you? =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Hub.pm 0000444 00000003525 14711217514 0011702 0 ustar 00 package Test2::EventFacet::Hub; use strict; use warnings; our $VERSION = '1.302186'; sub is_list { 1 } sub facet_key { 'hubs' } BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc}; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Hub - Facet for the hubs an event passes through. =head1 DESCRIPTION These are a record of the hubs an event passes through. Most recent hub is the first one in the list. =head1 FACET FIELDS =over 4 =item $string = $trace->{details} =item $string = $trace->details() The hub class or subclass =item $int = $trace->{pid} =item $int = $trace->pid() PID of the hub this event was sent to. =item $int = $trace->{tid} =item $int = $trace->tid() The thread ID of the hub the event was sent to. =item $hid = $trace->{hid} =item $hid = $trace->hid() The ID of the hub that the event was send to. =item $huuid = $trace->{huuid} =item $huuid = $trace->huuid() The UUID of the hub that the event was sent to. =item $int = $trace->{nested} =item $int = $trace->nested() How deeply nested the hub was. =item $bool = $trace->{buffered} =item $bool = $trace->buffered() True if the event was buffered and not sent to the formatter independent of a parent (This should never be set when nested is C<0> or C<undef>). =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet/Parent.pm 0000444 00000003355 14711217514 0012416 0 ustar 00 package Test2::EventFacet::Parent; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/confess/; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{-hid -children -buffered -start_stamp -stop_stamp}; sub init { confess "Attribute 'hid' must be set" unless defined $_[0]->{+HID}; $_[0]->{+CHILDREN} ||= []; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet::Parent - Facet for events contains other events =head1 DESCRIPTION This facet is used when an event contains other events, such as a subtest. =head1 FIELDS =over 4 =item $string = $parent->{details} =item $string = $parent->details() Human readable description of the event. =item $hid = $parent->{hid} =item $hid = $parent->hid() Hub ID of the hub that is represented in the parent-child relationship. =item $arrayref = $parent->{children} =item $arrayref = $parent->children() Arrayref containing the facet-data hashes of events nested under this one. I<To get the actual events you need to get them from the parent event directly> =item $bool = $parent->{buffered} =item $bool = $parent->buffered() True if the subtest is buffered (meaning the formatter has probably not seen them yet). =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/Context.pm 0000444 00000065601 14711217514 0011200 0 ustar 00 package Test2::API::Context; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/confess croak/; use Scalar::Util qw/weaken blessed/; use Test2::Util qw/get_tid try pkg_to_file get_tid/; use Test2::EventFacet::Trace(); use Test2::API(); # Preload some key event types my %LOADED = ( map { my $pkg = "Test2::Event::$_"; my $file = "Test2/Event/$_.pm"; require $file unless $INC{$file}; ( $pkg => $pkg, $_ => $pkg ) } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/ ); use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ stack hub trace _on_release _depth _is_canon _is_spawn _aborted errno eval_error child_error thrown }; # Private, not package vars # It is safe to cache these. my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); my $CONTEXTS = Test2::API::_contexts_ref(); sub init { my $self = shift; confess "The 'trace' attribute is required" unless $self->{+TRACE}; confess "The 'hub' attribute is required" unless $self->{+HUB}; $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; $self->{+ERRNO} = $! unless exists $self->{+ERRNO}; $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; } sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } sub restore_error_vars { my $self = shift; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; } sub DESTROY { return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; my ($self) = @_; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; # Do not show the warning if it looks like an exception has been thrown, or # if the context is not local to this process or thread. { # Sometimes $@ is uninitialized, not a problem in this case so do not # show the warning about using eq. no warnings 'uninitialized'; if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { require Carp; my $mess = Carp::longmess("Context destroyed"); my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; warn <<" EOT"; A context appears to have been destroyed without first calling release(). Based on \$@ it does not look like an exception was thrown (this is not always a reliable test) This is a problem because the global error variables (\$!, \$@, and \$?) will not be restored. In addition some release callbacks will not work properly from inside a DESTROY method. Here are the context creation details, just in case a tool forgot to call release(): File: $frame->[1] Line: $frame->[2] Tool: $frame->[3] Here is a trace to the code that caused the context to be destroyed, this could be an exit(), a goto, or simply the end of a scope: $mess Cleaning up the CONTEXT stack... EOT } } return if $self->{+_IS_SPAWN}; # Remove the key itself to avoid a slow memory leak delete $CONTEXTS->{$hid}; $self->{+_IS_CANON} = undef; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; } # release exists to implement behaviors like die-on-fail. In die-on-fail you # want to die after a failure, but only after diagnostics have been reported. # The ideal time for the die to happen is when the context is released. # Unfortunately die does not work in a DESTROY block. sub release { my ($self) = @_; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef if $self->{+_IS_SPAWN}; croak "release() should not be called on context that is neither canon nor a child" unless $self->{+_IS_CANON}; my $hub = $self->{+HUB}; my $hid = $hub->{hid}; croak "context thinks it is canon, but it is not" unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; # Remove the key itself to avoid a slow memory leak $self->{+_IS_CANON} = undef; delete $CONTEXTS->{$hid}; if (my $cbk = $self->{+_ON_RELEASE}) { $_->($self) for reverse @$cbk; } if (my $hcbk = $hub->{_context_release}) { $_->($self) for reverse @$hcbk; } $_->($self) for reverse @$ON_RELEASE; # Do this last so that nothing else changes them. # If one of the hooks dies then these do not get restored, this is # intentional ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; return; } sub do_in_context { my $self = shift; my ($sub, @args) = @_; # We need to update the pid/tid and error vars. my $clone = $self->snapshot; @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid()); my $hub = $clone->{+HUB}; my $hid = $hub->hid; my $old = $CONTEXTS->{$hid}; $clone->{+_IS_CANON} = 1; $CONTEXTS->{$hid} = $clone; weaken($CONTEXTS->{$hid}); my ($ok, $err) = &try($sub, @args); my ($rok, $rerr) = try { $clone->release }; delete $clone->{+_IS_CANON}; if ($old) { $CONTEXTS->{$hid} = $old; weaken($CONTEXTS->{$hid}); } else { delete $CONTEXTS->{$hid}; } die $err unless $ok; die $rerr unless $rok; } sub done_testing { my $self = shift; $self->hub->finalize($self->trace, 1); return; } sub throw { my ($self, $msg) = @_; $self->{+THROWN} = 1; ${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; $self->trace->throw($msg); } sub alert { my ($self, $msg) = @_; $self->trace->alert($msg); } sub send_ev2_and_release { my $self = shift; my $out = $self->send_ev2(@_); $self->release; return $out; } sub send_ev2 { my $self = shift; my $e; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $e = Test2::Event::V2->new( trace => $self->{+TRACE}->snapshot, @_, ); } if ($self->{+_ABORTED}) { my $f = $e->facet_data; ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); } $self->{+HUB}->send($e); } sub build_ev2 { my $self = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; Test2::Event::V2->new( trace => $self->{+TRACE}->snapshot, @_, ); } sub send_event_and_release { my $self = shift; my $out = $self->send_event(@_); $self->release; return $out; } sub send_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); my $e; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $e = $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } if ($self->{+_ABORTED}) { my $f = $e->facet_data; ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); } $self->{+HUB}->send($e); } sub build_event { my $self = shift; my $event = shift; my %args = @_; my $pkg = $LOADED{$event} || $self->_parse_event($event); local $Carp::CarpLevel = $Carp::CarpLevel + 1; $pkg->new( trace => $self->{+TRACE}->snapshot, %args, ); } sub pass { my $self = shift; my ($name) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Pass" ); $self->{+HUB}->send($e); return $e; } sub pass_and_release { my $self = shift; my ($name) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Pass" ); $self->{+HUB}->send($e); $self->release; return 1; } sub fail { my $self = shift; my ($name, @diag) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Fail" ); for my $msg (@diag) { if (ref($msg) eq 'Test2::EventFacet::Info::Table') { $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); } else { $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); } } $self->{+HUB}->send($e); return $e; } sub fail_and_release { my $self = shift; my ($name, @diag) = @_; my $e = bless( { trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), name => $name, }, "Test2::Event::Fail" ); for my $msg (@diag) { if (ref($msg) eq 'Test2::EventFacet::Info::Table') { $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); } else { $e->add_info({tag => 'DIAG', debug => 1, details => $msg}); } } $self->{+HUB}->send($e); $self->release; return 0; } sub ok { my $self = shift; my ($pass, $name, $on_fail) = @_; my $hub = $self->{+HUB}; my $e = bless { trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), pass => $pass, name => $name, }, 'Test2::Event::Ok'; $e->init; $hub->send($e); return $e if $pass; $self->failure_diag($e); if ($on_fail && @$on_fail) { $self->diag($_) for @$on_fail; } return $e; } sub failure_diag { my $self = shift; my ($e) = @_; # Figure out the debug info, this is typically the file name and line # number, but can also be a custom message. If no trace object is provided # then we have nothing useful to display. my $name = $e->name; my $trace = $e->trace; my $debug = $trace ? $trace->debug : "[No trace info available]"; # Create the initial diagnostics. If the test has a name we put the debug # info on a second line, this behavior is inherited from Test::Builder. my $msg = defined($name) ? qq[Failed test '$name'\n$debug.\n] : qq[Failed test $debug.\n]; $self->diag($msg); } sub skip { my $self = shift; my ($name, $reason, @extra) = @_; $self->send_event( 'Skip', name => $name, reason => $reason, pass => 1, @extra, ); } sub note { my $self = shift; my ($message) = @_; $self->send_event('Note', message => $message); } sub diag { my $self = shift; my ($message) = @_; my $hub = $self->{+HUB}; $self->send_event( 'Diag', message => $message, ); } sub plan { my ($self, $max, $directive, $reason) = @_; $self->send_event('Plan', max => $max, directive => $directive, reason => $reason); } sub bail { my ($self, $reason) = @_; $self->send_event('Bail', reason => $reason); } sub _parse_event { my $self = shift; my $event = shift; my $pkg; if ($event =~ m/^\+(.*)/) { $pkg = $1; } else { $pkg = "Test2::Event::$event"; } unless ($LOADED{$pkg}) { my $file = pkg_to_file($pkg); my ($ok, $err) = try { require $file }; $self->throw("Could not load event module '$pkg': $err") unless $ok; $LOADED{$pkg} = $pkg; } confess "'$pkg' is not a subclass of 'Test2::Event'" unless $pkg->isa('Test2::Event'); $LOADED{$event} = $pkg; return $pkg; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Context - Object to represent a testing context. =head1 DESCRIPTION The context object is the primary interface for authors of testing tools written with L<Test2>. The context object represents the context in which a test takes place (File and Line Number), and provides a quick way to generate events from that context. The context object also takes care of sending events to the correct L<Test2::Hub> instance. =head1 SYNOPSIS In general you will not be creating contexts directly. To obtain a context you should always use C<context()> which is exported by the L<Test2::API> module. use Test2::API qw/context/; sub my_ok { my ($bool, $name) = @_; my $ctx = context(); if ($bool) { $ctx->pass($name); } else { $ctx->fail($name); } $ctx->release; # You MUST do this! return $bool; } Context objects make it easy to wrap other tools that also use context. Once you grab a context, any tool you call before releasing your context will inherit it: sub wrapper { my ($bool, $name) = @_; my $ctx = context(); $ctx->diag("wrapping my_ok"); my $out = my_ok($bool, $name); $ctx->release; # You MUST do this! return $out; } =head1 CRITICAL DETAILS =over 4 =item you MUST always use the context() sub from Test2::API Creating your own context via C<< Test2::API::Context->new() >> will almost never produce a desirable result. Use C<context()> which is exported by L<Test2::API>. There are a handful of cases where a tool author may want to create a new context by hand, which is why the C<new> method exists. Unless you really know what you are doing you should avoid this. =item You MUST always release the context when done with it Releasing the context tells the system you are done with it. This gives it a chance to run any necessary callbacks or cleanup tasks. If you forget to release the context it will try to detect the problem and warn you about it. =item You MUST NOT pass context objects around When you obtain a context object it is made specifically for your tool and any tools nested within. If you pass a context around you run the risk of polluting other tools with incorrect context information. If you are certain that you want a different tool to use the same context you may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. =item You MUST NOT store or cache a context for later As long as a context exists for a given hub, all tools that try to get a context will get the existing instance. If you try to store the context you will pollute other tools with incorrect context information. If you are certain that you want to save the context for later, you can use a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context that is safe to pass around or store. C<context()> has some mechanisms to protect you if you do cause a context to persist beyond the scope in which it was obtained. In practice you should not rely on these protections, and they are fairly noisy with warnings. =item You SHOULD obtain your context as soon as possible in a given tool You never know what tools you call from within your own tool will need a context. Obtaining the context early ensures that nested tools can find the context you want them to find. =back =head1 METHODS =over 4 =item $ctx->done_testing; Note that testing is finished. If no plan has been set this will generate a Plan event. =item $clone = $ctx->snapshot() This will return a shallow clone of the context. The shallow clone is safe to store for later. =item $ctx->release() This will release the context. This runs cleanup tasks, and several important hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the context was created. B<Note:> If a context is acquired more than once an internal refcount is kept. C<release()> decrements the ref count, none of the other actions of C<release()> will occur unless the refcount hits 0. This means only the last call to C<release()> will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks. =item $ctx->throw($message) This will throw an exception reporting to the file and line number of the context. This will also release the context for you. =item $ctx->alert($message) This will issue a warning from the file and line number of the context. =item $stack = $ctx->stack() This will return the L<Test2::API::Stack> instance the context used to find the current hub. =item $hub = $ctx->hub() This will return the L<Test2::Hub> instance the context recognizes as the current one to which all events should be sent. =item $dbg = $ctx->trace() This will return the L<Test2::EventFacet::Trace> instance used by the context. =item $ctx->do_in_context(\&code, @args); Sometimes you have a context that is not current, and you want things to use it as the current one. In these cases you can call C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and anything inside of it that looks for a context will find the one on which the method was called. This B<DOES NOT> affect context on other hubs, only the hub used by the context will be affected. my $ctx = ...; $ctx->do_in_context(sub { my $ctx = context(); # returns the $ctx the sub is called on }); B<Note:> The context will actually be cloned, the clone will be used instead of the original. This allows the thread id, process id, and error variables to be correct without modifying the original context. =item $ctx->restore_error_vars() This will set C<$!>, C<$?>, and C<$@> to what they were when the context was created. There is no localization or anything done here, calling this method will actually set these vars. =item $! = $ctx->errno() The (numeric) value of C<$!> when the context was created. =item $? = $ctx->child_error() The value of C<$?> when the context was created. =item $@ = $ctx->eval_error() The value of C<$@> when the context was created. =back =head2 EVENT PRODUCTION METHODS B<Which one do I use?> The C<pass*> and C<fail*> are optimal if they meet your situation, using one of them will always be the most optimal. That said they are optimal by eliminating many features. Method such as C<ok>, and C<note> are shortcuts for generating common 1-task events based on the old API, however they are forward compatible, and easy to use. If these meet your needs then go ahead and use them, but please check back often for alternatives that may be added. If you want to generate new style events, events that do many things at once, then you want the C<*ev2*> methods. These let you directly specify which facets you wish to use. =over 4 =item $event = $ctx->pass() =item $event = $ctx->pass($name) This will send and return an L<Test2::Event::Pass> event. You may optionally provide a C<$name> for the assertion. The L<Test2::Event::Pass> is a specially crafted and optimized event, using this will help the performance of passing tests. =item $true = $ctx->pass_and_release() =item $true = $ctx->pass_and_release($name) This is a combination of C<pass()> and C<release()>. You can use this if you do not plan to do anything with the context after sending the event. This helps write more clear and compact code. sub shorthand { my ($bool, $name) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; ... Handle a failure ... } sub longform { my ($bool, $name) = @_; my $ctx = context(); if ($bool) { $ctx->pass($name); $ctx->release; return 1; } ... Handle a failure ... } =item my $event = $ctx->fail() =item my $event = $ctx->fail($name) =item my $event = $ctx->fail($name, @diagnostics) This lets you send an L<Test2::Event::Fail> event. You may optionally provide a C<$name> and C<@diagnostics> messages. Diagnostics messages can be simple strings, data structures, or instances of L<Test2::EventFacet::Info::Table> (which are converted inline into the L<Test2::EventFacet::Info> structure). =item my $false = $ctx->fail_and_release() =item my $false = $ctx->fail_and_release($name) =item my $false = $ctx->fail_and_release($name, @diagnostics) This is a combination of C<fail()> and C<release()>. This can be used to write clearer and shorter code. sub shorthand { my ($bool, $name) = @_; my $ctx = context(); return $ctx->fail_and_release($name) unless $bool; ... Handle a success ... } sub longform { my ($bool, $name) = @_; my $ctx = context(); unless ($bool) { $ctx->pass($name); $ctx->release; return 1; } ... Handle a success ... } =item $event = $ctx->ok($bool, $name) =item $event = $ctx->ok($bool, $name, \@on_fail) B<NOTE:> Use of this method is discouraged in favor of C<pass()> and C<fail()> which produce L<Test2::Event::Pass> and L<Test2::Event::Fail> events. These newer event types are faster and less crufty. This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false then an L<Test2::Event::Diag> event will be sent as well with details about the failure. If you do not want automatic diagnostics you should use the C<send_event()> method directly. The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in the event of a test failure. Unlike with C<fail()> these diagnostics must be plain strings, data structures are not supported. =item $event = $ctx->note($message) Send an L<Test2::Event::Note>. This event prints a message to STDOUT. =item $event = $ctx->diag($message) Send an L<Test2::Event::Diag>. This event prints a message to STDERR. =item $event = $ctx->plan($max) =item $event = $ctx->plan(0, 'SKIP', $reason) This can be used to send an L<Test2::Event::Plan> event. This event usually takes either a number of tests you expect to run. Optionally you can set the expected count to 0 and give the 'SKIP' directive with a reason to cause all tests to be skipped. =item $event = $ctx->skip($name, $reason); Send an L<Test2::Event::Skip> event. =item $event = $ctx->bail($reason) This sends an L<Test2::Event::Bail> event. This event will completely terminate all testing. =item $event = $ctx->send_ev2(%facets) This lets you build and send a V2 event directly from facets. The event is returned after it is sent. This example sends a single assertion, a note (comment for stdout in Test::Builder talk) and sets the plan to 1. my $event = $ctx->send_event( plan => {count => 1}, assert => {pass => 1, details => "A passing assert"}, info => [{tag => 'NOTE', details => "This is a note"}], ); =item $event = $ctx->build_e2(%facets) This is the same as C<send_ev2()>, except it builds and returns the event without sending it. =item $event = $ctx->send_ev2_and_release($Type, %parameters) This is a combination of C<send_ev2()> and C<release()>. sub shorthand { my $ctx = context(); return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'}); } sub longform { my $ctx = context(); my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'}); $ctx->release; return $event; } =item $event = $ctx->send_event($Type, %parameters) B<It is better to use send_ev2() in new code.> This lets you build and send an event of any type. The C<$Type> argument should be the event package name with C<Test2::Event::> left off, or a fully qualified package name prefixed with a '+'. The event is returned after it is sent. my $event = $ctx->send_event('Ok', ...); or my $event = $ctx->send_event('+Test2::Event::Ok', ...); =item $event = $ctx->build_event($Type, %parameters) B<It is better to use build_ev2() in new code.> This is the same as C<send_event()>, except it builds and returns the event without sending it. =item $event = $ctx->send_event_and_release($Type, %parameters) B<It is better to use send_ev2_and_release() in new code.> This is a combination of C<send_event()> and C<release()>. sub shorthand { my $ctx = context(); return $ctx->send_event_and_release(Pass => { name => 'foo' }); } sub longform { my $ctx = context(); my $event = $ctx->send_event(Pass => { name => 'foo' }); $ctx->release; return $event; } =back =head1 HOOKS There are 2 types of hooks, init hooks, and release hooks. As the names suggest, these hooks are triggered when contexts are created or released. =head2 INIT HOOKS These are called whenever a context is initialized. That means when a new instance is created. These hooks are B<NOT> called every time something requests a context, just when a new one is created. =head3 GLOBAL This is how you add a global init callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_init(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add an init callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_init(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you specify an init hook that will only run if your call to C<context()> generates a new context. The callback will be ignored if C<context()> is returning an existing context. my $ctx = context(on_init => sub { my $ctx = shift; ... }); =head2 RELEASE HOOKS These are called whenever a context is released. That means when the last reference to the instance is about to be destroyed. These hooks are B<NOT> called every time C<< $ctx->release >> is called. =head3 GLOBAL This is how you add a global release callback. Global callbacks happen for every context for any hub or stack. Test2::API::test2_add_callback_context_release(sub { my $ctx = shift; ... }); =head3 PER HUB This is how you add a release callback for all contexts created for a given hub. These callbacks will not run for other hubs. $hub->add_context_release(sub { my $ctx = shift; ... }); =head3 PER CONTEXT This is how you add release callbacks directly to a context. The callback will B<ALWAYS> be added to the context that gets returned, it does not matter if a new one is generated, or if an existing one is returned. my $ctx = context(on_release => sub { my $ctx = shift; ... }); =head1 THIRD PARTY META-DATA This object consumes L<Test2::Util::ExternalMeta> which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =item Kent Fredric E<lt>kentnl@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/Instance.pm 0000444 00000051771 14711217515 0011324 0 ustar 00 package Test2::API::Instance; use strict; use warnings; our $VERSION = '1.302186'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; use Scalar::Util qw/reftype/; use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/; use Test2::EventFacet::Trace(); use Test2::API::Stack(); use Test2::Util::HashBase qw{ _pid _tid no_wait finalized loaded ipc stack formatter contexts add_uuid_via -preload ipc_disabled ipc_polling ipc_drivers ipc_timeout formatters exit_callbacks post_load_callbacks context_acquire_callbacks context_init_callbacks context_release_callbacks pre_subtest_callbacks }; sub DEFAULT_IPC_TIMEOUT() { 30 } sub pid { $_[0]->{+_PID} } sub tid { $_[0]->{+_TID} } # Wrap around the getters that should call _finalize. BEGIN { for my $finalizer (IPC, FORMATTER) { my $orig = __PACKAGE__->can($finalizer); my $new = sub { my $self = shift; $self->_finalize unless $self->{+FINALIZED}; $self->$orig; }; no strict 'refs'; no warnings 'redefine'; *{$finalizer} = $new; } } sub has_ipc { !!$_[0]->{+IPC} } sub import { my $class = shift; return unless @_; my ($ref) = @_; $$ref = $class->new; } sub init { $_[0]->reset } sub start_preload { my $self = shift; confess "preload cannot be started, Test2::API has already been initialized" if $self->{+FINALIZED} || $self->{+LOADED}; return $self->{+PRELOAD} = 1; } sub stop_preload { my $self = shift; return 0 unless $self->{+PRELOAD}; $self->{+PRELOAD} = 0; $self->post_preload_reset(); return 1; } sub post_preload_reset { my $self = shift; delete $self->{+_PID}; delete $self->{+_TID}; $self->{+ADD_UUID_VIA} = undef unless exists $self->{+ADD_UUID_VIA}; $self->{+CONTEXTS} = {}; $self->{+FORMATTERS} = []; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; $self->{+LOADED} = 0; $self->{+STACK} ||= Test2::API::Stack->new; } sub reset { my $self = shift; delete $self->{+_PID}; delete $self->{+_TID}; $self->{+ADD_UUID_VIA} = undef; $self->{+CONTEXTS} = {}; $self->{+IPC_DRIVERS} = []; $self->{+IPC_POLLING} = undef; $self->{+FORMATTERS} = []; $self->{+FORMATTER} = undef; $self->{+FINALIZED} = undef; $self->{+IPC} = undef; $self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0; $self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT}; $self->{+NO_WAIT} = 0; $self->{+LOADED} = 0; $self->{+EXIT_CALLBACKS} = []; $self->{+POST_LOAD_CALLBACKS} = []; $self->{+CONTEXT_ACQUIRE_CALLBACKS} = []; $self->{+CONTEXT_INIT_CALLBACKS} = []; $self->{+CONTEXT_RELEASE_CALLBACKS} = []; $self->{+PRE_SUBTEST_CALLBACKS} = []; $self->{+STACK} = Test2::API::Stack->new; } sub _finalize { my $self = shift; my ($caller) = @_; $caller ||= [caller(1)]; confess "Attempt to initialize Test2::API during preload" if $self->{+PRELOAD}; $self->{+FINALIZED} = $caller; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; unless ($self->{+FORMATTER}) { my ($formatter, $source); if ($ENV{T2_FORMATTER}) { $source = "set by the 'T2_FORMATTER' environment variable"; if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) { $formatter = $1 ? $2 : "Test2::Formatter::$2" } else { $formatter = ''; } } elsif (@{$self->{+FORMATTERS}}) { ($formatter) = @{$self->{+FORMATTERS}}; $source = "Most recently added"; } else { $formatter = 'Test2::Formatter::TAP'; $source = 'default formatter'; } unless (ref($formatter) || $formatter->can('write')) { my $file = pkg_to_file($formatter); my ($ok, $err) = try { require $file }; unless ($ok) { my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *"; my $border = '*' x length($line); die "\n\n $border\n $line\n $border\n\n$err"; } } $self->{+FORMATTER} = $formatter; } # Turn on IPC if threads are on, drivers are registered, or the Test2::IPC # module is loaded. return if $self->{+IPC_DISABLED}; return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}}; # Turn on polling by default, people expect it. $self->enable_ipc_polling; unless (@{$self->{+IPC_DRIVERS}}) { my ($ok, $error) = try { require Test2::IPC::Driver::Files }; die $error unless $ok; push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files'; } for my $driver (@{$self->{+IPC_DRIVERS}}) { next unless $driver->can('is_viable') && $driver->is_viable; $self->{+IPC} = $driver->new or next; return; } die "IPC has been requested, but no viable drivers were found. Aborting...\n"; } sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 } sub add_formatter { my $self = shift; my ($formatter) = @_; unshift @{$self->{+FORMATTERS}} => $formatter; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::Formatter'} = 1; carp "Formatter $formatter loaded too late to be used as the global formatter"; } sub add_context_acquire_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-acquire callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code; } sub add_context_init_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-init callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code; } sub add_context_release_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Context-release callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code; } sub add_post_load_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Post-load callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+POST_LOAD_CALLBACKS}} => $code; $code->() if $self->{+LOADED}; } sub add_pre_subtest_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "Pre-subtest callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code; } sub load { my $self = shift; unless ($self->{+LOADED}) { confess "Attempt to initialize Test2::API during preload" if $self->{+PRELOAD}; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; # This is for https://github.com/Test-More/test-more/issues/16 # and https://rt.perl.org/Public/Bug/Display.html?id=127774 # END blocks run in reverse order. This insures the END block is loaded # as late as possible. It will not solve all cases, but it helps. eval "END { Test2::API::test2_set_is_end() }; 1" or die $@; $self->{+LOADED} = 1; $_->() for @{$self->{+POST_LOAD_CALLBACKS}}; } return $self->{+LOADED}; } sub add_exit_callback { my $self = shift; my ($code) = @_; my $rtype = reftype($code) || ""; confess "End callbacks must be coderefs" unless $code && $rtype eq 'CODE'; push @{$self->{+EXIT_CALLBACKS}} => $code; } sub ipc_disable { my $self = shift; confess "Attempt to disable IPC after it has been initialized" if $self->{+IPC}; $self->{+IPC_DISABLED} = 1; } sub add_ipc_driver { my $self = shift; my ($driver) = @_; unshift @{$self->{+IPC_DRIVERS}} => $driver; return unless $self->{+FINALIZED}; # Why is the @CARP_NOT entry not enough? local %Carp::Internal = %Carp::Internal; $Carp::Internal{'Test2::IPC::Driver'} = 1; carp "IPC driver $driver loaded too late to be used as the global ipc driver"; } sub enable_ipc_polling { my $self = shift; $self->{+_PID} = $$ unless defined $self->{+_PID}; $self->{+_TID} = get_tid() unless defined $self->{+_TID}; $self->add_context_init_callback( # This is called every time a context is created, it needs to be fast. # $_[0] is a context object sub { return unless $self->{+IPC_POLLING}; return unless $self->{+IPC}; return unless $self->{+IPC}->pending(); return $_[0]->{hub}->cull; } ) unless defined $self->ipc_polling; $self->set_ipc_polling(1); } sub get_ipc_pending { my $self = shift; return -1 unless $self->{+IPC}; $self->{+IPC}->pending(); } sub _check_pid { my $self = shift; my ($pid) = @_; return kill(0, $pid); } sub set_ipc_pending { my $self = shift; return unless $self->{+IPC}; my ($val) = @_; confess "value is required for set_ipc_pending" unless $val; $self->{+IPC}->set_pending($val); } sub disable_ipc_polling { my $self = shift; return unless defined $self->{+IPC_POLLING}; $self->{+IPC_POLLING} = 0; } sub _ipc_wait { my ($timeout) = @_; my $fail = 0; $timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout; my $ok = eval { if (CAN_FORK) { local $SIG{ALRM} = sub { die "Timeout waiting on child processes" }; alarm $timeout; while (1) { my $pid = CORE::wait(); my $err = $?; last if $pid == -1; next unless $err; $fail++; my $sig = $err & 127; my $exit = $err >> 8; warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n"; } alarm 0; } if (USE_THREADS) { my $start = time; while (1) { last unless threads->list(); die "Timeout waiting on child thread" if time - $start >= $timeout; sleep 1; for my $t (threads->list) { # threads older than 1.34 do not have this :-( next if $t->can('is_joinable') && !$t->is_joinable; $t->join; # In older threads we cannot check if a thread had an error unless # we control it and its return. my $err = $t->can('error') ? $t->error : undef; next unless $err; my $tid = $t->tid(); $fail++; chomp($err); warn "Thread $tid did not end cleanly: $err\n"; } } } 1; }; my $error = $@; return 0 if $ok && !$fail; warn $error unless $ok; return 255; } sub set_exit { my $self = shift; return if $self->{+PRELOAD}; my $exit = $?; my $new_exit = $exit; if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) { print STDERR <<" EOT"; ******************************************************************************** * * * Test::Builder -- Test2::API version mismatch detected * * * ******************************************************************************** Test2::API Version: $Test2::API::VERSION Test::Builder Version: $Test::Builder::VERSION This is not a supported configuration, you will have problems. EOT } for my $ctx (values %{$self->{+CONTEXTS}}) { next unless $ctx; next if $ctx->_aborted && ${$ctx->_aborted}; # Only worry about contexts in this PID my $trace = $ctx->trace || next; next unless $trace->pid && $trace->pid == $$; # Do not worry about contexts that have no hub my $hub = $ctx->hub || next; # Do not worry if the state came to a sudden end. next if $hub->bailed_out; next if defined $hub->skip_reason; # now we worry $trace->alert("context object was never released! This means a testing tool is behaving very badly"); $exit = 255; $new_exit = 255; } if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) { $? = $exit; return; } my @hubs = $self->{+STACK} ? $self->{+STACK}->all : (); if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) { local $?; my %seen; for my $hub (reverse @hubs) { my $ipc = $hub->ipc or next; next if $seen{$ipc}++; $ipc->waiting(); } my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT}); $new_exit ||= $ipc_exit; } # None of this is necessary if we never got a root hub if(my $root = shift @hubs) { my $trace = Test2::EventFacet::Trace->new( frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'], detail => __PACKAGE__ . ' END Block finalization', ); my $ctx = Test2::API::Context->new( trace => $trace, hub => $root, ); if (@hubs) { $ctx->diag("Test ended with extra hubs on the stack!"); $new_exit = 255; } unless ($root->no_ending) { local $?; $root->finalize($trace) unless $root->ended; $_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}}; $new_exit ||= $root->failed; $new_exit ||= 255 unless $root->is_passing; } } $new_exit = 255 if $new_exit > 255; if ($new_exit && eval { require Test2::API::Breakage; 1 }) { my @warn = Test2::API::Breakage->report(); if (@warn) { print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n"; print STDERR "$_\n" for @warn; print STDERR "\n"; } } $? = $new_exit; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Instance - Object used by Test2::API under the hood =head1 DESCRIPTION This object encapsulates the global shared state tracked by L<Test2>. A single global instance of this package is stored (and obscured) by the L<Test2::API> package. There is no reason to directly use this package. This package is documented for completeness. This package can change, or go away completely at any time. Directly using, or monkeypatching this package is not supported in any way shape or form. =head1 SYNOPSIS use Test2::API::Instance; my $obj = Test2::API::Instance->new; =over 4 =item $pid = $obj->pid PID of this instance. =item $obj->tid Thread ID of this instance. =item $obj->reset() Reset the object to defaults. =item $obj->load() Set the internal state to loaded, and run and stored post-load callbacks. =item $bool = $obj->loaded Check if the state is set to loaded. =item $arrayref = $obj->post_load_callbacks Get the post-load callbacks. =item $obj->add_post_load_callback(sub { ... }) Add a post-load callback. If C<load()> has already been called then the callback will be immediately executed. If C<load()> has not been called then the callback will be stored and executed later when C<load()> is called. =item $hashref = $obj->contexts() Get a hashref of all active contexts keyed by hub id. =item $arrayref = $obj->context_acquire_callbacks Get all context acquire callbacks. =item $arrayref = $obj->context_init_callbacks Get all context init callbacks. =item $arrayref = $obj->context_release_callbacks Get all context release callbacks. =item $arrayref = $obj->pre_subtest_callbacks Get all pre-subtest callbacks. =item $obj->add_context_init_callback(sub { ... }) Add a context init callback. Subs are called every time a context is created. Subs get the newly created context as their only argument. =item $obj->add_context_release_callback(sub { ... }) Add a context release callback. Subs are called every time a context is released. Subs get the released context as their only argument. These callbacks should not call release on the context. =item $obj->add_pre_subtest_callback(sub { ... }) Add a pre-subtest callback. Subs are called every time a subtest is going to be run. Subs get the subtest name, coderef, and any arguments. =item $obj->set_exit() This is intended to be called in an C<END { ... }> block. This will look at test state and set $?. This will also call any end callbacks, and wait on child processes/threads. =item $obj->set_ipc_pending($val) Tell other processes and threads there is a pending event. C<$val> should be a unique value no other thread/process will generate. B<Note:> This will also make the current process see a pending event. =item $pending = $obj->get_ipc_pending() This returns -1 if it is not possible to know. This returns 0 if there are no pending events. This returns 1 if there are pending events. =item $timeout = $obj->ipc_timeout; =item $obj->set_ipc_timeout($timeout); How long to wait for child processes and threads before aborting. =item $drivers = $obj->ipc_drivers Get the list of IPC drivers. =item $obj->add_ipc_driver($DRIVER_CLASS) Add an IPC driver to the list. The most recently added IPC driver will become the global one during initialization. If a driver is added after initialization has occurred a warning will be generated: "IPC driver $driver loaded too late to be used as the global ipc driver" =item $bool = $obj->ipc_polling Check if polling is enabled. =item $obj->enable_ipc_polling Turn on polling. This will cull events from other processes and threads every time a context is created. =item $obj->disable_ipc_polling Turn off IPC polling. =item $bool = $obj->no_wait =item $bool = $obj->set_no_wait($bool) Get/Set no_wait. This option is used to turn off process/thread waiting at exit. =item $arrayref = $obj->exit_callbacks Get the exit callbacks. =item $obj->add_exit_callback(sub { ... }) Add an exit callback. This callback will be called by C<set_exit()>. =item $bool = $obj->finalized Check if the object is finalized. Finalization happens when either C<ipc()>, C<stack()>, or C<format()> are called on the object. Once finalization happens these fields are considered unchangeable (not enforced here, enforced by L<Test2>). =item $ipc = $obj->ipc Get the one true IPC instance. =item $obj->ipc_disable Turn IPC off =item $bool = $obj->ipc_disabled Check if IPC is disabled =item $stack = $obj->stack Get the one true hub stack. =item $formatter = $obj->formatter Get the global formatter. By default this is the C<'Test2::Formatter::TAP'> package. This could be any package that implements the C<write()> method. This can also be an instantiated object. =item $bool = $obj->formatter_set() Check if a formatter has been set. =item $obj->add_formatter($class) =item $obj->add_formatter($obj) Add a formatter. The most recently added formatter will become the global one during initialization. If a formatter is added after initialization has occurred a warning will be generated: "Formatter $formatter loaded too late to be used as the global formatter" =item $obj->set_add_uuid_via(sub { ... }) =item $sub = $obj->add_uuid_via() This allows you to provide a UUID generator. If provided UUIDs will be attached to all events, hubs, and contexts. This is useful for storing, tracking, and linking these objects. The sub you provide should always return a unique identifier. Most things will expect a proper UUID string, however nothing in Test2::API enforces this. The sub will receive exactly 1 argument, the type of thing being tagged 'context', 'hub', or 'event'. In the future additional things may be tagged, in which case new strings will be passed in. These are purely informative, you can (and usually should) ignore them. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/Breakage.pm 0000444 00000011332 14711217515 0011246 0 ustar 00 package Test2::API::Breakage; use strict; use warnings; our $VERSION = '1.302186'; use Test2::Util qw/pkg_to_file/; our @EXPORT_OK = qw{ upgrade_suggested upgrade_required known_broken }; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub upgrade_suggested { return ( 'Test::Exception' => '0.42', 'Test::FITesque' => '0.04', 'Test::Module::Used' => '0.2.5', 'Test::Moose::More' => '0.025', ); } sub upgrade_required { return ( 'Test::Builder::Clutch' => '0.07', 'Test::Dist::VersionSync' => '1.1.4', 'Test::Modern' => '0.012', 'Test::SharedFork' => '0.34', 'Test::Alien' => '0.04', 'Test::UseAllModules' => '0.14', 'Test::More::Prefix' => '0.005', 'Test2::Tools::EventDumper' => 0.000007, 'Test2::Harness' => 0.000013, 'Test::DBIx::Class::Schema' => '1.0.9', 'Test::Clustericious::Cluster' => '0.30', ); } sub known_broken { return ( 'Net::BitTorrent' => '0.052', 'Test::Able' => '0.11', 'Test::Aggregate' => '0.373', 'Test::Flatten' => '0.11', 'Test::Group' => '0.20', 'Test::ParallelSubtest' => '0.05', 'Test::Pretty' => '0.32', 'Test::Wrapper' => '0.3.0', 'Log::Dispatch::Config::TestLog' => '0.02', ); } # Not reportable: # Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. sub report { my $class = shift; my ($require) = @_; my %suggest = __PACKAGE__->upgrade_suggested(); my %required = __PACKAGE__->upgrade_required(); my %broken = __PACKAGE__->known_broken(); my @warn; for my $mod (keys %suggest) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $suggest{$mod}; next if eval { $mod->VERSION($want); 1 }; my $error = $@; chomp $error; push @warn => " * Module '$mod' is outdated, we recommed updating above $want. error was: '$error'; INC is $INC{$file}"; } for my $mod (keys %required) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $required{$mod}; next if eval { $mod->VERSION($want); 1 }; push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; } for my $mod (keys %broken) { my $file = pkg_to_file($mod); next unless $INC{$file} || ($require && eval { require $file; 1 }); my $tested = $broken{$mod}; push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; } return @warn; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Breakage - What breaks at what version =head1 DESCRIPTION This module provides lists of modules that are broken, or have been broken in the past, when upgrading L<Test::Builder> to use L<Test2>. =head1 FUNCTIONS These can be imported, or called as methods on the class. =over 4 =item %mod_ver = upgrade_suggested() =item %mod_ver = Test2::API::Breakage->upgrade_suggested() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then an upgrade would be a good idea, but not strictly necessary. =item %mod_ver = upgrade_required() =item %mod_ver = Test2::API::Breakage->upgrade_required() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then an upgrade is required for the module to work properly. =item %mod_ver = known_broken() =item %mod_ver = Test2::API::Breakage->known_broken() This returns key/value pairs. The key is the module name, the value is the version number. If the installed version of the module is at or below the specified one then the module will not work. A newer version may work, but is not tested or verified. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/Stack.pm 0000444 00000011376 14711217515 0010622 0 ustar 00 package Test2::API::Stack; use strict; use warnings; our $VERSION = '1.302186'; use Test2::Hub(); use Carp qw/confess/; sub new { my $class = shift; return bless [], $class; } sub new_hub { my $self = shift; my %params = @_; my $class = delete $params{class} || 'Test2::Hub'; my $hub = $class->new(%params); if (@$self) { $hub->inherit($self->[-1], %params); } else { require Test2::API; $hub->format(Test2::API::test2_formatter()->new_root) unless $hub->format || exists($params{formatter}); my $ipc = Test2::API::test2_ipc(); if ($ipc && !$hub->ipc && !exists($params{ipc})) { $hub->set_ipc($ipc); $ipc->add_hub($hub->hid); } } push @$self => $hub; $hub; } sub top { my $self = shift; return $self->new_hub unless @$self; return $self->[-1]; } sub peek { my $self = shift; return @$self ? $self->[-1] : undef; } sub cull { my $self = shift; $_->cull for reverse @$self; } sub all { my $self = shift; return @$self; } sub root { my $self = shift; return unless @$self; return $self->[0]; } sub clear { my $self = shift; @$self = (); } # Do these last without keywords in order to prevent them from getting used # when we want the real push/pop. { no warnings 'once'; *push = sub { my $self = shift; my ($hub) = @_; $hub->inherit($self->[-1]) if @$self; push @$self => $hub; }; *pop = sub { my $self = shift; my ($hub) = @_; confess "No hubs on the stack" unless @$self; confess "You cannot pop the root hub" if 1 == @$self; confess "Hub stack mismatch, attempted to pop incorrect hub" unless $self->[-1] == $hub; pop @$self; }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::Stack - Object to manage a stack of L<Test2::Hub> instances. =head1 ***INTERNALS NOTE*** B<The internals of this package are subject to change at any time!> The public methods provided will not change in backwards incompatible ways, but the underlying implementation details might. B<Do not break encapsulation here!> =head1 DESCRIPTION This module is used to represent and manage a stack of L<Test2::Hub> objects. Hubs are usually in a stack so that you can push a new hub into place that can intercept and handle events differently than the primary hub. =head1 SYNOPSIS my $stack = Test2::API::Stack->new; my $hub = $stack->top; =head1 METHODS =over 4 =item $stack = Test2::API::Stack->new() This will create a new empty stack instance. All arguments are ignored. =item $hub = $stack->new_hub() =item $hub = $stack->new_hub(%params) =item $hub = $stack->new_hub(%params, class => $class) This will generate a new hub and push it to the top of the stack. Optionally you can provide arguments that will be passed into the constructor for the L<Test2::Hub> object. If you specify the C<< 'class' => $class >> argument, the new hub will be an instance of the specified class. Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the formatter and IPC instance will be inherited from the current top hub. You can set the parameters to C<undef> to avoid having a formatter or IPC instance. If there is no top hub, and you do not ask to leave IPC and formatter undef, then a new formatter will be created, and the IPC instance from L<Test2::API> will be used. =item $hub = $stack->top() This will return the top hub from the stack. If there is no top hub yet this will create it. =item $hub = $stack->peek() This will return the top hub from the stack. If there is no top hub yet this will return undef. =item $stack->cull This will call C<< $hub->cull >> on all hubs in the stack. =item @hubs = $stack->all This will return all the hubs in the stack as a list. =item $stack->clear This will completely remove all hubs from the stack. Normally you do not want to do this, but there are a few valid reasons for it. =item $stack->push($hub) This will push the new hub onto the stack. =item $stack->pop($hub) This will pop a hub from the stack, if the hub at the top of the stack does not match the hub you expect (passed in as an argument) it will throw an exception. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/InterceptResult.pm 0000444 00000043350 14711217515 0012706 0 ustar 00 package Test2::API::InterceptResult; use strict; use warnings; our $VERSION = '1.302186'; use Scalar::Util qw/blessed/; use Test2::Util qw/pkg_to_file/; use Storable qw/dclone/; use Carp qw/croak/; use Test2::API::InterceptResult::Squasher; use Test2::API::InterceptResult::Event; use Test2::API::InterceptResult::Hub; sub new { croak "Called a method that creates a new instance in void context" unless defined wantarray; my $class = shift; bless([@_], $class); } sub new_from_ref { croak "Called a method that creates a new instance in void context" unless defined wantarray; bless($_[1], $_[0]); } sub clone { blessed($_[0])->new(@{dclone($_[0])}) } sub event_list { @{$_[0]} } sub _upgrade { my $self = shift; my ($event, %params) = @_; my $blessed = blessed($event); my $upgrade_class = $params{upgrade_class} ||= 'Test2::API::InterceptResult::Event'; return $event if $blessed && $event->isa($upgrade_class) && !$params{_upgrade_clone}; my $fd = dclone($blessed ? $event->facet_data : $event); my $class = $params{result_class} ||= blessed($self); if (my $parent = $fd->{parent}) { $parent->{children} = $class->new_from_ref($parent->{children} || [])->upgrade(%params); } my $uc_file = pkg_to_file($upgrade_class); require($uc_file) unless $INC{$uc_file}; return $upgrade_class->new(facet_data => $fd, result_class => $class); } sub hub { my $self = shift; my $hub = Test2::API::InterceptResult::Hub->new(); $hub->process($_) for @$self; $hub->set_ended(1); return $hub; } sub state { my $self = shift; my %params = @_; my $hub = $self->hub; my $out = { map {($_ => scalar $hub->$_)} qw/count failed is_passing plan bailed_out skip_reason/ }; $out->{bailed_out} = $self->_upgrade($out->{bailed_out}, %params)->bailout_reason || 1 if $out->{bailed_out}; $out->{follows_plan} = $hub->check_plan; return $out; } sub upgrade { my $self = shift; my %params = @_; my @out = map { $self->_upgrade($_, %params, _upgrade_clone => 1) } @$self; return blessed($self)->new_from_ref(\@out) unless $params{in_place}; @$self = @out; return $self; } sub squash_info { my $self = shift; my %params = @_; my @out; { my $squasher = Test2::API::InterceptResult::Squasher->new(events => \@out); # Clone to make sure we do not indirectly modify an existing one if it # is already upgraded $squasher->process($self->_upgrade($_, %params)->clone) for @$self; $squasher->flush_down(); } return blessed($self)->new_from_ref(\@out) unless $params{in_place}; @$self = @out; return $self; } sub asserts { shift->grep(has_assert => @_) } sub subtests { shift->grep(has_subtest => @_) } sub diags { shift->grep(has_diags => @_) } sub notes { shift->grep(has_notes => @_) } sub errors { shift->grep(has_errors => @_) } sub plans { shift->grep(has_plan => @_) } sub causes_fail { shift->grep(causes_fail => @_) } sub causes_failure { shift->grep(causes_failure => @_) } sub flatten { shift->map(flatten => @_) } sub briefs { shift->map(brief => @_) } sub summaries { shift->map(summary => @_) } sub subtest_results { shift->map(subtest_result => @_) } sub diag_messages { shift->map(diag_messages => @_) } sub note_messages { shift->map(note_messages => @_) } sub error_messages { shift->map(error_messages => @_) } no warnings 'once'; *map = sub { my $self = shift; my ($call, %params) = @_; my $args = $params{args} ||= []; return [map { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self]; }; *grep = sub { my $self = shift; my ($call, %params) = @_; my $args = $params{args} ||= []; my @out = grep { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self; return blessed($self)->new_from_ref(\@out) unless $params{in_place}; @$self = @out; return $self; }; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult - Representation of a list of events. =head1 DESCRIPTION This class represents a list of events, normally obtained using C<intercept()> from L<Test2::API>. This class is intended for people who with to verify the results of test tools they write. This class provides methods to normalize, summarize, or map the list of events. The output of these operations makes verifying your testing tools and the events they generate significantly easier. In most cases this spares you from needing a deep understanding of the event/facet model. =head1 SYNOPSIS Usually you get an instance of this class when you use C<intercept()> from L<Test2::API>. use Test2::V0; use Test2::API qw/intercept/; my $events = intercept { ok(1, "pass"); ok(0, "fail"); todo "broken" => sub { ok(0, "fixme") }; plan 3; }; # This is typically the most useful construct # squash_info() merges assertions and diagnostics that are associated # (and returns a new instance with the modifications) # flatten() condenses the facet data into the key details for each event # (and returns those structures in an arrayref) is( $events->squash_info->flatten(), [ { causes_failure => 0, name => 'pass', pass => 1, trace_file => 'xxx.t', trace_line => 5, }, { causes_failure => 1, name => 'fail', pass => 0, trace_file => 'xxx.t', trace_line => 6, # There can be more than one diagnostics message so this is # always an array when present. diag => ["Failed test 'fail'\nat xxx.t line 6."], }, { causes_failure => 0, name => 'fixme', pass => 0, trace_file => 'xxx.t', trace_line => 7, # There can be more than one diagnostics message or todo # reason, so these are always an array when present. todo => ['broken'], # Diag message was turned into a note since the assertion was # TODO note => ["Failed test 'fixme'\nat xxx.t line 7."], }, { causes_failure => 0, plan => 3, trace_file => 'xxx.t', trace_line => 8, }, ], "Flattened events look like we expect" ); See L<Test2::API::InterceptResult::Event> for a full description of what C<flatten()> provides for each event. =head1 METHODS Please note that no methods modify the original instance unless asked to do so. =head2 CONSTRUCTION =over 4 =item $events = Test2::API::InterceptResult->new(@EVENTS) =item $events = Test2::API::InterceptResult->new_from_ref(\@EVENTS) These create a new instance of Test2::API::InterceptResult from the given events. In the first form a new blessed arrayref is returned. In the 'new_from_ref' form the reference you pass in is directly blessed. Both of these will throw an exception if called in void context. This is mainly important for the 'filtering' methods listed below which normally return a new instance, they throw an exception in such cases as it probably means someone meant to filter the original in place. =item $clone = $events->clone() Make a clone of the original events. Note that this is a deep copy, the entire structure is duplicated. This uses C<dclone> from L<Storable> to achieve the deep clone. =back =head2 NORMALIZATION =over 4 =item @events = $events->event_list This returns all the events in list-form. =item $hub = $events->hub This returns a new L<Test2::Hub> instance that has processed all the events contained in the instance. This gives you a simple way to inspect the state changes your events cause. =item $state = $events->state This returns a summary of the state of a hub after processing all the events. { count => 2, # Number of assertions made failed => 1, # Number of test failures seen is_passing => 0, # Boolean, true if the test would be passing # after the events are processed. plan => 2, # Plan, either a number, undef, 'SKIP', or 'NO PLAN' follows_plan => 1, # True if there is a plan and it was followed. # False if the plan and assertions did not # match, undef if no plan was present in the # event list. bailed_out => undef, # undef unless there was a bail-out in the # events in which case this will be a string # explaining why there was a bailout, if no # reason was given this will simply be set to # true (1). skip_reason => undef, # If there was a skip_all this will give the # reason. } =item $new = $events->upgrade =item $events->upgrade(in_place => $BOOL) B<Note:> This normally returns a new instance, leaving the original unchanged. If you call it in void context it will throw an exception. If you want to modify the original you must pass in the C<< in_place => 1 >> option. You may call this in void context when you ask to modify it in place. The in-place form returns the instance that was modified so you can chain methods. This will create a clone of the list where all events have been converted into L<Test2::API::InterceptResult::Event> instances. This is extremely helpful as L<Test2::API::InterceptResult::Event> provide a much better interface for working with events. This allows you to avoid thinking about legacy event types. This also means your tests against the list are not fragile if the tool you are testing randomly changes what type of events it generates (IE Changing from L<Test2::Event::Ok> to L<Test2::Event::Pass>, both make assertions and both will normalize to identical (or close enough) L<Test2::API::InterceptResult::Event> instances. Really you almost always want this, the only reason it is not done automatically is to make sure the C<intercept()> tool is backwards compatible. =item $new = $events->squash_info =item $events->squash_info(in_place => $BOOL) B<Note:> This normally returns a new instance, leaving the original unchanged. If you call it in void context it will throw an exception. If you want to modify the original you must pass in the C<< in_place => 1 >> option. You may call this in void context when you ask to modify it in place. The in-place form returns the instance that was modified so you can chain methods. B<Note:> All events in the new or modified instance will be converted to L<Test2::API::InterceptResult::Event> instances. There is no way to avoid this, the squash operation requires the upgraded event class. L<Test::More> and many other legacy tools would send notes, diags, and assertions as seperate events. A subtest in L<Test::More> would send a note with the subtest name, the subtest assertion, and finally a diagnostics event if the subtest failed. This method will normalize things by squashing the note and diag into the same event as the subtest (This is different from putting them into the subtest, which is not what happens). =back =head2 FILTERING B<Note:> These normally return new instances, leaving the originals unchanged. If you call them in void context they will throw exceptions. If you want to modify the originals you must pass in the C<< in_place => 1 >> option. You may call these in void context when you ask to modify them in place. The in-place forms return the instance that was modified so you can chain methods. =head3 %PARAMS These all accept the same 2 optional parameters: =over 4 =item in_place => $BOOL When true the method will modify the instance in place instead of returning a new instance. =item args => \@ARGS If you wish to pass parameters into the event method being used for filtering, you may do so here. =back =head3 METHODS =over 4 =item $events->grep($CALL, %PARAMS) This is essentially: Test2::API::InterceptResult->new( grep { $_->$CALL( @{$PARAMS{args}} ) } $self->event_list, ); B<Note:> that $CALL is called on an upgraded version of the event, though the events returned will be the original ones, not the upgraded ones. $CALL may be either the name of a method on L<Test2::API::InterceptResult::Event>, or a coderef. =item $events->asserts(%PARAMS) This is essentially: $events->grep(has_assert => @{$PARAMS{args}}) It returns a new instance containing only the events that made assertions. =item $events->subtests(%PARAMS) This is essentially: $events->grep(has_subtest => @{$PARAMS{args}}) It returns a new instance containing only the events that have subtests. =item $events->diags(%PARAMS) This is essentially: $events->grep(has_diags => @{$PARAMS{args}}) It returns a new instance containing only the events that have diags. =item $events->notes(%PARAMS) This is essentially: $events->grep(has_notes => @{$PARAMS{args}}) It returns a new instance containing only the events that have notes. =item $events->errors(%PARAMS) B<Note:> Errors are NOT failing assertions. Failing assertions are a different thing. This is essentially: $events->grep(has_errors => @{$PARAMS{args}}) It returns a new instance containing only the events that have errors. =item $events->plans(%PARAMS) This is essentially: $events->grep(has_plan => @{$PARAMS{args}}) It returns a new instance containing only the events that set the plan. =item $events->causes_fail(%PARAMS) =item $events->causes_failure(%PARAMS) These are essentially: $events->grep(causes_fail => @{$PARAMS{args}}) $events->grep(causes_failure => @{$PARAMS{args}}) B<Note:> C<causes_fail()> and C<causes_failure()> are both aliases for eachother in events, so these methods are effectively aliases here as well. It returns a new instance containing only the events that cause failure. =back =head2 MAPPING These methods B<ALWAYS> return an arrayref. B<Note:> No methods on L<Test2::API::InterceptResult::Event> alter the event in any way. B<Important Notes about Events>: L<Test2::API::InterceptResult::Event> was tailor-made to be used in event-lists. Most methods that are not applicable to a given event will return an empty list, so you normally do not need to worry about unwanted C<undef> values or exceptions being thrown. Mapping over event methods is an entended use, so it works well to produce lists. B<Exceptions to the rule:> Some methods such as C<causes_fail> always return a boolean true or false for all events. Any method prefixed with C<the_> conveys the intent that the event should have exactly 1 of something, so those will throw an exception when that condition is not true. =over 4 =item $arrayref = $events->map($CALL, %PARAMS) This is essentially: [ map { $_->$CALL(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; $CALL may be either the name of a method on L<Test2::API::InterceptResult::Event>, or a coderef. =item $arrayref = $events->flatten(%PARAMS) This is essentially: [ map { $_->flatten(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of flattened structures. See L<Test2::API::InterceptResult::Event> for details on what C<flatten()> returns. =item $arrayref = $events->briefs(%PARAMS) This is essentially: [ map { $_->briefs(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of event briefs. See L<Test2::API::InterceptResult::Event> for details on what C<brief()> returns. =item $arrayref = $events->summaries(%PARAMS) This is essentially: [ map { $_->summaries(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of event summaries. See L<Test2::API::InterceptResult::Event> for details on what C<summary()> returns. =item $arrayref = $events->subtest_results(%PARAMS) This is essentially: [ map { $_->subtest_result(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of event summaries. See L<Test2::API::InterceptResult::Event> for details on what C<subtest_result()> returns. =item $arrayref = $events->diag_messages(%PARAMS) This is essentially: [ map { $_->diag_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of diagnostic messages (strings). See L<Test2::API::InterceptResult::Event> for details on what C<diag_messages()> returns. =item $arrayref = $events->note_messages(%PARAMS) This is essentially: [ map { $_->note_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of notification messages (strings). See L<Test2::API::InterceptResult::Event> for details on what C<note_messages()> returns. =item $arrayref = $events->error_messages(%PARAMS) This is essentially: [ map { $_->error_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ]; It returns a new list of error messages (strings). See L<Test2::API::InterceptResult::Event> for details on what C<error_messages()> returns. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/InterceptResult/Squasher.pm 0000444 00000007132 14711217515 0014477 0 ustar 00 package Test2::API::InterceptResult::Squasher; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/croak/; use List::Util qw/first/; use Test2::Util::HashBase qw{ <events +down_sig +down_buffer +up_into +up_sig +up_clear }; sub init { my $self = shift; croak "'events' is a required attribute" unless $self->{+EVENTS}; } sub can_squash { my $self = shift; my ($event) = @_; # No info, no squash return unless $event->has_info; # Do not merge up if one of these is true return if first { $event->$_ } 'causes_fail', 'has_assert', 'has_bailout', 'has_errors', 'has_plan', 'has_subtest'; # Signature if we can squash return $event->trace_signature; } sub process { my $self = shift; my ($event) = @_; return if $self->squash_up($event); return if $self->squash_down($event); $self->flush_down($event); push @{$self->{+EVENTS}} => $event; return; } sub squash_down { my $self = shift; my ($event) = @_; my $sig = $self->can_squash($event) or return; $self->flush_down() if $self->{+DOWN_SIG} && $self->{+DOWN_SIG} ne $sig; $self->{+DOWN_SIG} ||= $sig; push @{$self->{+DOWN_BUFFER}} => $event; return 1; } sub flush_down { my $self = shift; my ($into) = @_; my $sig = delete $self->{+DOWN_SIG}; my $buffer = delete $self->{+DOWN_BUFFER}; return unless $buffer && @$buffer; my $fsig = $into ? $into->trace_signature : undef; if ($fsig && $fsig eq $sig) { $self->squash($into, @$buffer); } else { push @{$self->{+EVENTS}} => @$buffer if $buffer; } } sub clear_up { my $self = shift; return unless $self->{+UP_CLEAR}; delete $self->{+UP_INTO}; delete $self->{+UP_SIG}; delete $self->{+UP_CLEAR}; } sub squash_up { my $self = shift; my ($event) = @_; no warnings 'uninitialized'; $self->clear_up; if ($event->has_assert) { if(my $sig = $event->trace_signature) { $self->{+UP_INTO} = $event; $self->{+UP_SIG} = $sig; $self->{+UP_CLEAR} = 0; } else { $self->{+UP_CLEAR} = 1; $self->clear_up; } return; } my $into = $self->{+UP_INTO} or return; # Next iteration should clear unless something below changes that $self->{+UP_CLEAR} = 1; # Only merge into matching trace signatres my $sig = $self->can_squash($event); return unless $sig eq $self->{+UP_SIG}; # OK Merge! Do not clear merge in case the return event is also a matching sig diag-only $self->{+UP_CLEAR} = 0; $self->squash($into, $event); return 1; } sub squash { my $self = shift; my ($into, @from) = @_; push @{$into->facet_data->{info}} => $_->info for @from; } sub DESTROY { my $self = shift; return unless $self->{+EVENTS}; $self->flush_down(); return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Squasher - Encapsulation of the algorithm that squashes diags into assertions. =head1 DESCRIPTION Internal use only, please ignore. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/InterceptResult/Hub.pm 0000444 00000001707 14711217515 0013424 0 ustar 00 package Test2::API::InterceptResult::Hub; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; sub init { my $self = shift; $self->SUPER::init(); $self->{+NESTED} = 0; } sub inherit { my $self = shift; $self->{+NESTED} = 0; } sub terminate { } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Hub - Hub used by InterceptResult. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/InterceptResult/Event.pm 0000444 00000067735 14711217515 0014004 0 ustar 00 package Test2::API::InterceptResult::Event; use strict; use warnings; our $VERSION = '1.302186'; use List::Util qw/first/; use Test2::Util qw/pkg_to_file/; use Scalar::Util qw/reftype blessed/; use Storable qw/dclone/; use Carp qw/confess croak/; use Test2::API::InterceptResult::Facet; use Test2::API::InterceptResult::Hub; use Test2::Util::HashBase qw{ +causes_failure <facet_data <result_class }; my %FACETS; BEGIN { local $@; local *plugins; if (eval { require Module::Pluggable; 1 }) { Module::Pluggable->import( # We will replace the sub later require => 1, on_require_error => sub { 1 }, search_path => ['Test2::EventFacet'], max_depth => 3, min_depth => 3, ); for my $facet_type (__PACKAGE__->plugins) { my ($key, $list); eval { $key = $facet_type->facet_key; $list = $facet_type->is_list; }; next unless $key && defined($list); $FACETS{$key} = {list => $list, class => $facet_type, loaded => 1}; } } $FACETS{__GENERIC__} = {class => 'Test2::API::InterceptResult::Facet', loaded => 1}; } sub facet_map { \%FACETS } sub facet_info { my $facet = pop; return $FACETS{$facet} if exists $FACETS{$facet}; my $mname = ucfirst(lc($facet)); $mname =~ s/s$//; for my $name ($mname, "${mname}s") { my $file = "Test2/EventFacet/$name.pm"; my $class = "Test2::EventFacet::$name"; local $@; my $ok = eval { require $file; my $key = $class->facet_key; my $list = $class->is_list; $FACETS{$key} = {list => $list, class => $class, loaded => 1}; $FACETS{$facet} = $FACETS{$key} if $facet ne $key; 1; }; return $FACETS{$facet} if $ok && $FACETS{$facet}; } return $FACETS{$facet} = $FACETS{__GENERIC__}; } sub init { my $self = shift; my $rc = $self->{+RESULT_CLASS} ||= 'Test2::API::InterceptResult'; my $rc_file = pkg_to_file($rc); require($rc_file) unless $INC{$rc_file}; my $fd = $self->{+FACET_DATA} ||= {}; for my $facet (keys %$fd) { my $finfo = $self->facet_info($facet); my $is_list = $finfo->{list}; next unless defined $is_list; my $type = reftype($fd->{$facet}); if ($is_list) { confess "Facet '$facet' is a list facet, but got '$type' instead of an arrayref" unless $type eq 'ARRAY'; for my $item (@{$fd->{$facet}}) { my $itype = reftype($item); next if $itype eq 'HASH'; confess "Got item type '$itype' in list-facet '$facet', all items must be hashrefs"; } } else { confess "Facet '$facet' is an only-one facet, but got '$type' instead of a hashref" unless $type eq 'HASH'; } } } sub clone { my $self = shift; my $class = blessed($self); my %data = %$self; $data{+FACET_DATA} = dclone($data{+FACET_DATA}); return bless(\%data, $class); } sub _facet_class { my $self = shift; my ($name) = @_; my $spec = $self->facet_info($name); my $class = $spec->{class}; unless ($spec->{loaded}) { my $file = pkg_to_file($class); require $file unless $INC{$file}; $spec->{loaded} = 1; } return $class; } sub the_facet { my $self = shift; my ($name) = @_; return undef unless defined $self->{+FACET_DATA}->{$name}; my $data = $self->{+FACET_DATA}->{$name}; my $type = reftype($data) or confess "Facet '$name' has a value that is not a reference, this should not happen"; return $self->_facet_class($name)->new(%{dclone($data)}) if $type eq 'HASH'; if ($type eq 'ARRAY') { return undef unless @$data; croak "'the_facet' called for facet '$name', but '$name' has '" . @$data . "' items" if @$data != 1; return $self->_facet_class($name)->new(%{dclone($data->[0])}); } die "Invalid facet data type: $type"; } sub facet { my $self = shift; my ($name) = @_; return () unless exists $self->{+FACET_DATA}->{$name}; my $data = $self->{+FACET_DATA}->{$name}; my $type = reftype($data) or confess "Facet '$name' has a value that is not a reference, this should not happen"; my @out; @out = ($data) if $type eq 'HASH'; @out = (@$data) if $type eq 'ARRAY'; my $class = $self->_facet_class($name); return map { $class->new(%{dclone($_)}) } @out; } sub causes_failure { my $self = shift; return $self->{+CAUSES_FAILURE} if exists $self->{+CAUSES_FAILURE}; my $hub = Test2::API::InterceptResult::Hub->new(); $hub->process($self); return $self->{+CAUSES_FAILURE} = ($hub->is_passing ? 0 : 1); } sub causes_fail { shift->causes_failure } sub trace { $_[0]->facet('trace') } sub the_trace { $_[0]->the_facet('trace') } sub frame { my $t = $_[0]->the_trace or return undef; $t->{frame} || undef } sub trace_details { my $t = $_[0]->the_trace or return undef; $t->{details} || undef } sub trace_package { my $f = $_[0]->frame or return undef; $f->[0] || undef } sub trace_file { my $f = $_[0]->frame or return undef; $f->[1] || undef } sub trace_line { my $f = $_[0]->frame or return undef; $f->[2] || undef } sub trace_subname { my $f = $_[0]->frame or return undef; $f->[3] || undef } sub trace_tool { my $f = $_[0]->frame or return undef; $f->[3] || undef } sub trace_signature { my $t = $_[0]->the_trace or return undef; Test2::EventFacet::Trace::signature($t) || undef } sub brief { my $self = shift; my @try = qw{ bailout_brief error_brief assert_brief plan_brief }; for my $meth (@try) { my $got = $self->$meth or next; return $got; } return; } sub flatten { my $self = shift; my %params = @_; my $todo = {%{$self->{+FACET_DATA}}}; delete $todo->{hubs}; delete $todo->{meta}; delete $todo->{trace}; my $out = $self->summary; delete $out->{brief}; delete $out->{facets}; delete $out->{trace_tool}; delete $out->{trace_details} unless defined($out->{trace_details}); for my $tagged (grep { my $finfo = $self->facet_info($_); $finfo->{list} && $finfo->{class}->can('tag') } keys %FACETS, keys %$todo) { my $set = delete $todo->{$tagged} or next; my $fd = $self->{+FACET_DATA}; my $has_assert = $self->has_assert; my $has_parent = $self->has_subtest; my $has_fatal_error = $self->has_errors && grep { $_->{fail} } $self->errors; next if $tagged eq 'amnesty' && !($has_assert || $has_parent || $has_fatal_error); for my $item (@$set) { push @{$out->{lc($item->{tag})}} => $item->{fail} ? "FATAL: $item->{details}" : $item->{details}; } } if (my $assert = delete $todo->{assert}) { $out->{pass} = $assert->{pass}; $out->{name} = $assert->{details}; } if (my $parent = delete $todo->{parent}) { delete $out->{subtest}->{bailed_out} unless defined $out->{subtest}->{bailed_out}; delete $out->{subtest}->{skip_reason} unless defined $out->{subtest}->{skip_reason}; if (my $res = $self->subtest_result) { my $state = $res->state; delete $state->{$_} for grep { !defined($state->{$_}) } keys %$state; $out->{subtest} = $state; $out->{subevents} = $res->flatten(%params) if $params{include_subevents}; } } if (my $control = delete $todo->{control}) { if ($control->{halt}) { $out->{bailed_out} = $control->{details} || 1; } elsif(defined $control->{details}) { $out->{control} = $control->{details}; } } if (my $plan = delete $todo->{plan}) { $out->{plan} = $self->plan_brief; $out->{plan} =~ s/^PLAN\s*//; } for my $other (keys %$todo) { my $data = $todo->{$other} or next; if (reftype($data) eq 'ARRAY') { if (!$out->{$other} || reftype($out->{$other}) eq 'ARRAY') { for my $item (@$data) { push @{$out->{$other}} => $item->{details} if defined $item->{details}; } } } else { $out->{$other} = $data->{details} if defined($data->{details}) && !defined($out->{$other}); } } if (my $fields = $params{fields}) { $out = { map {exists($out->{$_}) ? ($_ => $out->{$_}) : ()} @$fields }; } if (my $remove = $params{remove}) { delete $out->{$_} for @$remove; } return $out; } sub summary { my $self = shift; my %params = @_; my $out = { brief => $self->brief || '', causes_failure => $self->causes_failure, trace_line => $self->trace_line, trace_file => $self->trace_file, trace_tool => $self->trace_subname, trace_details => $self->trace_details, facets => [ sort keys(%{$self->{+FACET_DATA}}) ], }; if (my $fields = $params{fields}) { $out = { map {exists($out->{$_}) ? ($_ => $out->{$_}) : ()} @$fields }; } if (my $remove = $params{remove}) { delete $out->{$_} for @$remove; } return $out; } sub has_assert { $_[0]->{+FACET_DATA}->{assert} ? 1 : 0 } sub the_assert { $_[0]->the_facet('assert') } sub assert { $_[0]->facet('assert') } sub assert_brief { my $self = shift; my $fd = $self->{+FACET_DATA}; my $as = $fd->{assert} or return; my $am = $fd->{amnesty}; my $out = $as->{pass} ? "PASS" : "FAIL"; $out .= " with amnesty" if $am; return $out; } sub has_subtest { $_[0]->{+FACET_DATA}->{parent} ? 1 : 0 } sub the_subtest { $_[0]->the_facet('parent') } sub subtest { $_[0]->facet('parent') } sub subtest_result { my $self = shift; my $parent = $self->{+FACET_DATA}->{parent} or return; my $children = $parent->{children} || []; $children = $self->{+RESULT_CLASS}->new(@$children)->upgrade unless blessed($children) && $children->isa($self->{+RESULT_CLASS}); return $children; } sub has_bailout { $_[0]->bailout ? 1 : 0 } sub the_bailout { my ($b) = $_[0]->bailout; $b } sub bailout { my $self = shift; my $control = $self->{+FACET_DATA}->{control} or return; return $control if $control->{halt}; return; } sub bailout_brief { my $self = shift; my $bo = $self->bailout or return; my $reason = $bo->{details} or return "BAILED OUT"; return "BAILED OUT: $reason"; } sub bailout_reason { my $self = shift; my $bo = $self->bailout or return; return $bo->{details} || ''; } sub has_plan { $_[0]->{+FACET_DATA}->{plan} ? 1 : 0 } sub the_plan { $_[0]->the_facet('plan') } sub plan { $_[0]->facet('plan') } sub plan_brief { my $self = shift; my $plan = $self->{+FACET_DATA}->{plan} or return; my $base = $self->_plan_brief($plan); my $reason = $plan->{details} or return $base; return "$base: $reason"; } sub _plan_brief { my $self = shift; my ($plan) = @_; return 'NO PLAN' if $plan->{none}; return "SKIP ALL" if $plan->{skip} || !$plan->{count}; return "PLAN $plan->{count}"; } sub has_amnesty { $_[0]->{+FACET_DATA}->{amnesty} ? 1 : 0 } sub the_amnesty { $_[0]->the_facet('amnesty') } sub amnesty { $_[0]->facet('amnesty') } sub amnesty_reasons { map { $_->{details} } $_[0]->amnesty } sub has_todos { &first(sub { uc($_->{tag}) eq 'TODO' }, $_[0]->amnesty) ? 1 : 0 } sub todos { grep { uc($_->{tag}) eq 'TODO' } $_[0]->amnesty } sub todo_reasons { map { $_->{details} || 'TODO' } $_[0]->todos } sub has_skips { &first(sub { uc($_->{tag}) eq 'SKIP' }, $_[0]->amnesty) ? 1 : 0 } sub skips { grep { uc($_->{tag}) eq 'SKIP' } $_[0]->amnesty } sub skip_reasons { map { $_->{details} || 'SKIP' } $_[0]->skips } my %TODO_OR_SKIP = (SKIP => 1, TODO => 1); sub has_other_amnesty { &first( sub { !$TODO_OR_SKIP{uc($_->{tag})} }, $_[0]->amnesty) ? 1 : 0 } sub other_amnesty { grep { !$TODO_OR_SKIP{uc($_->{tag})} } $_[0]->amnesty } sub other_amnesty_reasons { map { $_->{details} || $_->{tag} || 'AMNESTY' } $_[0]->other_amnesty } sub has_errors { $_[0]->{+FACET_DATA}->{errors} ? 1 : 0 } sub the_errors { $_[0]->the_facet('errors') } sub errors { $_[0]->facet('errors') } sub error_messages { map { $_->{details} || $_->{tag} || 'ERROR' } $_[0]->errors } sub error_brief { my $self = shift; my $errors = $self->{+FACET_DATA}->{errors} or return; my $base = @$errors > 1 ? "ERRORS" : "ERROR"; return $base unless @$errors; my ($msg, @extra) = split /[\n\r]+/, $errors->[0]->{details}; my $out = "$base: $msg"; $out .= " [...]" if @extra || @$errors > 1; return $out; } sub has_info { $_[0]->{+FACET_DATA}->{info} ? 1 : 0 } sub the_info { $_[0]->the_facet('info') } sub info { $_[0]->facet('info') } sub info_messages { map { $_->{details} } $_[0]->info } sub has_diags { &first(sub { uc($_->{tag}) eq 'DIAG' }, $_[0]->info) ? 1 : 0 } sub diags { grep { uc($_->{tag}) eq 'DIAG' } $_[0]->info } sub diag_messages { map { $_->{details} || 'DIAG' } $_[0]->diags } sub has_notes { &first(sub { uc($_->{tag}) eq 'NOTE' }, $_[0]->info) ? 1 : 0 } sub notes { grep { uc($_->{tag}) eq 'NOTE' } $_[0]->info } sub note_messages { map { $_->{details} || 'NOTE' } $_[0]->notes } my %NOTE_OR_DIAG = (NOTE => 1, DIAG => 1); sub has_other_info { &first(sub { !$NOTE_OR_DIAG{uc($_->{tag})} }, $_[0]->info) ? 1 : 0 } sub other_info { grep { !$NOTE_OR_DIAG{uc($_->{tag})} } $_[0]->info } sub other_info_messages { map { $_->{details} || $_->{tag} || 'INFO' } $_[0]->other_info } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Event - Representation of an event for use in testing other test tools. =head1 DESCRIPTION C<intercept { ... }> from L<Test2::API> returns an instance of L<Test2::API::InterceptResult> which is a blessed arrayref of L<Test2::API::InterceptResult::Event> objects. This POD documents the methods of these events, which are mainly provided for you to use when testing your test tools. =head1 SYNOPSIS use Test2::V0; use Test2::API qw/intercept/; my $events = intercept { ok(1, "A passing assertion"); plan(1); }; # This will convert all events into instances of # Test2::API::InterceptResult::Event. Until we do this they are the # original Test::Event::* instances $events->upgrade(in_place => 1); # Now we can get individual events in this form my $assert = $events->[0]; my $plan = $events->[1]; # Or we can operate on all events at once: my $flattened = $events->flatten; is( $flattened, [ { causes_failure => 0, name => 'A passing assertion', pass => 1, trace_file => 'xxx.t', trace_line => 5, }, { causes_failure => 0, plan => 1, trace_file => 'xxx.t', trace_line => 6, }, ], "Flattened both events and returned an arrayref of the results ); =head1 METHODS =head2 !!! IMPORTANT NOTES ON DESIGN !!! Please pay attention to what these return, many return a scalar when applicable or an empty list when not (as opposed to undef). Many also always return a list of 0 or more items. Some always return a scalar. Note that none of the methods care about context, their behavior is consistent regardless of scalar, list, or void context. This was done because this class was specifically designed to be used in a list and generate more lists in bulk operations. Sometimes in a map you want nothing to show up for the event, and you do not want an undef in its place. In general single event instances are not going to be used alone, though that is allowed. As a general rule any method prefixed with C<the_> implies the event should have exactly 1 of the specified item, and and exception will be thrown if there are 0, or more than 1 of the item. =head2 ATTRIBUTES =over 4 =item $hashref = $event->facet_data This will return the facet data hashref, which is all Test2 cares about for any given event. =item $class = $event->result_class This is normally L<Test2::API::InterceptResult>. This is set at construction so that subtest results can be turned into instances of it on demand. =back =head2 DUPLICATION =over 4 =item $copy = $event->clone Create a deep copy of the event. Modifying either event will not effect the other. =back =head2 CONDENSED MULTI-FACET DATA =over 4 =item $bool = $event->causes_failure =item $bool = $event->causes_fail These are both aliases of the same functionality. This will always return either a true value, or a false value. This never returns a list. This method may be relatively slow (still super fast) because it determines pass or fail by creating an instance of L<Test2::Hub> and asking it to process the event, and then asks the hub for its pass/fail state. This is slower than bulding in logic to do the check, but it is more reliable as it will always tell you what the hub thinks, so the logic will never be out of date relative to the Test2 logic that actually cares. =item STRING_OR_EMPTY_LIST = $event->brief Not all events have a brief, some events are not rendered by the formatter, others have no "brief" data worth seeing. When this is the case an empty list is returned. This is done intentionally so it can be used in a map operation without having C<undef> being included in the result. When a brief can be generated it is always a single 1-line string, and is returned as-is, not in a list. Possible briefs: # From control facets "BAILED OUT" "BAILED OUT: $why" # From error facets "ERROR" "ERROR: $message" "ERROR: $partial_message [...]" "ERRORS: $first_error_message [...]" # From assert facets "PASS" "FAIL" "PASS with amnesty" "FAIL with amnesty" # From plan facets "PLAN $count" "NO PLAN" "SKIP ALL" "SKIP ALL: $why" Note that only the first applicable brief is returned. This is essnetially a poor-mans TAP that only includes facets that could (but not necessarily do) cause a failure. =item $hashref = $event->flatten =item $hashref = $event->flatten(include_subevents => 1) This ALWAYS returns a hashref. This puts all the most useful data for the most interesting facets into a single hashref for easy validation. If there are no meaningful facets this will return an empty hashref. If given the 'include_subevents' parameter it will also include subtest data: Here is a list of EVERY possible field. If a field is not applicable it will not be present. =over 4 =item always present causes_failure => 1, # Always present =item Present if the event has a trace facet trace_line => 42, trace_file => 'Foo/Bar.pm', trace_details => 'Extra trace details', # usually not present =item If an assertion is present pass => 0, name => "1 + 1 = 2, so math works", =item If a plan is present: plan => $count_or_SKIP_ALL_or_NO_PLAN, =item If amnesty facets are present You get an array for each type that is present. todo => [ # Yes you could be under multiple todos, this will list them all. "I will fix this later", "I promise to fix these", ], skip => ["This will format the main drive, do not run"], ... => ["Other amnesty"] =item If Info (note/diag) facets are present You get an arrayref for any that are present, the key is not defined if they are not present. diag => [ "Test failed at Foo/Bar.pm line 42", "You forgot to tie your boots", ], note => ["Your boots are red"], ... => ["Other info"], =item If error facets are present Always an arrayref error => [ "non fatal error (does not cause test failure, just an FYI", "FATAL: This is a fatal error (causes failure)", ], # Errors can have alternative tags, but in practice are always 'error', # listing this for completeness. ... => [ ... ] =item Present if the event is a subtest subtest => { count => 2, # Number of assertions made failed => 1, # Number of test failures seen is_passing => 0, # Boolean, true if the test would be passing # after the events are processed. plan => 2, # Plan, either a number, undef, 'SKIP', or 'NO PLAN' follows_plan => 1, # True if there is a plan and it was followed. # False if the plan and assertions did not # match, undef if no plan was present in the # event list. bailed_out => "foo", # if there was a bail-out in the # events in this will be a string explaining # why there was a bailout, if no reason was # given this will simply be set to true (1). skip_reason => "foo", # If there was a skip_all this will give the # reason. }, if C<< (include_subtest => 1) >> was provided as a parameter then the following will be included. This is the result of turning all subtest child events into an L<Test2::API::InterceptResult> instance and calling the C<flatten> method on it. subevents => Test2::API::InterceptResult->new(@child_events)->flatten(...), =item If a bail-out is being requested If no reason was given this will be set to 1. bailed_out => "reason", =back =item $hashref = $event->summary() This returns a limited summary. See C<flatten()>, which is usually a better option. { brief => $event->brief || '', causes_failure => $event->causes_failure, trace_line => $event->trace_line, trace_file => $event->trace_file, trace_tool => $event->trace_subname, trace_details => $event->trace_details, facets => [ sort keys(%{$event->{+FACET_DATA}}) ], } =back =head2 DIRECT ARBITRARY FACET ACCESS =over 4 =item @list_of_facets = $event->facet($name) This always returns a list of 0 or more items. This fetches the facet instances from the event. For facets like 'assert' this will always return 0 or 1 item. For events like 'info' (diags, notes) this will return 0 or more instances, once for each instance of the facet. These will be blessed into the proper L<Test2::EventFacet> subclass. If no subclass can be found it will be blessed as an L<Test2::API::InterceptResult::Facet> generic facet class. =item $undef_or_facet = $event->the_facet($name) If you know you will have exactly 1 instance of a facet you can call this. If you are correct and there is exactly one instance of the facet it will always return the hashref. If there are 0 instances of the facet this will reutrn undef, not an empty list. If there are more than 1 instance this will throw an exception because your assumption was incorrect. =back =head2 TRACE FACET =over 4 =item @list_of_facets = $event->trace TODO =item $undef_or_hashref = $event->the_trace This returns the trace hashref, or undef if it is not present. =item $undef_or_arrayref = $event->frame If a trace is present, and has a caller frame, this will be an arrayref: [$package, $file, $line, $subname] If the trace is not present, or has no caller frame this will return undef. =item $undef_or_string = $event->trace_details This is usually undef, but occasionally has a string that overrides the file/line number debugging a trace usually provides on test failure. =item $undef_or_string = $event->trace_package Same as C<(caller())[0]>, the first element of the trace frame. Will be undef if not present. =item $undef_or_string = $event->trace_file Same as C<(caller())[1]>, the second element of the trace frame. Will be undef if not present. =item $undef_or_integer = $event->trace_line Same as C<(caller())[2]>, the third element of the trace frame. Will be undef if not present. =item $undef_or_string = $event->trace_subname =item $undef_or_string = $event->trace_tool Aliases for the same thing Same as C<(caller($level))[4]>, the fourth element of the trace frame. Will be undef if not present. =item $undef_or_string = $event->trace_signature A string that is a unique signature for the trace. If a single context generates multiple events they will all have the same signature. This can be used to tie assertions and diagnostics sent as seperate events together after the fact. =back =head2 ASSERT FACET =over 4 =item $bool = $event->has_assert Returns true if the event has an assert facet, false if it does not. =item $undef_or_hashref = $event->the_assert Returns the assert facet if present, undef if it is not. =item @list_of_facets = $event->assert TODO =item EMPTY_LIST_OR_STRING = $event->assert_brief Returns a string giving a brief of the assertion if an assertion is present. Returns an empty list if no assertion is present. =back =head2 SUBTESTS (PARENT FACET) =over 4 =item $bool = $event->has_subtest True if a subetest is present in this event. =item $undef_or_hashref = $event->the_subtest Get the one subtest if present, otherwise undef. =item @list_of_facets = $event->subtest TODO =item EMPTY_LIST_OR_OBJECT = $event->subtest_result Returns an empty list if there is no subtest. Get an instance of L<Test2::API::InterceptResult> representing the subtest. =back =head2 CONTROL FACET (BAILOUT, ENCODING) =over 4 =item $bool = $event->has_bailout True if there was a bailout =item $undef_hashref = $event->the_bailout Return the control facet if it requested a bailout. =item EMPTY_LIST_OR_HASHREF = $event->bailout Get a list of 0 or 1 hashrefs. The hashref will be the control facet if a bail-out was requested. =item EMPTY_LIST_OR_STRING = $event->bailout_brief Get the brief of the balout if present. =item EMPTY_LIST_OR_STRING = $event->bailout_reason Get the reason for the bailout, an empty string if no reason was provided, or an empty list if there was no bailout. =back =head2 PLAN FACET TODO =over 4 =item $bool = $event->has_plan =item $undef_or_hashref = $event->the_plan =item @list_if_hashrefs = $event->plan =item EMPTY_LIST_OR_STRING $event->plan_brief =back =head2 AMNESTY FACET (TODO AND SKIP) TODO =over 4 =item $event->has_amnesty =item $event->the_amnesty =item $event->amnesty =item $event->amnesty_reasons =item $event->has_todos =item $event->todos =item $event->todo_reasons =item $event->has_skips =item $event->skips =item $event->skip_reasons =item $event->has_other_amnesty =item $event->other_amnesty =item $event->other_amnesty_reasons =back =head2 ERROR FACET (CAPTURED EXCEPTIONS) TODO =over 4 =item $event->has_errors =item $event->the_errors =item $event->errors =item $event->error_messages =item $event->error_brief =back =head2 INFO FACET (DIAG, NOTE) TODO =over 4 =item $event->has_info =item $event->the_info =item $event->info =item $event->info_messages =item $event->has_diags =item $event->diags =item $event->diag_messages =item $event->has_notes =item $event->notes =item $event->note_messages =item $event->has_other_info =item $event->other_info =item $event->other_info_messages =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/API/InterceptResult/Facet.pm 0000444 00000000574 14711217517 0013733 0 ustar 00 package Test2::API::InterceptResult::Facet; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::EventFacet; our @ISA = ('Test2::EventFacet'); } our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my $name = $AUTOLOAD; $name =~ s/^.*:://g; return undef unless exists $self->{$name}; return $self->{$name}; } sub DESTROY {} 1; perl5/Test2/IPC/Driver.pm 0000444 00000014572 14711217517 0011015 0 ustar 00 package Test2::IPC::Driver; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/confess/; use Test2::Util::HashBase qw{no_fatal no_bail}; use Test2::API qw/test2_ipc_add_driver/; my %ADDED; sub import { my $class = shift; return if $class eq __PACKAGE__; return if $ADDED{$class}++; test2_ipc_add_driver($class); } sub pending { -1 } sub set_pending { -1 } for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) { no strict 'refs'; *$meth = sub { my $thing = shift; confess "'$thing' did not define the required method '$meth'." }; } # Print the error and call exit. We are not using 'die' cause this is a # catastrophic error that should never be caught. If we get here it # means some serious shit has happened in a child process, the only way # to inform the parent may be to exit false. sub abort { my $self = shift; chomp(my ($msg) = @_); $self->driver_abort($msg) if $self->can('driver_abort'); print STDERR "IPC Fatal Error: $msg\n"; print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail; CORE::exit(255) unless $self->no_fatal; } sub abort_trace { my $self = shift; my ($msg) = @_; # Older versions of Carp do not export longmess() function, so it needs to be called with package name $self->abort(Carp::longmess($msg)); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver - Base class for Test2 IPC drivers. =head1 SYNOPSIS package Test2::IPC::Driver::MyDriver; use base 'Test2::IPC::Driver'; ... =head1 METHODS =over 4 =item $self->abort($msg) If an IPC encounters a fatal error it should use this. This will print the message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will forcefully exit 255. IPC errors may occur in threads or processes other than the main one, this method provides the best chance of the harness noticing the error. =item $self->abort_trace($msg) This is the same as C<< $ipc->abort($msg) >> except that it uses C<Carp::longmess> to add a stack trace to the message. =back =head1 LOADING DRIVERS Test2::IPC::Driver has an C<import()> method. All drivers inherit this import method. This import method registers the driver. In most cases you just need to load the desired IPC driver to make it work. You should load this driver as early as possible. A warning will be issued if you load it too late for it to be effective. use Test2::IPC::Driver::MyDriver; ... =head1 WRITING DRIVERS package Test2::IPC::Driver::MyDriver; use strict; use warnings; use base 'Test2::IPC::Driver'; sub is_viable { return 0 if $^O eq 'win32'; # Will not work on windows. return 1; } sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } sub send { my $self = shift; my ($hid, $e, $global) = @_; ... # Send the event to the proper hub. # This may notify other procs/threads that there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } 1; =head2 METHODS SUBCLASSES MUST IMPLEMENT =over 4 =item $ipc->is_viable This should return true if the driver works in the current environment. This should return false if it does not. This is a CLASS method. =item $ipc->add_hub($hid) This is used to alert the driver that a new hub is expecting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it. sub add_hub { my $self = shift; my ($hid) = @_; ... # Make it possible to contact the hub } =item $ipc->drop_hub($hid) This is used to alert the driver that a hub is no longer accepting events. The driver should keep track of the process and thread ids, the hub should only be dropped by the proc+thread that started it (This is the drivers responsibility to enforce). sub drop_hub { my $self = shift; my ($hid) = @_; ... # Nothing should try to reach the hub anymore. } =item $ipc->send($hid, $event); =item $ipc->send($hid, $event, $global); Used to send events from the current process/thread to the specified hub in its process+thread. sub send { my $self = shift; my ($hid, $e) = @_; ... # Send the event to the proper hub. # This may notify other procs/threads that there is a pending event. Test2::API::test2_ipc_set_pending($uniq_val); } If C<$global> is true then the driver should send the event to all hubs in all processes and threads. =item @events = $ipc->cull($hid) Used to collect events that have been sent to the specified hub. sub cull { my $self = shift; my ($hid) = @_; my @events = ...; # Here is where you get the events for the hub return @events; } =item $ipc->waiting() This is called in the parent process when it is complete and waiting for all child processes and threads to complete. sub waiting { my $self = shift; ... # Notify all listening procs and threads that the main ... # process/thread is waiting for them to finish. } =back =head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE =over 4 =item $ipc->driver_abort($msg) This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your chance to cleanup when an abort happens. You cannot prevent the abort, but you can gracefully except it. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/IPC/Driver/Files.pm 0000444 00000032374 14711217517 0012057 0 ustar 00 package Test2::IPC::Driver::Files; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals}; use Scalar::Util qw/blessed/; use File::Temp(); use Storable(); use File::Spec(); use POSIX(); use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/; use Test2::API qw/test2_ipc_set_pending/; sub is_viable { 1 } sub init { my $self = shift; my $tmpdir = File::Temp::tempdir( $ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX", CLEANUP => 0, TMPDIR => 1, ); $self->abort_trace("Could not get a temp dir") unless $tmpdir; $self->{+TEMPDIR} = File::Spec->canonpath($tmpdir); print STDERR "\nIPC Temp Dir: $tmpdir\n\n" if $ENV{T2_KEEP_TEMPDIR}; $self->{+EVENT_IDS} = {}; $self->{+READ_IDS} = {}; $self->{+TIMEOUTS} = {}; $self->{+TID} = get_tid(); $self->{+PID} = $$; $self->{+GLOBALS} = {}; return $self; } sub hub_file { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid); } sub event_file { my $self = shift; my ($hid, $e) = @_; my $tempdir = $self->{+TEMPDIR}; my $type = blessed($e) or $self->abort("'$e' is not a blessed object!"); $self->abort("'$e' is not an event object!") unless $type->isa('Test2::Event'); my $tid = get_tid(); my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1; my @type = split '::', $type; my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type); return File::Spec->catfile($tempdir, $name); } sub add_hub { my $self = shift; my ($hid) = @_; my $hfile = $self->hub_file($hid); $self->abort_trace("File for hub '$hid' already exists") if -e $hfile; open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!"); print $fh "$$\n" . get_tid() . "\n"; close($fh); } sub drop_hub { my $self = shift; my ($hid) = @_; my $tdir = $self->{+TEMPDIR}; my $hfile = $self->hub_file($hid); $self->abort_trace("File for hub '$hid' does not exist") unless -e $hfile; open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!"); my ($pid, $tid) = <$fh>; close($fh); $self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$") unless $pid == $$; $self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid()) unless get_tid() == $tid; if ($ENV{T2_KEEP_TEMPDIR}) { my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete")); $self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok } else { my ($ok, $err) = do_unlink($hfile); $self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok } opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); my %bad; for my $file (readdir($dh)) { next if $file =~ m{\.complete$}; next unless $file =~ m{^$hid}; eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file"; } closedir($dh); return unless keys %bad; my $data; my $ok = eval { require JSON::PP; local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } }; my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed; $data = $json->encode(\%bad); 1; }; $ok ||= eval { require Data::Dumper; local $Data::Dumper::Sortkeys = 1; $data = Data::Dumper::Dumper(\%bad); 1; }; $data = "Could not dump data... sorry." unless defined $data; $self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n"); } sub send { my $self = shift; my ($hid, $e, $global) = @_; my $tempdir = $self->{+TEMPDIR}; my $hfile = $self->hub_file($hid); my $dest = $global ? 'GLOBAL' : $hid; $self->abort(<<" EOT") unless $global || -f $hfile; hub '$hid' is not available, failed to send event! There was an attempt to send an event to a hub in a parent process or thread, but that hub appears to be gone. This can happen if you fork, or start a new thread from inside subtest, and the parent finishes the subtest before the child returns. This can also happen if the parent process is done testing before the child finishes. Test2 normally waits automatically in the root process, but will not do so if Test::Builder is loaded for legacy reasons. EOT my $file = $self->event_file($dest, $e); my $ready = File::Spec->canonpath("$file.ready"); if ($global) { my $name = $ready; $name =~ s{^.*(GLOBAL)}{GLOBAL}; $self->{+GLOBALS}->{$hid}->{$name}++; } # Write and rename the file. my ($ren_ok, $ren_err); my ($ok, $err) = try_sig_mask(sub { Storable::store($e, $file); ($ren_ok, $ren_err) = do_rename("$file", $ready); }); if ($ok) { $self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok; test2_ipc_set_pending($file); } else { my $src_file = __FILE__; $err =~ s{ at \Q$src_file\E.*$}{}; chomp($err); my $tid = get_tid(); my $trace = $e->trace->debug; my $type = blessed($e); $self->abort(<<" EOT"); ******************************************************************************* There was an error writing an event: Destination: $dest Origin PID: $$ Origin TID: $tid Event Type: $type Event Trace: $trace File Name: $file Ready Name: $ready Error: $err ******************************************************************************* EOT } return 1; } sub driver_abort { my $self = shift; my ($msg) = @_; local ($@, $!, $?, $^E); eval { my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); open(my $fh, '>>', $abort) or die "Could not open abort file: $!"; print $fh $msg, "\n"; close($fh) or die "Could not close abort file: $!"; 1; } or warn $@; } sub cull { my $self = shift; my ($hid) = @_; my $tempdir = $self->{+TEMPDIR}; opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!"); my $read = $self->{+READ_IDS}; my $timeouts = $self->{+TIMEOUTS}; my @out; for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) { unless ($info->{global}) { my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1; $timeouts->{$info->{file}} ||= time; if ($next != $info->{eid}) { # Wait up to N seconds for missing events next unless 5 < time - $timeouts->{$info->{file}}; $self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}."); } $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1; } my $full = $info->{full_path}; my $obj = $self->read_event_file($full); push @out => $obj; # Do not remove global events next if $info->{global}; if ($ENV{T2_KEEP_TEMPDIR}) { my $complete = File::Spec->canonpath("$full.complete"); my ($ok, $err) = do_rename($full, $complete); $self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok; } else { my ($ok, $err) = do_unlink("$full"); $self->abort("Could not unlink IPC file '$full': $err") unless $ok; } } closedir($dh); return @out; } sub parse_event_filename { my $self = shift; my ($file) = @_; # The || is to force 0 in false my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, ""); my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, ""); my @parts = split ipc_separator, $file; my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4)); my ($pid, $tid, $eid) = splice(@parts, 0, 3); my $type = join '::' => @parts; return { file => $file, ready => $ready, complete => $complete, global => $global, type => $type, hid => $hid, pid => $pid, tid => $tid, eid => $eid, }; } sub should_read_event { my $self = shift; my ($hid, $file) = @_; return if substr($file, 0, 1) eq '.'; return if substr($file, 0, 3) eq 'HUB'; CORE::exit(255) if $file eq 'ABORT'; my $parsed = $self->parse_event_filename($file); return if $parsed->{complete}; return unless $parsed->{ready}; return unless $parsed->{global} || $parsed->{hid} eq $hid; return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++; # Untaint the path. my $full = File::Spec->catfile($self->{+TEMPDIR}, $file); ($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT}; $parsed->{full_path} = $full; return $parsed; } sub cmp_events { # Globals first return -1 if $a->{global} && !$b->{global}; return 1 if $b->{global} && !$a->{global}; return $a->{pid} <=> $b->{pid} || $a->{tid} <=> $b->{tid} || $a->{eid} <=> $b->{eid}; } sub read_event_file { my $self = shift; my ($file) = @_; my $obj = Storable::retrieve($file); $self->abort("Got an unblessed object: '$obj'") unless blessed($obj); unless ($obj->isa('Test2::Event')) { my $pkg = blessed($obj); my $mod_file = pkg_to_file($pkg); my ($ok, $err) = try { require $mod_file }; $self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err") unless $ok; $self->abort("'$obj' is not a 'Test2::Event' object") unless $obj->isa('Test2::Event'); } return $obj; } sub waiting { my $self = shift; require Test2::Event::Waiting; $self->send( GLOBAL => Test2::Event::Waiting->new( trace => Test2::EventFacet::Trace->new(frame => [caller()]), ), 'GLOBAL' ); return; } sub DESTROY { my $self = shift; return unless defined $self->pid; return unless defined $self->tid; return unless $$ == $self->pid; return unless get_tid() == $self->tid; my $tempdir = $self->{+TEMPDIR}; my $aborted = 0; my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); if (-e $abort_file) { $aborted = 1; my ($ok, $err) = do_unlink($abort_file); warn $err unless $ok; } opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)"); while(my $file = readdir($dh)) { next if $file =~ m/^\.+$/; next if $file =~ m/\.complete$/; my $full = File::Spec->catfile($tempdir, $file); my $sep = ipc_separator; if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) { $full =~ m/^(.*)$/; $full = $1; # Untaint it next if $ENV{T2_KEEP_TEMPDIR}; my ($ok, $err) = do_unlink($full); $self->abort("Could not unlink IPC file '$full': $err") unless $ok; next; } $self->abort("Leftover files in the directory ($full)!\n"); } closedir($dh); if ($ENV{T2_KEEP_TEMPDIR}) { print STDERR "# Not removing temp dir: $tempdir\n"; return; } my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT"); unlink($abort) if -e $abort; rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::IPC::Driver::Files - Temp dir + Files concurrency model. =head1 DESCRIPTION This is the default, and fallback concurrency model for L<Test2>. This sends events between processes and threads using serialized files in a temporary directory. This is not particularly fast, but it works everywhere. =head1 SYNOPSIS use Test2::IPC::Driver::Files; # IPC is now enabled =head1 ENVIRONMENT VARIABLES =over 4 =item T2_KEEP_TEMPDIR=0 When true, the tempdir used by the IPC driver will not be deleted when the test is done. =item T2_TEMPDIR_TEMPLATE='test2-XXXXXX' This can be used to set the template for the IPC temp dir. The template should follow template specifications from L<File::Temp>. =back =head1 SEE ALSO See L<Test2::IPC::Driver> for methods. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/EventFacet.pm 0000444 00000002726 14711217520 0011163 0 ustar 00 package Test2::EventFacet; use strict; use warnings; our $VERSION = '1.302186'; use Test2::Util::HashBase qw/-details/; use Carp qw/croak/; my $SUBLEN = length(__PACKAGE__ . '::'); sub facet_key { my $key = ref($_[0]) || $_[0]; substr($key, 0, $SUBLEN, ''); return lc($key); } sub is_list { 0 } sub clone { my $self = shift; my $type = ref($self); return bless {%$self, @_}, $type; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::EventFacet - Base class for all event facets. =head1 DESCRIPTION Base class for all event facets. =head1 METHODS =over 4 =item $key = $facet_class->facet_key() This will return the key for the facet in the facet data hash. =item $bool = $facet_class->is_list() This will return true if the facet should be in a list instead of a single item. =item $clone = $facet->clone() =item $clone = $facet->clone(%replace) This will make a shallow clone of the facet. You may specify fields to override as arguments. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Tools/Tiny.pm 0000444 00000021665 14711217520 0011165 0 ustar 00 package Test2::Tools::Tiny; use strict; use warnings; BEGIN { if ($] lt "5.008") { require Test::Builder::IO::Scalar; } } use Scalar::Util qw/blessed/; use Test2::Util qw/try/; use Test2::API qw/context run_subtest test2_stack/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); our $VERSION = '1.302186'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing warnings exception tests capture }; sub ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub is($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" eq "$want"; } elsif (defined($got) xor defined($want)) { $bool = 0; } else { # Both are undef $bool = 1; } return $ctx->pass_and_release($name) if $bool; $got = '*NOT DEFINED*' unless defined $got; $want = '*NOT DEFINED*' unless defined $want; unshift @diag => ( "GOT: $got", "EXPECTED: $want", ); return $ctx->fail_and_release($name, @diag); } sub isnt($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($got) && defined($want)) { $bool = "$got" ne "$want"; } elsif (defined($got) xor defined($want)) { $bool = 1; } else { # Both are undef $bool = 0; } return $ctx->pass_and_release($name) if $bool; unshift @diag => "Strings are the same (they should not be)" unless $bool; return $ctx->fail_and_release($name, @diag); } sub like($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" =~ $pattern; unshift @diag => ( "Value: $thing", "Does not match: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub unlike($$;$@) { my ($thing, $pattern, $name, @diag) = @_; my $ctx = context(); my $bool; if (defined($thing)) { $bool = "$thing" !~ $pattern; unshift @diag => ( "Unexpected pattern match (it should not match)", "Value: $thing", "Matches: $pattern" ) unless $bool; } else { $bool = 0; unshift @diag => "Got an undefined value."; } return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } sub is_deeply($$;$@) { my ($got, $want, $name, @diag) = @_; my $ctx = context(); no warnings 'once'; require Data::Dumper; # Otherwise numbers might be unquoted local $Data::Dumper::Useperl = 1; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Deparse = 1; local $Data::Dumper::Freezer = 'XXX'; local *UNIVERSAL::XXX = sub { my ($thing) = @_; if (ref($thing)) { $thing = {%$thing} if "$thing" =~ m/=HASH/; $thing = [@$thing] if "$thing" =~ m/=ARRAY/; $thing = \"$$thing" if "$thing" =~ m/=SCALAR/; } $_[0] = $thing; }; my $g = Data::Dumper::Dumper($got); my $w = Data::Dumper::Dumper($want); my $bool = $g eq $w; return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, $g, $w, @diag); } sub diag { my $ctx = context(); $ctx->diag(join '', @_); $ctx->release; } sub note { my $ctx = context(); $ctx->note(join '', @_); $ctx->release; } sub skip_all { my ($reason) = @_; my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release if $ctx; } sub todo { my ($reason, $sub) = @_; my $ctx = context(); # This code is mostly copied from Test2::Todo in the Test2-Suite # distribution. my $hub = test2_stack->top; my $filter = $hub->pre_filter( sub { my ($active_hub, $event) = @_; if ($active_hub == $hub) { $event->set_todo($reason) if $event->can('set_todo'); $event->add_amnesty({tag => 'TODO', details => $reason}); } else { $event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1}); } return $event; }, inherit => 1, todo => $reason, ); $sub->(); $hub->pre_unfilter($filter); $ctx->release if $ctx; } sub plan { my ($max) = @_; my $ctx = context(); $ctx->plan($max); $ctx->release; } sub done_testing { my $ctx = context(); $ctx->done_testing; $ctx->release; } sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } sub exception(&) { my $code = shift; local ($@, $!, $SIG{__DIE__}); my $ok = eval { $code->(); 1 }; my $error = $@ || 'SQUASHED ERROR'; return $ok ? undef : $error; } sub tests { my ($name, $code) = @_; my $ctx = context(); my $be = caller->can('before_each'); $be->($name) if $be; my $bool = run_subtest($name, $code, 1); $ctx->release; return $bool; } sub capture(&) { my $code = shift; my ($err, $out) = ("", ""); my $handles = test2_stack->top->format->handles; my ($ok, $e); { my ($out_fh, $err_fh); ($ok, $e) = try { # Scalar refs as filehandles were added in 5.8. if ($] ge "5.008") { open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!"; } # Emulate scalar ref filehandles with a tie. else { $out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT"; $err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR"; } test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]); $code->(); }; } test2_stack->top->format->set_handles($handles); die $e unless $ok; $err =~ s/ $/_/mg; $out =~ s/ $/_/mg; return { STDOUT => $out, STDERR => $err, }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use L<Test2::Suite>. =head1 DESCRIPTION You should really look at L<Test2::Suite>. This package is some very basic essential tools implemented using L<Test2>. This exists only so that L<Test2> and other tools required by L<Test2::Suite> can be tested. This is the package L<Test2> uses to test itself. =head1 USE Test2::Suite INSTEAD Use L<Test2::Suite> if at all possible. =head1 EXPORTS =over 4 =item ok($bool, $name) =item ok($bool, $name, @diag) Run a simple assertion. =item is($got, $want, $name) =item is($got, $want, $name, @diag) Assert that 2 strings are the same. =item isnt($got, $do_not_want, $name) =item isnt($got, $do_not_want, $name, @diag) Assert that 2 strings are not the same. =item like($got, $regex, $name) =item like($got, $regex, $name, @diag) Check that the input string matches the regex. =item unlike($got, $regex, $name) =item unlike($got, $regex, $name, @diag) Check that the input string does not match the regex. =item is_deeply($got, $want, $name) =item is_deeply($got, $want, $name, @diag) Check 2 data structures. Please note that this is a I<DUMB> implementation that compares the output of L<Data::Dumper> against both structures. =item diag($msg) Issue a diagnostics message to STDERR. =item note($msg) Issue a diagnostics message to STDOUT. =item skip_all($reason) Skip all tests. =item todo $reason => sub { ... } Run a block in TODO mode. =item plan($count) Set the plan. =item done_testing() Set the plan to the current test count. =item $warnings = warnings { ... } Capture an arrayref of warnings from the block. =item $exception = exception { ... } Capture an exception. =item tests $name => sub { ... } Run a subtest. =item $output = capture { ... } Capture STDOUT and STDERR output. Result looks like this: { STDOUT => "...", STDERR => "...", } =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Hub.pm 0000444 00000054454 14711217520 0007662 0 ustar 00 package Test2::Hub; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/carp croak confess/; use Test2::Util qw/get_tid gen_uid/; use Scalar::Util qw/weaken/; use List::Util qw/first/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util::HashBase qw{ pid tid hid ipc nested buffered no_ending _filters _pre_filters _listeners _follow_ups _formatter _context_acquire _context_init _context_release uuid active count failed ended bailed_out _passing _plan skip_reason }; my $UUID_VIA; sub init { my $self = shift; $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = gen_uid(); $UUID_VIA ||= Test2::API::_add_uuid_via_ref(); $self->{+UUID} = ${$UUID_VIA}->('hub') if $$UUID_VIA; $self->{+NESTED} = 0 unless defined $self->{+NESTED}; $self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED}; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; if (my $formatter = delete $self->{formatter}) { $self->format($formatter); } if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub is_subtest { 0 } sub _tb_reset { my $self = shift; # Nothing to do return if $self->{+PID} == $$ && $self->{+TID} == get_tid(); $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+HID} = gen_uid(); if (my $ipc = $self->{+IPC}) { $ipc->add_hub($self->{+HID}); } } sub reset_state { my $self = shift; $self->{+COUNT} = 0; $self->{+FAILED} = 0; $self->{+_PASSING} = 1; delete $self->{+_PLAN}; delete $self->{+ENDED}; delete $self->{+BAILED_OUT}; delete $self->{+SKIP_REASON}; } sub inherit { my $self = shift; my ($from, %params) = @_; $self->{+NESTED} ||= 0; $self->{+_FORMATTER} = $from->{+_FORMATTER} unless $self->{+_FORMATTER} || exists($params{formatter}); if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { my $ipc = $from->{+IPC}; $self->{+IPC} = $ipc; $ipc->add_hub($self->{+HID}); } if (my $ls = $from->{+_LISTENERS}) { push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls; } if (my $pfs = $from->{+_PRE_FILTERS}) { push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs; } if (my $fs = $from->{+_FILTERS}) { push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs; } } sub format { my $self = shift; my $old = $self->{+_FORMATTER}; ($self->{+_FORMATTER}) = @_ if @_; return $old; } sub is_local { my $self = shift; return $$ == $self->{+PID} && get_tid() == $self->{+TID}; } sub listen { my $self = shift; my ($sub, %params) = @_; carp "Useless addition of a listener in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "listen only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_LISTENERS}} => { %params, code => $sub }; $sub; # Intentional return. } sub unlisten { my $self = shift; carp "Useless removal of a listener in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; my %subs = map {$_ => $_} @_; @{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}}; } sub filter { my $self = shift; my ($sub, %params) = @_; carp "Useless addition of a filter in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "filter only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_FILTERS}} => { %params, code => $sub }; $sub; # Intentional Return } sub unfilter { my $self = shift; carp "Useless removal of a filter in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; my %subs = map {$_ => $_} @_; @{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}}; } sub pre_filter { my $self = shift; my ($sub, %params) = @_; croak "pre_filter only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub }; $sub; # Intentional Return } sub pre_unfilter { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}}; } sub follow_up { my $self = shift; my ($sub) = @_; carp "Useless addition of a follow-up in a child process or thread!" if $$ != $self->{+PID} || get_tid() != $self->{+TID}; croak "follow_up only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_FOLLOW_UPS}} => $sub; } *add_context_aquire = \&add_context_acquire; sub add_context_acquire { my $self = shift; my ($sub) = @_; croak "add_context_acquire only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_ACQUIRE}} => $sub; $sub; # Intentional return. } *remove_context_aquire = \&remove_context_acquire; sub remove_context_acquire { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}}; } sub add_context_init { my $self = shift; my ($sub) = @_; croak "add_context_init only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_INIT}} => $sub; $sub; # Intentional return. } sub remove_context_init { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}}; } sub add_context_release { my $self = shift; my ($sub) = @_; croak "add_context_release only takes coderefs for arguments, got '$sub'" unless ref $sub && ref $sub eq 'CODE'; push @{$self->{+_CONTEXT_RELEASE}} => $sub; $sub; # Intentional return. } sub remove_context_release { my $self = shift; my %subs = map {$_ => $_} @_; @{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}}; } sub send { my $self = shift; my ($e) = @_; $e->eid; $e->add_hub( { details => ref($self), buffered => $self->{+BUFFERED}, hid => $self->{+HID}, nested => $self->{+NESTED}, pid => $self->{+PID}, tid => $self->{+TID}, uuid => $self->{+UUID}, ipc => $self->{+IPC} ? 1 : 0, } ); $e->set_uuid(${$UUID_VIA}->('event')) if $$UUID_VIA; if ($self->{+_PRE_FILTERS}) { for (@{$self->{+_PRE_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } my $ipc = $self->{+IPC} || return $self->process($e); if($e->global) { $ipc->send($self->{+HID}, $e, 'GLOBAL'); return $self->process($e); } return $ipc->send($self->{+HID}, $e) if $$ != $self->{+PID} || get_tid() != $self->{+TID}; $self->process($e); } sub process { my $self = shift; my ($e) = @_; if ($self->{+_FILTERS}) { for (@{$self->{+_FILTERS}}) { $e = $_->{code}->($self, $e); return unless $e; } } # Optimize the most common case my $type = ref($e); if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) { my $count = ++($self->{+COUNT}); $self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}}; } return $e; } my $f = $e->facet_data; my $fail = 0; $fail = 1 if $f->{assert} && !$f->{assert}->{pass}; $fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}}; $fail = 0 if $f->{amnesty}; $self->{+COUNT}++ if $f->{assert}; $self->{+FAILED}++ if $fail && $f->{assert}; $self->{+_PASSING} = 0 if $fail; my $code = $f->{control} ? $f->{control}->{terminate} : undef; my $count = $self->{+COUNT}; if (my $plan = $f->{plan}) { if ($plan->{skip}) { $self->plan('SKIP'); $self->set_skip_reason($plan->{details} || 1); $code ||= 0; } elsif ($plan->{none}) { $self->plan('NO PLAN'); } else { $self->plan($plan->{count}); } } $e->callback($self) if $f->{control} && $f->{control}->{has_callback}; $self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER}; if ($self->{+_LISTENERS}) { $_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}}; } if ($f->{control} && $f->{control}->{halt}) { $code ||= 255; $self->set_bailed_out($e); } if (defined $code) { $self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER}; $self->terminate($code, $e, $f); } return $e; } sub terminate { my $self = shift; my ($code) = @_; exit($code); } sub cull { my $self = shift; my $ipc = $self->{+IPC} || return; return if $self->{+PID} != $$ || $self->{+TID} != get_tid(); # No need to do IPC checks on culled events $self->process($_) for $ipc->cull($self->{+HID}); } sub finalize { my $self = shift; my ($trace, $do_plan) = @_; $self->cull(); my $plan = $self->{+_PLAN}; my $count = $self->{+COUNT}; my $failed = $self->{+FAILED}; my $active = $self->{+ACTIVE}; # return if NOTHING was done. unless ($active || $do_plan || defined($plan) || $count || $failed) { $self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER}; return; } unless ($self->{+ENDED}) { if ($self->{+_FOLLOW_UPS}) { $_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}}; } # These need to be refreshed now $plan = $self->{+_PLAN}; $count = $self->{+COUNT}; $failed = $self->{+FAILED}; if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) { $self->send( Test2::Event::Plan->new( trace => $trace, max => $count, ) ); } $plan = $self->{+_PLAN}; } my $frame = $trace->frame; if($self->{+ENDED}) { my (undef, $ffile, $fline) = @{$self->{+ENDED}}; my (undef, $sfile, $sline) = @$frame; die <<" EOT" Test already ended! First End: $ffile line $fline Second End: $sfile line $sline EOT } $self->{+ENDED} = $frame; my $pass = $self->is_passing(); # Generate the final boolean. $self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER}; return $pass; } sub is_passing { my $self = shift; ($self->{+_PASSING}) = @_ if @_; # If we already failed just return 0. my $pass = $self->{+_PASSING} or return 0; return $self->{+_PASSING} = 0 if $self->{+FAILED}; my $count = $self->{+COUNT}; my $ended = $self->{+ENDED}; my $plan = $self->{+_PLAN}; return $pass if !$count && $plan && $plan =~ m/^SKIP$/; return $self->{+_PASSING} = 0 if $ended && (!$count || !$plan); return $pass unless $plan && $plan =~ m/^\d+$/; if ($ended) { return $self->{+_PASSING} = 0 if $count != $plan; } else { return $self->{+_PASSING} = 0 if $count > $plan; } return $pass; } sub plan { my $self = shift; return $self->{+_PLAN} unless @_; my ($plan) = @_; confess "You cannot unset the plan" unless defined $plan; confess "You cannot change the plan" if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/; confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'" unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/; $self->{+_PLAN} = $plan; } sub check_plan { my $self = shift; return undef unless $self->{+ENDED}; my $plan = $self->{+_PLAN} || return undef; return 1 if $plan !~ m/^\d+$/; return 1 if $plan == $self->{+COUNT}; return 0; } sub DESTROY { my $self = shift; my $ipc = $self->{+IPC} || return; return unless $$ == $self->{+PID}; return unless get_tid() == $self->{+TID}; $ipc->drop_hub($self->{+HID}); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Hub - The conduit through which all events flow. =head1 SYNOPSIS use Test2::Hub; my $hub = Test2::Hub->new(); $hub->send(...); =head1 DESCRIPTION The hub is the place where all events get processed and handed off to the formatter. The hub also tracks test state, and provides several hooks into the event pipeline. =head1 COMMON TASKS =head2 SENDING EVENTS $hub->send($event) The C<send()> method is used to issue an event to the hub. This method will handle thread/fork sync, filters, listeners, TAP output, etc. =head2 ALTERING OR REMOVING EVENTS You can use either C<filter()> or C<pre_filter()>, depending on your needs. Both have identical syntax, so only C<filter()> is shown here. $hub->filter(sub { my ($hub, $event) = @_; my $action = get_action($event); # No action should be taken return $event if $action eq 'none'; # You want your filter to remove the event return undef if $action eq 'delete'; if ($action eq 'do_it') { my $new_event = copy_event($event); ... Change your copy of the event ... return $new_event; } die "Should not happen"; }); By default, filters are not inherited by child hubs. That means if you start a subtest, the subtest will not inherit the filter. You can change this behavior with the C<inherit> parameter: $hub->filter(sub { ... }, inherit => 1); =head2 LISTENING FOR EVENTS $hub->listen(sub { my ($hub, $event, $number) = @_; ... do whatever you want with the event ... # return is ignored }); By default listeners are not inherited by child hubs. That means if you start a subtest, the subtest will not inherit the listener. You can change this behavior with the C<inherit> parameter: $hub->listen(sub { ... }, inherit => 1); =head2 POST-TEST BEHAVIORS $hub->follow_up(sub { my ($trace, $hub) = @_; ... do whatever you need to ... # Return is ignored }); follow_up subs are called only once, either when done_testing is called, or in an END block. =head2 SETTING THE FORMATTER By default an instance of L<Test2::Formatter::TAP> is created and used. my $old = $hub->format(My::Formatter->new); Setting the formatter will REPLACE any existing formatter. You may set the formatter to undef to prevent output. The old formatter will be returned if one was already set. Only one formatter is allowed at a time. =head1 METHODS =over 4 =item $hub->send($event) This is where all events enter the hub for processing. =item $hub->process($event) This is called by send after it does any IPC handling. You can use this to bypass the IPC process, but in general you should avoid using this. =item $old = $hub->format($formatter) Replace the existing formatter instance with a new one. Formatters must be objects that implement a C<< $formatter->write($event) >> method. =item $sub = $hub->listen(sub { ... }, %optional_params) You can use this to record all events AFTER they have been sent to the formatter. No changes made here will be meaningful, except possibly to other listeners. $hub->listen(sub { my ($hub, $event, $number) = @_; ... do whatever you want with the event ... # return is ignored }); Normally listeners are not inherited by child hubs such as subtests. You can add the C<< inherit => 1 >> parameter to allow a listener to be inherited. =item $hub->unlisten($sub) You can use this to remove a listen callback. You must pass in the coderef returned by the C<listen()> method. =item $sub = $hub->filter(sub { ... }, %optional_params) =item $sub = $hub->pre_filter(sub { ... }, %optional_params) These can be used to add filters. Filters can modify, replace, or remove events before anything else can see them. $hub->filter( sub { my ($hub, $event) = @_; return $event; # No Changes return; # Remove the event # Or you can modify an event before returning it. $event->modify; return $event; } ); If you are not using threads, forking, or IPC then the only difference between a C<filter> and a C<pre_filter> is that C<pre_filter> subs run first. When you are using threads, forking, or IPC, pre_filters happen to events before they are sent to their destination proc/thread, ordinary filters happen only in the destination hub/thread. You cannot add a regular filter to a hub if the hub was created in another process or thread. You can always add a pre_filter. =item $hub->unfilter($sub) =item $hub->pre_unfilter($sub) These can be used to remove filters and pre_filters. The C<$sub> argument is the reference returned by C<filter()> or C<pre_filter()>. =item $hub->follow_op(sub { ... }) Use this to add behaviors that are called just before the hub is finalized. The only argument to your codeblock will be a L<Test2::EventFacet::Trace> instance. $hub->follow_up(sub { my ($trace, $hub) = @_; ... do whatever you need to ... # Return is ignored }); follow_up subs are called only once, ether when done_testing is called, or in an END block. =item $sub = $hub->add_context_acquire(sub { ... }); Add a callback that will be called every time someone tries to acquire a context. It gets a single argument, a reference of the hash of parameters being used the construct the context. This is your chance to change the parameters by directly altering the hash. test2_add_callback_context_acquire(sub { my $params = shift; $params->{level}++; }); This is a very scary API function. Please do not use this unless you need to. This is here for L<Test::Builder> and backwards compatibility. This has you directly manipulate the hash instead of returning a new one for performance reasons. B<Note> Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_acquire($sub); This can be used to remove a context acquire hook. =item $sub = $hub->add_context_init(sub { ... }); This allows you to add callbacks that will trigger every time a new context is created for the hub. The only argument to the sub will be the L<Test2::API::Context> instance that was created. B<Note> Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_init($sub); This can be used to remove a context init hook. =item $sub = $hub->add_context_release(sub { ... }); This allows you to add callbacks that will trigger every time a context for this hub is released. The only argument to the sub will be the L<Test2::API::Context> instance that was released. These will run in reverse order. B<Note> Using this hook could have a huge performance impact. The coderef you provide is returned and can be used to remove the hook later. =item $hub->remove_context_release($sub); This can be used to remove a context release hook. =item $hub->cull() Cull any IPC events (and process them). =item $pid = $hub->pid() Get the process id under which the hub was created. =item $tid = $hub->tid() Get the thread id under which the hub was created. =item $hud = $hub->hid() Get the identifier string of the hub. =item $uuid = $hub->uuid() If UUID tagging is enabled (see L<Test2::API>) then the hub will have a UUID. =item $ipc = $hub->ipc() Get the IPC object used by the hub. =item $hub->set_no_ending($bool) =item $bool = $hub->no_ending This can be used to disable auto-ending behavior for a hub. The auto-ending behavior is triggered by an end block and is used to cull IPC events, and output the final plan if the plan was 'NO PLAN'. =item $bool = $hub->active =item $hub->set_active($bool) These are used to get/set the 'active' attribute. When true this attribute will force C<< hub->finalize() >> to take action even if there is no plan, and no tests have been run. This flag is useful for plugins that add follow-up behaviors that need to run even if no events are seen. =back =head2 STATE METHODS =over 4 =item $hub->reset_state() Reset all state to the start. This sets the test count to 0, clears the plan, removes the failures, etc. =item $num = $hub->count Get the number of tests that have been run. =item $num = $hub->failed Get the number of failures (Not all failures come from a test fail, so this number can be larger than the count). =item $bool = $hub->ended True if the testing has ended. This MAY return the stack frame of the tool that ended the test, but that is not guaranteed. =item $bool = $hub->is_passing =item $hub->is_passing($bool) Check if the overall test run is a failure. Can also be used to set the pass/fail status. =item $hub->plan($plan) =item $plan = $hub->plan Get or set the plan. The plan must be an integer larger than 0, the string 'NO PLAN', or the string 'SKIP'. =item $bool = $hub->check_plan Check if the plan and counts match, but only if the tests have ended. If tests have not ended this will return undef, otherwise it will be a true/false. =back =head1 THIRD PARTY META-DATA This object consumes L<Test2::Util::ExternalMeta> which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Util/Trace.pm 0000444 00000001563 14711217520 0011110 0 ustar 00 package Test2::Util::Trace; require Test2::EventFacet::Trace; use warnings; use strict; our @ISA = ('Test2::EventFacet::Trace'); our $VERSION = '1.302186'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Trace - Legacy wrapper fro L<Test2::EventFacet::Trace>. =head1 DESCRIPTION All the functionality for this class has been moved to L<Test2::EventFacet::Trace>. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Util/ExternalMeta.pm 0000444 00000007303 14711217521 0012442 0 ustar 00 package Test2::Util::ExternalMeta; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/croak/; sub META_KEY() { '_meta' } our @EXPORT = qw/meta set_meta get_meta delete_meta/; BEGIN { require Exporter; our @ISA = qw(Exporter) } sub set_meta { my $self = shift; my ($key, $value) = @_; validate_key($key); $self->{+META_KEY} ||= {}; $self->{+META_KEY}->{$key} = $value; } sub get_meta { my $self = shift; my ($key) = @_; validate_key($key); my $meta = $self->{+META_KEY} or return undef; return $meta->{$key}; } sub delete_meta { my $self = shift; my ($key) = @_; validate_key($key); my $meta = $self->{+META_KEY} or return undef; delete $meta->{$key}; } sub meta { my $self = shift; my ($key, $default) = @_; validate_key($key); my $meta = $self->{+META_KEY}; return undef unless $meta || defined($default); unless($meta) { $meta = {}; $self->{+META_KEY} = $meta; } $meta->{$key} = $default if defined($default) && !defined($meta->{$key}); return $meta->{$key}; } sub validate_key { my $key = shift; return if $key && !ref($key); my $render_key = defined($key) ? "'$key'" : 'undef'; croak "Invalid META key: $render_key, keys must be true, and may not be references"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data to your instances. =head1 DESCRIPTION This package lets you define a clear, and consistent way to allow third party tools to attach meta-data to your instances. If your object consumes this package, and imports its methods, then third party meta-data has a safe place to live. =head1 SYNOPSIS package My::Object; use strict; use warnings; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; ... Now to use it: my $inst = My::Object->new; $inst->set_meta(foo => 'bar'); my $val = $inst->get_meta('foo'); =head1 WHERE IS THE DATA STORED? This package assumes your instances are blessed hashrefs, it will not work if that is not true. It will store all meta-data in the C<_meta> key on your objects hash. If your object makes use of the C<_meta> key in its underlying hash, then there is a conflict and you cannot use this package. =head1 EXPORTS =over 4 =item $val = $obj->meta($key) =item $val = $obj->meta($key, $default) This will get the value for a specified meta C<$key>. Normally this will return C<undef> when there is no value for the C<$key>, however you can specify a C<$default> value to set when no value is already set. =item $val = $obj->get_meta($key) This will get the value for a specified meta C<$key>. This does not have the C<$default> overhead that C<meta()> does. =item $val = $obj->delete_meta($key) This will remove the value of a specified meta C<$key>. The old C<$val> will be returned. =item $obj->set_meta($key, $val) Set the value of a specified meta C<$key>. =back =head1 META-KEY RESTRICTIONS Meta keys must be defined, and must be true when used as a boolean. Keys may not be references. You are free to stringify a reference C<"$ref"> for use as a key, but this package will not stringify it for you. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Util/HashBase.pm 0000444 00000031645 14711217521 0011535 0 ustar 00 package Test2::Util::HashBase; use strict; use warnings; our $VERSION = '1.302186'; ################################################################# # # # This is a generated file! Do not modify this file directly! # # Use hashbase_inc.pl script to regenerate this file. # # The script is part of the Object::HashBase distribution. # # Note: You can modify the version number above this comment # # if needed, that is fine. # # # ################################################################# { no warnings 'once'; $Test2::Util::HashBase::HB_VERSION = '0.009'; *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE; } require Carp; { no warnings 'once'; $Carp::Internal{+__PACKAGE__} = 1; } BEGIN { # these are not strictly equivalent, but for out use we don't care # about order *_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub { no strict 'refs'; my @packages = ($_[0]); my %seen; for my $package (@packages) { push @packages, grep !$seen{$_}++, @{"$package\::ISA"}; } return \@packages; } } my %SPEC = ( '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, ); sub import { my $class = shift; my $into = caller; # Make sure we list the OLDEST version used to create this class. my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION; $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver; my $isa = _isa($into); my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= []; my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {}; my %subs = ( ($into->can('new') ? () : (new => \&_new)), (map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]), ( map { my $p = substr($_, 0, 1); my $x = $_; my $spec = $SPEC{$p} || {reader => 1, writer => 1}; substr($x, 0, 1) = '' if $spec->{strip}; push @$attr_list => $x; my ($sub, $attr) = (uc $x, $x); $attr_subs->{$sub} = sub() { $attr }; my %out = ($sub => $attr_subs->{$sub}); $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; %out; } @_ ), ); no strict 'refs'; *{"$into\::$_"} = $subs{$_} for keys %subs; } sub attr_list { my $class = shift; my $isa = _isa($class); my %seen; my @list = grep { !$seen{$_}++ } map { my @out; if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) { Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()"); } else { my $list = $Test2::Util::HashBase::ATTR_LIST{$_}; @out = $list ? @$list : () } @out; } reverse @$isa; return @list; } sub _new { my $class = shift; my $self; if (@_ == 1) { my $arg = shift; my $type = ref($arg); if ($type eq 'HASH') { $self = bless({%$arg}, $class) } else { Carp::croak("Not sure what to do with '$type' in $class constructor") unless $type eq 'ARRAY'; my %proto; my @attributes = attr_list($class); while (@$arg) { my $val = shift @$arg; my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor"); $proto{$key} = $val; } $self = bless(\%proto, $class); } } else { $self = bless({@_}, $class); } $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init') unless exists $Test2::Util::HashBase::CAN_CACHE{$class}; $self->init if $Test2::Util::HashBase::CAN_CACHE{$class}; $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::HashBase - Build hash based classes. =head1 SYNOPSIS A class: package My::Class; use strict; use warnings; # Generate 3 accessors use Test2::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; # Chance to initialize defaults sub init { my $self = shift; # No other args $self->{+FOO} ||= "foo"; $self->{+BAR} ||= "bar"; $self->{+BAZ} ||= "baz"; $self->{+BAT} ||= "bat"; $self->{+BAN} ||= "ban"; $self->{+BOO} ||= "boo"; } sub print { print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; } Subclass it package My::Subclass; use strict; use warnings; # Note, you should subclass before loading HashBase. use base 'My::Class'; use Test2::Util::HashBase qw/bub/; sub init { my $self = shift; # We get the constants from the base class for free. $self->{+FOO} ||= 'SubFoo'; $self->{+BUB} ||= 'bub'; $self->SUPER::init(); } use it: package main; use strict; use warnings; use My::Class; # These are all functionally identical my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar'); my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); my $three = My::Class->new(['MyFoo', 'MyBar']); # Readers! my $foo = $one->foo; # 'MyFoo' my $bar = $one->bar; # 'MyBar' my $baz = $one->baz; # Defaulted to: 'baz' my $bat = $one->bat; # Defaulted to: 'bat' # '>ban' means setter only, no reader # '+boo' means no setter or reader, just the BOO constant # Setters! $one->set_foo('A Foo'); #'-bar' means read-only, so the setter will throw an exception (but is defined). $one->set_bar('A bar'); # '^baz' means deprecated setter, this will warn about the setter being # deprecated. $one->set_baz('A Baz'); # '<bat' means no setter defined at all # '+boo' means no setter or reader, just the BOO constant $one->{+FOO} = 'xxx'; =head1 DESCRIPTION This package is used to generate classes based on hashrefs. Using this class will give you a C<new()> method, as well as generating accessors you request. Generated accessors will be getters, C<set_ACCESSOR> setters will also be generated for you. You also get constants for each accessor (all caps) which return the key into the hash for that accessor. Single inheritance is also supported. =head1 THIS IS A BUNDLED COPY OF HASHBASE This is a bundled copy of L<Object::HashBase>. This file was generated using the C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl> script. =head1 METHODS =head2 PROVIDED BY HASH BASE =over 4 =item $it = $class->new(%PAIRS) =item $it = $class->new(\%PAIRS) =item $it = $class->new(\@ORDERED_VALUES) Create a new instance. HashBase will not export C<new()> if there is already a C<new()> method in your packages inheritance chain. B<If you do not want this method you can define your own> you just have to declare it before loading L<Test2::Util::HashBase>. package My::Package; # predeclare new() so that HashBase does not give us one. sub new; use Test2::Util::HashBase qw/foo bar baz/; # Now we define our own new method. sub new { ... } This makes it so that HashBase sees that you have your own C<new()> method. Alternatively you can define the method before loading HashBase instead of just declaring it, but that scatters your use statements. The most common way to create an object is to pass in key/value pairs where each key is an attribute and each value is what you want assigned to that attribute. No checking is done to verify the attributes or values are valid, you may do that in C<init()> if desired. If you would like, you can pass in a hashref instead of pairs. When you do so the hashref will be copied, and the copy will be returned blessed as an object. There is no way to ask HashBase to bless a specific hashref. In some cases an object may only have 1 or 2 attributes, in which case a hashref may be too verbose for your liking. In these cases you can pass in an arrayref with only values. The values will be assigned to attributes in the order the attributes were listed. When there is inheritance involved the attributes from parent classes will come before subclasses. =back =head2 HOOKS =over 4 =item $self->init() This gives you the chance to set some default values to your fields. The only argument is C<$self> with its indexes already set from the constructor. B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >> during construction. It DOES NOT call C<can()> on the created object. Also note that the result of the check is cached, it is only ever checked once, the first time an instance of your class is created. This means that adding an C<init()> method AFTER the first construction will result in it being ignored. =back =head1 ACCESSORS =head2 READ/WRITE To generate accessors you list them when using the module: use Test2::Util::HashBase qw/foo/; This will generate the following subs in your namespace: =over 4 =item foo() Getter, used to get the value of the C<foo> field. =item set_foo() Setter, used to set the value of the C<foo> field. =item FOO() Constant, returns the field C<foo>'s key into the class hashref. Subclasses will also get this function as a constant, not simply a method, that means it is copied into the subclass namespace. The main reason for using these constants is to help avoid spelling mistakes and similar typos. It will not help you if you forget to prefix the '+' though. =back =head2 READ ONLY use Test2::Util::HashBase qw/-foo/; =over 4 =item set_foo() Throws an exception telling you the attribute is read-only. This is exported to override any active setters for the attribute in a parent class. =back =head2 DEPRECATED SETTER use Test2::Util::HashBase qw/^foo/; =over 4 =item set_foo() This will set the value, but it will also warn you that the method is deprecated. =back =head2 NO SETTER use Test2::Util::HashBase qw/<foo/; Only gives you a reader, no C<set_foo> method is defined at all. =head2 NO READER use Test2::Util::HashBase qw/>foo/; Only gives you a write (C<set_foo>), no C<foo> method is defined at all. =head2 CONSTANT ONLY use Test2::Util::HashBase qw/+foo/; This does not create any methods for you, it just adds the C<FOO> constant. =head1 SUBCLASSING You can subclass an existing HashBase class. use base 'Another::HashBase::Class'; use Test2::Util::HashBase qw/foo bar baz/; The base class is added to C<@ISA> for you, and all constants from base classes are added to subclasses automatically. =head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS Test2::Util::HashBase provides a function for retrieving a list of attributes for an Test2::Util::HashBase class. =over 4 =item @list = Test2::Util::HashBase::attr_list($class) =item @list = $class->Test2::Util::HashBase::attr_list() Either form above will work. This will return a list of attributes defined on the object. This list is returned in the attribute definition order, parent class attributes are listed before subclass attributes. Duplicate attributes will be removed before the list is returned. B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to determine the attribute to which each value will be paired. =back =head1 SOURCE The source code repository for HashBase can be found at F<http://github.com/Test-More/HashBase/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Util/Facets2Legacy.pm 0000444 00000015373 14711217521 0012473 0 ustar 00 package Test2::Util::Facets2Legacy; use strict; use warnings; our $VERSION = '1.302186'; use Carp qw/croak confess/; use Scalar::Util qw/blessed/; use base 'Exporter'; our @EXPORT_OK = qw{ causes_fail diagnostics global increments_count no_display sets_plan subtest_id summary terminate uuid }; our %EXPORT_TAGS = ( ALL => \@EXPORT_OK ); our $CYCLE_DETECT = 0; sub _get_facet_data { my $in = shift; if (blessed($in) && $in->isa('Test2::Event')) { confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)" if $CYCLE_DETECT; local $CYCLE_DETECT = 1; return $in->facet_data; } return $in if ref($in) eq 'HASH'; croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref"; } sub causes_fail { my $facet_data = _get_facet_data(shift @_); return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}}; if (my $control = $facet_data->{control}) { return 1 if $control->{halt}; return 1 if $control->{terminate}; } return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}}; return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass}; return 0; } sub diagnostics { my $facet_data = _get_facet_data(shift @_); return 1 if $facet_data->{errors} && @{$facet_data->{errors}}; return 0 unless $facet_data->{info} && @{$facet_data->{info}}; return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0; } sub global { my $facet_data = _get_facet_data(shift @_); return 0 unless $facet_data->{control}; return $facet_data->{control}->{global}; } sub increments_count { my $facet_data = _get_facet_data(shift @_); return $facet_data->{assert} ? 1 : 0; } sub no_display { my $facet_data = _get_facet_data(shift @_); return 0 unless $facet_data->{about}; return $facet_data->{about}->{no_display}; } sub sets_plan { my $facet_data = _get_facet_data(shift @_); my $plan = $facet_data->{plan} or return; my @out = ($plan->{count} || 0); if ($plan->{skip}) { push @out => 'SKIP'; push @out => $plan->{details} if defined $plan->{details}; } elsif ($plan->{none}) { push @out => 'NO PLAN' } return @out; } sub subtest_id { my $facet_data = _get_facet_data(shift @_); return undef unless $facet_data->{parent}; return $facet_data->{parent}->{hid}; } sub summary { my $facet_data = _get_facet_data(shift @_); return '' unless $facet_data->{about} && $facet_data->{about}->{details}; return $facet_data->{about}->{details}; } sub terminate { my $facet_data = _get_facet_data(shift @_); return undef unless $facet_data->{control}; return $facet_data->{control}->{terminate}; } sub uuid { my $in = shift; if ($CYCLE_DETECT) { if (blessed($in) && $in->isa('Test2::Event')) { my $meth = $in->can('uuid'); $meth = $in->can('SUPER::uuid') if $meth == \&uuid; my $uuid = $in->$meth if $meth && $meth != \&uuid; return $uuid if $uuid; } return undef; } my $facet_data = _get_facet_data($in); return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid}; return undef; } 1; =pod =encoding UTF-8 =head1 NAME Test2::Util::Facets2Legacy - Convert facet data to the legacy event API. =head1 DESCRIPTION This module exports several subroutines from the older event API (see L<Test2::Event>). These subroutines can be used as methods on any object that provides a custom C<facet_data()> method. These subroutines can also be used as functions that take a facet data hashref as arguments. =head1 SYNOPSIS =head2 AS METHODS package My::Event; use Test2::Util::Facets2Legacy ':ALL'; sub facet_data { return { ... } } Then to use it: my $e = My::Event->new(...); my $causes_fail = $e->causes_fail; my $summary = $e->summary; .... =head2 AS FUNCTIONS use Test2::Util::Facets2Legacy ':ALL'; my $f = { assert => { ... }, info => [{...}, ...], control => {...}, ... }; my $causes_fail = causes_fail($f); my $summary = summary($f); =head1 NOTE ON CYCLES When used as methods, all these subroutines call C<< $e->facet_data() >>. The default C<facet_data()> method in L<Test2::Event> relies on the legacy methods this module emulates in order to work. As a result of this it is very easy to create infinite recursion bugs. These methods have cycle detection and will throw an exception early if a cycle is detected. C<uuid()> is currently the only subroutine in this library that has a fallback behavior when cycles are detected. =head1 EXPORTS Nothing is exported by default. You must specify which methods to import, or use the ':ALL' tag. =over 4 =item $bool = $e->causes_fail() =item $bool = causes_fail($f) Check if the event or facets result in a failing state. =item $bool = $e->diagnostics() =item $bool = diagnostics($f) Check if the event or facets contain any diagnostics information. =item $bool = $e->global() =item $bool = global($f) Check if the event or facets need to be globally processed. =item $bool = $e->increments_count() =item $bool = increments_count($f) Check if the event or facets make an assertion. =item $bool = $e->no_display() =item $bool = no_display($f) Check if the event or facets should be rendered or hidden. =item ($max, $directive, $reason) = $e->sets_plan() =item ($max, $directive, $reason) = sets_plan($f) Check if the event or facets set a plan, and return the plan details. =item $id = $e->subtest_id() =item $id = subtest_id($f) Get the subtest id, if any. =item $string = $e->summary() =item $string = summary($f) Get the summary of the event or facets hash, if any. =item $undef_or_int = $e->terminate() =item $undef_or_int = terminate($f) Check if the event or facets should result in process termination, if so the exit code is returned (which could be 0). undef is returned if no termination is requested. =item $uuid = $e->uuid() =item $uuid = uuid($f) Get the UUID of the facets or event. B<Note:> This will fall back to C<< $e->SUPER::uuid() >> if a cycle is detected and an event is used as the argument. =back =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test2/Event.pm 0000444 00000054157 14711217521 0010226 0 ustar 00 package Test2::Event; use strict; use warnings; our $VERSION = '1.302186'; use Scalar::Util qw/blessed reftype/; use Carp qw/croak/; use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/; use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; use Test2::Util qw/pkg_to_file gen_uid/; use Test2::EventFacet::About(); use Test2::EventFacet::Amnesty(); use Test2::EventFacet::Assert(); use Test2::EventFacet::Control(); use Test2::EventFacet::Error(); use Test2::EventFacet::Info(); use Test2::EventFacet::Meta(); use Test2::EventFacet::Parent(); use Test2::EventFacet::Plan(); use Test2::EventFacet::Trace(); use Test2::EventFacet::Hub(); # Legacy tools will expect this to be loaded now require Test2::Util::Trace; my %LOADED_FACETS = ( 'about' => 'Test2::EventFacet::About', 'amnesty' => 'Test2::EventFacet::Amnesty', 'assert' => 'Test2::EventFacet::Assert', 'control' => 'Test2::EventFacet::Control', 'errors' => 'Test2::EventFacet::Error', 'info' => 'Test2::EventFacet::Info', 'meta' => 'Test2::EventFacet::Meta', 'parent' => 'Test2::EventFacet::Parent', 'plan' => 'Test2::EventFacet::Plan', 'trace' => 'Test2::EventFacet::Trace', 'hubs' => 'Test2::EventFacet::Hub', ); sub FACET_TYPES { sort values %LOADED_FACETS } sub load_facet { my $class = shift; my ($facet) = @_; return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet}; my @check = ($facet); if ('s' eq substr($facet, -1, 1)) { push @check => substr($facet, 0, -1); } else { push @check => $facet . 's'; } my $found; for my $check (@check) { my $mod = "Test2::EventFacet::" . ucfirst($facet); my $file = pkg_to_file($mod); next unless eval { require $file; 1 }; $found = $mod; last; } return undef unless $found; $LOADED_FACETS{$facet} = $found; } sub causes_fail { 0 } sub increments_count { 0 } sub diagnostics { 0 } sub no_display { 0 } sub subtest_id { undef } sub callback { } sub terminate { () } sub global { () } sub sets_plan { () } sub summary { ref($_[0]) } sub related { my $self = shift; my ($event) = @_; my $tracea = $self->trace or return undef; my $traceb = $event->trace or return undef; my $uuida = $tracea->uuid; my $uuidb = $traceb->uuid; if ($uuida && $uuidb) { return 1 if $uuida eq $uuidb; return 0; } my $siga = $tracea->signature or return undef; my $sigb = $traceb->signature or return undef; return 1 if $siga eq $sigb; return 0; } sub add_hub { my $self = shift; unshift @{$self->{+HUBS}} => @_; } sub add_amnesty { my $self = shift; for my $am (@_) { $am = {%$am} if ref($am) ne 'ARRAY'; $am = Test2::EventFacet::Amnesty->new($am); push @{$self->{+AMNESTY}} => $am; } } sub eid { $_[0]->{+_EID} ||= gen_uid() } sub common_facet_data { my $self = shift; my %out; $out{about} = {package => ref($self) || undef}; if (my $uuid = $self->uuid) { $out{about}->{uuid} = $uuid; } $out{about}->{eid} = $self->{+_EID} || $self->eid; if (my $trace = $self->trace) { $out{trace} = { %$trace }; } if (my $hubs = $self->hubs) { $out{hubs} = $hubs; } $out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}] if $self->{+AMNESTY}; if (my $meta = $self->meta_facet_data) { $out{meta} = $meta; } return \%out; } sub meta_facet_data { my $self = shift; my $key = Test2::Util::ExternalMeta::META_KEY(); my $hash = $self->{$key} or return undef; return {%$hash}; } sub facet_data { my $self = shift; my $out = $self->common_facet_data; $out->{about}->{details} = $self->summary || undef; $out->{about}->{no_display} = $self->no_display || undef; # Might be undef, we want to preserve that my $terminate = $self->terminate; $out->{control} = { global => $self->global || 0, terminate => $terminate, has_callback => $self->can('callback') == \&callback ? 0 : 1, }; $out->{assert} = { no_debug => 1, # Legacy behavior pass => $self->causes_fail ? 0 : 1, details => $self->summary, } if $self->increments_count; $out->{parent} = {hid => $self->subtest_id} if $self->subtest_id; if (my @plan = $self->sets_plan) { $out->{plan} = {}; $out->{plan}->{count} = $plan[0] if defined $plan[0]; $out->{plan}->{details} = $plan[2] if defined $plan[2]; if ($plan[1]) { $out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP'; $out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN'; } $out->{control}->{terminate} ||= 0 if $out->{plan}->{skip}; } if ($self->causes_fail && !$out->{assert}) { $out->{errors} = [ { tag => 'FAIL', fail => 1, details => $self->summary, } ]; } my %IGNORE = (trace => 1, about => 1, control => 1); my $do_info = !grep { !$IGNORE{$_} } keys %$out; if ($do_info && !$self->no_display && $self->diagnostics) { $out->{info} = [ { tag => 'DIAG', debug => 1, details => $self->summary, } ]; } return $out; } sub facets { my $self = shift; my %out; my $data = $self->facet_data; my @errors = $self->validate_facet_data($data); die join "\n" => @errors if @errors; for my $facet (keys %$data) { my $class = $self->load_facet($facet); my $val = $data->{$facet}; unless($class) { $out{$facet} = $val; next; } my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0; if ($is_list) { $out{$facet} = [map { $class->new($_) } @$val]; } else { $out{$facet} = $class->new($val); } } return \%out; } sub validate_facet_data { my $class_or_self = shift; my ($f, %params); $f = shift if @_ && (reftype($_[0]) || '') eq 'HASH'; %params = @_; $f ||= $class_or_self->facet_data if blessed($class_or_self); croak "No facet data" unless $f; my @errors; for my $k (sort keys %$f) { my $fclass = $class_or_self->load_facet($k); push @errors => "Could not find a facet class for facet '$k'" if $params{require_facet_class} && !$fclass; next unless $fclass; my $v = $f->{$k}; next unless defined($v); # undef is always fine my $is_list = $fclass->is_list(); my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0; push @errors => "Facet '$k' should be a list, but got a single item ($v)" if $is_list && !$got_list; push @errors => "Facet '$k' should not be a list, but got a a list ($v)" if $got_list && !$is_list; } return @errors; } sub nested { my $self = shift; Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead") if $ENV{AUTHOR_TESTING}; if (my $hubs = $self->{+HUBS}) { return $hubs->[0]->{nested} if @$hubs; } my $trace = $self->{+TRACE} or return undef; return $trace->{nested}; } sub in_subtest { my $self = shift; Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead") if $ENV{AUTHOR_TESTING}; my $hubs = $self->{+HUBS}; if ($hubs && @$hubs) { return undef unless $hubs->[0]->{nested}; return $hubs->[0]->{hid} } my $trace = $self->{+TRACE} or return undef; return undef unless $trace->{nested}; return $trace->{hid}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Event - Base class for events =head1 DESCRIPTION Base class for all event objects that get passed through L<Test2>. =head1 SYNOPSIS package Test2::Event::MyEvent; use strict; use warnings; # This will make our class an event subclass (required) use base 'Test2::Event'; # Add some accessors (optional) # You are not obligated to use HashBase, you can use any object tool you # want, or roll your own accessors. use Test2::Util::HashBase qw/foo bar baz/; # Use this if you want the legacy API to be written for you, for this to # work you will need to implement a facet_data() method. use Test2::Util::Facets2Legacy; # Chance to initialize some defaults sub init { my $self = shift; # no other args in @_ $self->set_foo('xxx') unless defined $self->foo; ... } # This is the new way for events to convey data to the Test2 system sub facet_data { my $self = shift; # Get common facets such as 'about', 'trace' 'amnesty', and 'meta' my $facet_data = $self->common_facet_data(); # Are you making an assertion? $facet_data->{assert} = {pass => 1, details => 'my assertion'}; ... return $facet_data; } 1; =head1 METHODS =head2 GENERAL =over 4 =item $trace = $e->trace Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was generated =item $bool_or_undef = $e->related($e2) Check if 2 events are related. In this case related means their traces share a signature meaning they were created with the same context (or at the very least by contexts which share an id, which is the same thing unless someone is doing something very bad). This can be used to reliably link multiple events created by the same tool. For instance a failing test like C<ok(0, "fail"> will generate 2 events, one being a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these events are related having been created under the same context and by the same initial tool (though multiple tools may have been nested under the initial one). This will return C<undef> if the relationship cannot be checked, which happens if either event has an incomplete or missing trace. This will return C<0> if the traces are complete, but do not match. C<1> will be returned if there is a match. =item $e->add_amnesty({tag => $TAG, details => $DETAILS}); This can be used to add amnesty to this event. Amnesty only effects failing assertions in most cases, but some formatters may display them for passing assertions, or even non-assertions as well. Amnesty will prevent a failed assertion from causing the overall test to fail. In other words it marks a failure as expected and allowed. B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially amnesty with the 'TODO' tag. The details are the reason for the TODO. =item $uuid = $e->uuid If UUID tagging is enabled (See L<Test::API>) then any event that has made its way through a hub will be tagged with a UUID. A newly created event will not yet be tagged in most cases. =item $class = $e->load_facet($name) This method is used to load a facet by name (or key). It will attempt to load the facet class, if it succeeds it will return the class it loaded. If it fails it will return C<undef>. This caches the result at the class level so that future calls will be faster. The C<$name> variable should be the key used to access the facet in a facets hashref. For instance the assertion facet has the key 'assert', the information facet has the 'info' key, and the error facet has the key 'errors'. You may include or omit the 's' at the end of the name, the method is smart enough to try both the 's' and no-'s' forms, it will check what you provided first, and if that is not found it will add or strip the 's and try again. =item @classes = $e->FACET_TYPES() =item @classes = Test2::Event->FACET_TYPES() This returns a list of all facets that have been loaded using the C<load_facet()> method. This will not return any classes that have not been loaded, or have been loaded directly without a call to C<load_facet()>. B<Note:> The core facet types are automatically loaded and populated in this list. =back =head2 NEW API =over 4 =item $hashref = $e->common_facet_data(); This can be used by subclasses to generate a starting facet data hashref. This will populate the hashref with the trace, meta, amnesty, and about facets. These facets are nearly always produced the same way for all events. =item $hashref = $e->facet_data() If you do not override this then the default implementation will attempt to generate facets from the legacy API. This generation is limited only to what the legacy API can provide. It is recommended that you override this method and write out explicit facet data. =item $hashref = $e->facets() This takes the hashref from C<facet_data()> and blesses each facet into the proper C<Test2::EventFacet::*> subclass. If no class can be found for any given facet it will be passed along unchanged. =item @errors = $e->validate_facet_data(); =item @errors = $e->validate_facet_data(%params); =item @errors = $e->validate_facet_data(\%facets, %params); =item @errors = Test2::Event->validate_facet_data(%params); =item @errors = Test2::Event->validate_facet_data(\%facets, %params); This method will validate facet data and return a list of errors. If no errors are found this will return an empty list. This can be called as an object method with no arguments, in which case the C<facet_data()> method will be called to get the facet data to be validated. When used as an object method the C<\%facet_data> argument may be omitted. When used as a class method the C<\%facet_data> argument is required. Remaining arguments will be slurped into a C<%params> hash. Currently only 1 parameter is defined: =over 4 =item require_facet_class => $BOOL When set to true (default is false) this will reject any facets where a facet class cannot be found. Normally facets without classes are assumed to be custom and are ignored. =back =back =head3 WHAT ARE FACETS? Facets are how events convey their purpose to the Test2 internals and formatters. An event without facets will have no intentional effect on the overall test state, and will not be displayed at all by most formatters, except perhaps to say that an event of an unknown type was seen. Facets are produced by the C<facet_data()> subroutine, which you should nearly-always override. C<facet_data()> is expected to return a hashref where each key is the facet type, and the value is either a hashref with the data for that facet, or an array of hashrefs. Some facets must be defined as single hashrefs, some must be defined as an array of hashrefs, No facets allow both. C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and nested facet hashrefs B<MUST> be bare, though items contained within each facet may be blessed. The data returned by this method B<should> also be copies of the internal data in order to prevent accidental state modification. C<facets()> takes the data from C<facet_data()> and blesses it into the C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet packages are primarily for convenience and documentation. The EventFacet classes are not used at all internally, instead the raw data is used. Here is a list of facet types by package. The packages are not used internally, but are where the documentation for each type is kept. B<Note:> Every single facet type has the C<'details'> field. This field is always intended for human consumption, and when provided, should explain the 'why' for the facet. All other fields are facet specific. =over 4 =item about => {...} L<Test2::EventFacet::About> This contains information about the event itself such as the event package name. The C<details> field for this facet is an overall summary of the event. =item assert => {...} L<Test2::EventFacet::Assert> This facet is used if an assertion was made. The C<details> field of this facet is the description of the assertion. =item control => {...} L<Test2::EventFacet::Control> This facet is used to tell the L<Test2::Event::Hub> about special actions the event causes. Things like halting all testing, terminating the current test, etc. In this facet the C<details> field explains why any special action was taken. B<Note:> This is how bail-out is implemented. =item meta => {...} L<Test2::EventFacet::Meta> The meta facet contains all the meta-data attached to the event. In this case the C<details> field has no special meaning, but may be present if something sets the 'details' meta-key on the event. =item parent => {...} L<Test2::EventFacet::Parent> This facet contains nested events and similar details for subtests. In this facet the C<details> field will typically be the name of the subtest. =item plan => {...} L<Test2::EventFacet::Plan> This facet tells the system that a plan has been set. The C<details> field of this is usually left empty, but when present explains why the plan is what it is, this is most useful if the plan is to skip-all. =item trace => {...} L<Test2::EventFacet::Trace> This facet contains information related to when and where the event was generated. This is how the test file and line number of a failure is known. This facet can also help you to tell if tests are related. In this facet the C<details> field overrides the "failed at test_file.t line 42." message provided on assertion failure. =item amnesty => [{...}, ...] L<Test2::EventFacet::Amnesty> The amnesty facet is a list instead of a single item, this is important as amnesty can come from multiple places at once. For each instance of amnesty the C<details> field explains why amnesty was granted. B<Note:> Outside of formatters amnesty only acts to forgive a failing assertion. =item errors => [{...}, ...] L<Test2::EventFacet::Error> The errors facet is a list instead of a single item, any number of errors can be listed. In this facet C<details> describes the error, or may contain the raw error message itself (such as an exception). In perl exception may be blessed objects, as such the raw data for this facet may contain nested items which are blessed. Not all errors are considered fatal, there is a C<fail> field that must be set for an error to cause the test to fail. B<Note:> This facet is unique in that the field name is 'errors' while the package is 'Error'. This is because this is the only facet type that is both a list, and has a name where the plural is not the same as the singular. This may cause some confusion, but I feel it will be less confusing than the alternative. =item info => [{...}, ...] L<Test2::EventFacet::Info> The 'info' facet is a list instead of a single item, any quantity of extra information can be attached to an event. Some information may be critical diagnostics, others may be simply commentary in nature, this is determined by the C<debug> flag. For this facet the C<details> flag is the info itself. This info may be a string, or it may be a data structure to display. This is one of the few facet types that may contain blessed items. =back =head2 LEGACY API =over 4 =item $bool = $e->causes_fail Returns true if this event should result in a test failure. In general this should be false. =item $bool = $e->increments_count Should be true if this event should result in a test count increment. =item $e->callback($hub) If your event needs to have extra effects on the L<Test2::Hub> you can override this method. This is called B<BEFORE> your event is passed to the formatter. =item $num = $e->nested If this event is nested inside of other events, this should be the depth of nesting. (This is mainly for subtests) =item $bool = $e->global Set this to true if your event is global, that is ALL threads and processes should see it no matter when or where it is generated. This is not a common thing to want, it is used by bail-out and skip_all to end testing. =item $code = $e->terminate This is called B<AFTER> your event has been passed to the formatter. This should normally return undef, only change this if your event should cause the test to exit immediately. If you want this event to cause the test to exit you should return the exit code here. Exit code of 0 means exit success, any other integer means exit with failure. This is used by L<Test2::Event::Plan> to exit 0 when the plan is 'skip_all'. This is also used by L<Test2::Event:Bail> to force the test to exit with a failure. This is called after the event has been sent to the formatter in order to ensure the event is seen and understood. =item $msg = $e->summary This is intended to be a human readable summary of the event. This should ideally only be one line long, but you can use multiple lines if necessary. This is intended for human consumption. You do not need to make it easy for machines to understand. The default is to simply return the event package name. =item ($count, $directive, $reason) = $e->sets_plan() Check if this event sets the testing plan. It will return an empty list if it does not. If it does set the plan it will return a list of 1 to 3 items in order: Expected Test Count, Test Directive, Reason for directive. =item $bool = $e->diagnostics True if the event contains diagnostics info. This is useful because a non-verbose harness may choose to hide events that are not in this category. Some formatters may choose to send these to STDERR instead of STDOUT to ensure they are seen. =item $bool = $e->no_display False by default. This will return true on events that should not be displayed by formatters. =item $id = $e->in_subtest If the event is inside a subtest this should have the subtest ID. =item $id = $e->subtest_id If the event is a final subtest event, this should contain the subtest ID. =back =head1 THIRD PARTY META-DATA This object consumes L<Test2::Util::ExternalMeta> which provides a consistent way for you to attach meta-data to instances of this class. This is useful for tools, plugins, and other extensions. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Path/Tiny.pm 0000444 00000335755 14711217522 0007772 0 ustar 00 use 5.008001; use strict; use warnings; package Path::Tiny; # ABSTRACT: File path utility our $VERSION = '0.118'; # Dependencies use Config; use Exporter 5.57 (qw/import/); use File::Spec 0.86 (); # shipped with 5.8.1 use Carp (); our @EXPORT = qw/path/; our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/; use constant { PATH => 0, CANON => 1, VOL => 2, DIR => 3, FILE => 4, TEMP => 5, IS_WIN32 => ( $^O eq 'MSWin32' ), }; use overload ( q{""} => sub { $_[0]->[PATH] }, bool => sub () { 1 }, fallback => 1, ); # FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol sub FREEZE { return $_[0]->[PATH] } sub THAW { return path( $_[2] ) } { no warnings 'once'; *TO_JSON = *FREEZE }; my $HAS_UU; # has Unicode::UTF8; lazily populated sub _check_UU { local $SIG{__DIE__}; # prevent outer handler from being called !!eval { require Unicode::UTF8; Unicode::UTF8->VERSION(0.58); 1; }; } my $HAS_PU; # has PerlIO::utf8_strict; lazily populated sub _check_PU { local $SIG{__DIE__}; # prevent outer handler from being called !!eval { # MUST preload Encode or $SIG{__DIE__} localization fails # on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2. require Encode; require PerlIO::utf8_strict; PerlIO::utf8_strict->VERSION(0.003); 1; }; } my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf}; # notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \ my $SLASH = qr{[\\/]}; my $NOTSLASH = qr{[^\\/]}; my $DRV_VOL = qr{[a-z]:}i; my $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x; my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x; sub _win32_vol { my ( $path, $drv ) = @_; require Cwd; my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd # getdcwd on non-existent drive returns empty string # so just use the original drive Z: -> Z: $dcwd = "$drv" unless defined $dcwd && length $dcwd; # normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z: $dcwd =~ s{$SLASH?\z}{/}; # make the path absolute with dcwd $path =~ s{^$DRV_VOL}{$dcwd}; return $path; } # This is a string test for before we have the object; see is_rootdir for well-formed # object test sub _is_root { return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT\z/ ) : ( $_[0] eq '/' ); } BEGIN { *_same = IS_WIN32() ? sub { lc( $_[0] ) eq lc( $_[1] ) } : sub { $_[0] eq $_[1] }; } # mode bits encoded for chmod in symbolic mode my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic { my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ }; sub _symbolic_chmod { my ( $mode, $symbolic ) = @_; for my $clause ( split /,\s*/, $symbolic ) { if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) { my ( $who, $action, $perms ) = ( $1, $2, $3 ); $who =~ s/a/ugo/g; for my $w ( split //, $who ) { my $p = 0; $p |= $MODEBITS{"$w$_"} for split //, $perms; if ( $action eq '=' ) { $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p; } else { $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p ); } } } else { Carp::croak("Invalid mode clause '$clause' for chmod()"); } } return $mode; } # flock doesn't work on NFS on BSD or on some filesystems like lustre. # Since program authors often can't control or detect that, we warn once # instead of being fatal if we can detect it and people who need it strict # can fatalize the 'flock' category #<<< No perltidy { package flock; use warnings::register } #>>> my $WARNED_NO_FLOCK = 0; sub _throw { my ( $self, $function, $file, $msg ) = @_; if ( $function =~ /^flock/ && $! =~ /operation not supported|function not implemented/i && !warnings::fatal_enabled('flock') ) { if ( !$WARNED_NO_FLOCK ) { warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" ); $WARNED_NO_FLOCK++; } } else { $msg = $! unless defined $msg; Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ), $msg ); } return; } # cheapo option validation sub _get_args { my ( $raw, @valid ) = @_; if ( defined($raw) && ref($raw) ne 'HASH' ) { my ( undef, undef, undef, $called_as ) = caller(1); $called_as =~ s{^.*::}{}; Carp::croak("Options for $called_as must be a hash reference"); } my $cooked = {}; for my $k (@valid) { $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k}; } if ( keys %$raw ) { my ( undef, undef, undef, $called_as ) = caller(1); $called_as =~ s{^.*::}{}; Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) ); } return $cooked; } #--------------------------------------------------------------------------# # Constructors #--------------------------------------------------------------------------# #pod =construct path #pod #pod $path = path("foo/bar"); #pod $path = path("/tmp", "file.txt"); # list #pod $path = path("."); # cwd #pod $path = path("~user/file.txt"); # tilde processing #pod #pod Constructs a C<Path::Tiny> object. It doesn't matter if you give a file or #pod directory path. It's still up to you to call directory-like methods only on #pod directories and file-like methods only on files. This function is exported #pod automatically by default. #pod #pod The first argument must be defined and have non-zero length or an exception #pod will be thrown. This prevents subtle, dangerous errors with code like #pod C<< path( maybe_undef() )->remove_tree >>. #pod #pod If the first component of the path is a tilde ('~') then the component will be #pod replaced with the output of C<glob('~')>. If the first component of the path #pod is a tilde followed by a user name then the component will be replaced with #pod output of C<glob('~username')>. Behaviour for non-existent users depends on #pod the output of C<glob> on the system. #pod #pod On Windows, if the path consists of a drive identifier without a path component #pod (C<C:> or C<D:>), it will be expanded to the absolute path of the current #pod directory on that volume using C<Cwd::getdcwd()>. #pod #pod If called with a single C<Path::Tiny> argument, the original is returned unless #pod the original is holding a temporary file or directory reference in which case a #pod stringified copy is made. #pod #pod $path = path("foo/bar"); #pod $temp = Path::Tiny->tempfile; #pod #pod $p2 = path($path); # like $p2 = $path #pod $t2 = path($temp); # like $t2 = path( "$temp" ) #pod #pod This optimizes copies without proliferating references unexpectedly if a copy is #pod made by code outside your control. #pod #pod Current API available since 0.017. #pod #pod =cut sub path { my $path = shift; Carp::croak("Path::Tiny paths require defined, positive-length parts") unless 1 + @_ == grep { defined && length } $path, @_; # non-temp Path::Tiny objects are effectively immutable and can be reused if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) { return $path; } # stringify objects $path = "$path"; # expand relative volume paths on windows; put trailing slash on UNC root if ( IS_WIN32() ) { $path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH|\z)}; $path .= "/" if $path =~ m{^$UNC_VOL\z}; } # concatenations stringifies objects, too if (@_) { $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ ); } # canonicalize, but with unix slashes and put back trailing volume slash my $cpath = $path = File::Spec->canonpath($path); $path =~ tr[\\][/] if IS_WIN32(); $path = "/" if $path eq '/..'; # for old File::Spec $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL\z}; # root paths must always have a trailing slash, but other paths must not if ( _is_root($path) ) { $path =~ s{/?\z}{/}; } else { $path =~ s{/\z}{}; } # do any tilde expansions if ( $path =~ m{^(~[^/]*).*} ) { require File::Glob; my ($homedir) = File::Glob::bsd_glob($1); $homedir =~ tr[\\][/] if IS_WIN32(); $path =~ s{^(~[^/]*)}{$homedir}; } bless [ $path, $cpath ], __PACKAGE__; } #pod =construct new #pod #pod $path = Path::Tiny->new("foo/bar"); #pod #pod This is just like C<path>, but with method call overhead. (Why would you #pod do that?) #pod #pod Current API available since 0.001. #pod #pod =cut sub new { shift; path(@_) } #pod =construct cwd #pod #pod $path = Path::Tiny->cwd; # path( Cwd::getcwd ) #pod $path = cwd; # optional export #pod #pod Gives you the absolute path to the current directory as a C<Path::Tiny> object. #pod This is slightly faster than C<< path(".")->absolute >>. #pod #pod C<cwd> may be exported on request and used as a function instead of as a #pod method. #pod #pod Current API available since 0.018. #pod #pod =cut sub cwd { require Cwd; return path( Cwd::getcwd() ); } #pod =construct rootdir #pod #pod $path = Path::Tiny->rootdir; # / #pod $path = rootdir; # optional export #pod #pod Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too #pod picky for C<path("/")>. #pod #pod C<rootdir> may be exported on request and used as a function instead of as a #pod method. #pod #pod Current API available since 0.018. #pod #pod =cut sub rootdir { path( File::Spec->rootdir ) } #pod =construct tempfile, tempdir #pod #pod $temp = Path::Tiny->tempfile( @options ); #pod $temp = Path::Tiny->tempdir( @options ); #pod $temp = tempfile( @options ); # optional export #pod $temp = tempdir( @options ); # optional export #pod #pod C<tempfile> passes the options to C<< File::Temp->new >> and returns a C<Path::Tiny> #pod object with the file name. The C<TMPDIR> option is enabled by default. #pod #pod The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is #pod destroyed, the C<File::Temp> object will be as well. #pod #pod C<File::Temp> annoyingly requires you to specify a custom template in slightly #pod different ways depending on which function or method you call, but #pod C<Path::Tiny> lets you ignore that and can take either a leading template or a #pod C<TEMPLATE> option and does the right thing. #pod #pod $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok #pod $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok #pod #pod The tempfile path object will be normalized to have an absolute path, even if #pod created in a relative directory using C<DIR>. If you want it to have #pod the C<realpath> instead, pass a leading options hash like this: #pod #pod $real_temp = tempfile({realpath => 1}, @options); #pod #pod C<tempdir> is just like C<tempfile>, except it calls #pod C<< File::Temp->newdir >> instead. #pod #pod Both C<tempfile> and C<tempdir> may be exported on request and used as #pod functions instead of as methods. #pod #pod B<Note>: for tempfiles, the filehandles from File::Temp are closed and not #pod reused. This is not as secure as using File::Temp handles directly, but is #pod less prone to deadlocks or access problems on some platforms. Think of what #pod C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned #pod up. #pod #pod B<Note 2>: if you don't want these cleaned up automatically when the object #pod is destroyed, File::Temp requires different options for directories and #pod files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for #pod files. #pod #pod B<Note 3>: Don't lose the temporary object by chaining a method call instead #pod of storing it: #pod #pod my $lost = tempdir()->child("foo"); # tempdir cleaned up right away #pod #pod B<Note 4>: The cached object may be accessed with the L</cached_temp> method. #pod Keeping a reference to, or modifying the cached object may break the #pod behavior documented above and is not supported. Use at your own risk. #pod #pod Current API available since 0.097. #pod #pod =cut sub tempfile { shift if @_ && $_[0] eq 'Path::Tiny'; # called as method my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {}; $opts = _get_args( $opts, qw/realpath/ ); my ( $maybe_template, $args ) = _parse_file_temp_args(@_); # File::Temp->new demands TEMPLATE $args->{TEMPLATE} = $maybe_template->[0] if @$maybe_template; require File::Temp; my $temp = File::Temp->new( TMPDIR => 1, %$args ); close $temp; my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute; $self->[TEMP] = $temp; # keep object alive while we are return $self; } sub tempdir { shift if @_ && $_[0] eq 'Path::Tiny'; # called as method my $opts = ( @_ && ref $_[0] eq 'HASH' ) ? shift @_ : {}; $opts = _get_args( $opts, qw/realpath/ ); my ( $maybe_template, $args ) = _parse_file_temp_args(@_); # File::Temp->newdir demands leading template require File::Temp; my $temp = File::Temp->newdir( @$maybe_template, TMPDIR => 1, %$args ); my $self = $opts->{realpath} ? path($temp)->realpath : path($temp)->absolute; $self->[TEMP] = $temp; # keep object alive while we are # Some ActiveState Perls for Windows break Cwd in ways that lead # File::Temp to get confused about what path to remove; this # monkey-patches the object with our own view of the absolute path $temp->{REALNAME} = $self->[CANON] if IS_WIN32; return $self; } # normalize the various ways File::Temp does templates sub _parse_file_temp_args { my $leading_template = ( scalar(@_) % 2 == 1 ? shift(@_) : '' ); my %args = @_; %args = map { uc($_), $args{$_} } keys %args; my @template = ( exists $args{TEMPLATE} ? delete $args{TEMPLATE} : $leading_template ? $leading_template : () ); return ( \@template, \%args ); } #--------------------------------------------------------------------------# # Private methods #--------------------------------------------------------------------------# sub _splitpath { my ($self) = @_; @{$self}[ VOL, DIR, FILE ] = File::Spec->splitpath( $self->[PATH] ); } sub _resolve_symlinks { my ($self) = @_; my $new = $self; my ( $count, %seen ) = 0; while ( -l $new->[PATH] ) { if ( $seen{ $new->[PATH] }++ ) { $self->_throw( 'readlink', $self->[PATH], "symlink loop detected" ); } if ( ++$count > 100 ) { $self->_throw( 'readlink', $self->[PATH], "maximum symlink depth exceeded" ); } my $resolved = readlink $new->[PATH] or $new->_throw( 'readlink', $new->[PATH] ); $resolved = path($resolved); $new = $resolved->is_absolute ? $resolved : $new->sibling($resolved); } return $new; } #--------------------------------------------------------------------------# # Public methods #--------------------------------------------------------------------------# #pod =method absolute #pod #pod $abs = path("foo/bar")->absolute; #pod $abs = path("foo/bar")->absolute("/tmp"); #pod #pod Returns a new C<Path::Tiny> object with an absolute path (or itself if already #pod absolute). If no argument is given, the current directory is used as the #pod absolute base path. If an argument is given, it will be converted to an #pod absolute path (if it is not already) and used as the absolute base path. #pod #pod This will not resolve upward directories ("foo/../bar") unless C<canonpath> #pod in L<File::Spec> would normally do so on your platform. If you need them #pod resolved, you must call the more expensive C<realpath> method instead. #pod #pod On Windows, an absolute path without a volume component will have it added #pod based on the current drive. #pod #pod Current API available since 0.101. #pod #pod =cut sub absolute { my ( $self, $base ) = @_; # absolute paths handled differently by OS if (IS_WIN32) { return $self if length $self->volume; # add missing volume if ( $self->is_absolute ) { require Cwd; # use Win32::GetCwd not Cwd::getdcwd because we're sure # to have the former but not necessarily the latter my ($drv) = Win32::GetCwd() =~ /^($DRV_VOL | $UNC_VOL)/x; return path( $drv . $self->[PATH] ); } } else { return $self if $self->is_absolute; } # no base means use current directory as base require Cwd; return path( Cwd::getcwd(), $_[0]->[PATH] ) unless defined $base; # relative base should be made absolute; we check is_absolute rather # than unconditionally make base absolute so that "/foo" doesn't become # "C:/foo" on Windows. $base = path($base); return path( ( $base->is_absolute ? $base : $base->absolute ), $_[0]->[PATH] ); } #pod =method append, append_raw, append_utf8 #pod #pod path("foo.txt")->append(@data); #pod path("foo.txt")->append(\@data); #pod path("foo.txt")->append({binmode => ":raw"}, @data); #pod path("foo.txt")->append_raw(@data); #pod path("foo.txt")->append_utf8(@data); #pod #pod Appends data to a file. The file is locked with C<flock> prior to writing #pod and closed afterwards. An optional hash reference may be used to pass #pod options. Valid options are: #pod #pod =for :list #pod * C<binmode>: passed to C<binmode()> on the handle used for writing. #pod * C<truncate>: truncates the file after locking and before appending #pod #pod The C<truncate> option is a way to replace the contents of a file #pod B<in place>, unlike L</spew> which writes to a temporary file and then #pod replaces the original (if it exists). #pod #pod C<append_raw> is like C<append> with a C<binmode> of C<:unix> for fast, #pod unbuffered, raw write. #pod #pod C<append_utf8> is like C<append> with a C<binmode> of #pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> #pod 0.58+ is installed, a raw append will be done instead on the data encoded #pod with C<Unicode::UTF8>. #pod #pod Current API available since 0.060. #pod #pod =cut sub append { my ( $self, @data ) = @_; my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {}; $args = _get_args( $args, qw/binmode truncate/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode; my $mode = $args->{truncate} ? ">" : ">>"; my $fh = $self->filehandle( { locked => 1 }, $mode, $binmode ); print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data; close $fh or $self->_throw('close'); } sub append_raw { my ( $self, @data ) = @_; my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {}; $args = _get_args( $args, qw/binmode truncate/ ); $args->{binmode} = ':unix'; append( $self, $args, @data ); } sub append_utf8 { my ( $self, @data ) = @_; my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {}; $args = _get_args( $args, qw/binmode truncate/ ); if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { $args->{binmode} = ":unix"; append( $self, $args, map { Unicode::UTF8::encode_utf8($_) } @data ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $args->{binmode} = ":unix:utf8_strict"; append( $self, $args, @data ); } else { $args->{binmode} = ":unix:encoding(UTF-8)"; append( $self, $args, @data ); } } #pod =method assert #pod #pod $path = path("foo.txt")->assert( sub { $_->exists } ); #pod #pod Returns the invocant after asserting that a code reference argument returns #pod true. When the assertion code reference runs, it will have the invocant #pod object in the C<$_> variable. If it returns false, an exception will be #pod thrown. The assertion code reference may also throw its own exception. #pod #pod If no assertion is provided, the invocant is returned without error. #pod #pod Current API available since 0.062. #pod #pod =cut sub assert { my ( $self, $assertion ) = @_; return $self unless $assertion; if ( ref $assertion eq 'CODE' ) { local $_ = $self; $assertion->() or Path::Tiny::Error->throw( "assert", $self->[PATH], "failed assertion" ); } else { Carp::croak("argument to assert must be a code reference argument"); } return $self; } #pod =method basename #pod #pod $name = path("foo/bar.txt")->basename; # bar.txt #pod $name = path("foo.txt")->basename('.txt'); # foo #pod $name = path("foo.txt")->basename(qr/.txt/); # foo #pod $name = path("foo.txt")->basename(@suffixes); #pod #pod Returns the file portion or last directory portion of a path. #pod #pod Given a list of suffixes as strings or regular expressions, any that match at #pod the end of the file portion or last directory portion will be removed before #pod the result is returned. #pod #pod Current API available since 0.054. #pod #pod =cut sub basename { my ( $self, @suffixes ) = @_; $self->_splitpath unless defined $self->[FILE]; my $file = $self->[FILE]; for my $s (@suffixes) { my $re = ref($s) eq 'Regexp' ? qr/$s\z/ : qr/\Q$s\E\z/; last if $file =~ s/$re//; } return $file; } #pod =method canonpath #pod #pod $canonical = path("foo/bar")->canonpath; # foo\bar on Windows #pod #pod Returns a string with the canonical format of the path name for #pod the platform. In particular, this means directory separators #pod will be C<\> on Windows. #pod #pod Current API available since 0.001. #pod #pod =cut sub canonpath { $_[0]->[CANON] } #pod =method cached_temp #pod #pod Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the #pod C<Path::Tiny> object was created with C</tempfile> or C</tempdir>. #pod If there is no such object, this method throws. #pod #pod B<WARNING>: Keeping a reference to, or modifying the cached object may #pod break the behavior documented for temporary files and directories created #pod with C<Path::Tiny> and is not supported. Use at your own risk. #pod #pod Current API available since 0.101. #pod #pod =cut sub cached_temp { my $self = shift; $self->_throw( "cached_temp", $self, "has no cached File::Temp object" ) unless defined $self->[TEMP]; return $self->[TEMP]; } #pod =method child #pod #pod $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt" #pod $file = path("/tmp")->child(@parts); #pod #pod Returns a new C<Path::Tiny> object relative to the original. Works #pod like C<catfile> or C<catdir> from File::Spec, but without caring about #pod file or directories. #pod #pod B<WARNING>: because the argument could contain C<..> or refer to symlinks, #pod there is no guarantee that the new path refers to an actual descendent of #pod the original. If this is important to you, transform parent and child with #pod L</realpath> and check them with L</subsumes>. #pod #pod Current API available since 0.001. #pod #pod =cut sub child { my ( $self, @parts ) = @_; return path( $self->[PATH], @parts ); } #pod =method children #pod #pod @paths = path("/tmp")->children; #pod @paths = path("/tmp")->children( qr/\.txt\z/ ); #pod #pod Returns a list of C<Path::Tiny> objects for all files and directories #pod within a directory. Excludes "." and ".." automatically. #pod #pod If an optional C<qr//> argument is provided, it only returns objects for child #pod names that match the given regular expression. Only the base name is used #pod for matching: #pod #pod @paths = path("/tmp")->children( qr/^foo/ ); #pod # matches children like the glob foo* #pod #pod Current API available since 0.028. #pod #pod =cut sub children { my ( $self, $filter ) = @_; my $dh; opendir $dh, $self->[PATH] or $self->_throw('opendir'); my @children = readdir $dh; closedir $dh or $self->_throw('closedir'); if ( not defined $filter ) { @children = grep { $_ ne '.' && $_ ne '..' } @children; } elsif ( $filter && ref($filter) eq 'Regexp' ) { @children = grep { $_ ne '.' && $_ ne '..' && $_ =~ $filter } @children; } else { Carp::croak("Invalid argument '$filter' for children()"); } return map { path( $self->[PATH], $_ ) } @children; } #pod =method chmod #pod #pod path("foo.txt")->chmod(0777); #pod path("foo.txt")->chmod("0755"); #pod path("foo.txt")->chmod("go-w"); #pod path("foo.txt")->chmod("a=r,u+wx"); #pod #pod Sets file or directory permissions. The argument can be a numeric mode, a #pod octal string beginning with a "0" or a limited subset of the symbolic mode use #pod by F</bin/chmod>. #pod #pod The symbolic mode must be a comma-delimited list of mode clauses. Clauses must #pod match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and #pod "perms" parameters for each clause. Unlike F</bin/chmod>, all three parameters #pod are required for each clause, multiple ops are not allowed and permissions #pod C<stugoX> are not supported. (See L<File::chmod> for more complex needs.) #pod #pod Current API available since 0.053. #pod #pod =cut sub chmod { my ( $self, $new_mode ) = @_; my $mode; if ( $new_mode =~ /\d/ ) { $mode = ( $new_mode =~ /^0/ ? oct($new_mode) : $new_mode ); } elsif ( $new_mode =~ /[=+-]/ ) { $mode = _symbolic_chmod( $self->stat->mode & 07777, $new_mode ); ## no critic } else { Carp::croak("Invalid mode argument '$new_mode' for chmod()"); } CORE::chmod( $mode, $self->[PATH] ) or $self->_throw("chmod"); return 1; } #pod =method copy #pod #pod path("/tmp/foo.txt")->copy("/tmp/bar.txt"); #pod #pod Copies the current path to the given destination using L<File::Copy>'s #pod C<copy> function. Upon success, returns the C<Path::Tiny> object for the #pod newly copied file. #pod #pod Current API available since 0.070. #pod #pod =cut # XXX do recursively for directories? sub copy { my ( $self, $dest ) = @_; require File::Copy; File::Copy::copy( $self->[PATH], $dest ) or Carp::croak("copy failed for $self to $dest: $!"); return -d $dest ? path( $dest, $self->basename ) : path($dest); } #pod =method digest #pod #pod $obj = path("/tmp/foo.txt")->digest; # SHA-256 #pod $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected #pod $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" ); #pod #pod Returns a hexadecimal digest for a file. An optional hash reference of options may #pod be given. The only option is C<chunk_size>. If C<chunk_size> is given, that many #pod bytes will be read at a time. If not provided, the entire file will be slurped #pod into memory to compute the digest. #pod #pod Any subsequent arguments are passed to the constructor for L<Digest> to select #pod an algorithm. If no arguments are given, the default is SHA-256. #pod #pod Current API available since 0.056. #pod #pod =cut sub digest { my ( $self, @opts ) = @_; my $args = ( @opts && ref $opts[0] eq 'HASH' ) ? shift @opts : {}; $args = _get_args( $args, qw/chunk_size/ ); unshift @opts, 'SHA-256' unless @opts; require Digest; my $digest = Digest->new(@opts); if ( $args->{chunk_size} ) { my $fh = $self->filehandle( { locked => 1 }, "<", ":unix" ); my $buf; $digest->add($buf) while read $fh, $buf, $args->{chunk_size}; } else { $digest->add( $self->slurp_raw ); } return $digest->hexdigest; } #pod =method dirname (deprecated) #pod #pod $name = path("/tmp/foo.txt")->dirname; # "/tmp/" #pod #pod Returns the directory portion you would get from calling #pod C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a #pod parent directory portion. Because L<File::Spec> is inconsistent, the result #pod might or might not have a trailing slash. Because of this, this method is #pod B<deprecated>. #pod #pod A better, more consistently approach is likely C<< $path->parent->stringify >>, #pod which will not have a trailing slash except for a root directory. #pod #pod Deprecated in 0.056. #pod #pod =cut sub dirname { my ($self) = @_; $self->_splitpath unless defined $self->[DIR]; return length $self->[DIR] ? $self->[DIR] : "."; } #pod =method edit, edit_raw, edit_utf8 #pod #pod path("foo.txt")->edit( \&callback, $options ); #pod path("foo.txt")->edit_utf8( \&callback ); #pod path("foo.txt")->edit_raw( \&callback ); #pod #pod These are convenience methods that allow "editing" a file using a single #pod callback argument. They slurp the file using C<slurp>, place the contents #pod inside a localized C<$_> variable, call the callback function (without #pod arguments), and then write C<$_> (presumably mutated) back to the #pod file with C<spew>. #pod #pod An optional hash reference may be used to pass options. The only option is #pod C<binmode>, which is passed to C<slurp> and C<spew>. #pod #pod C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and #pod C<spew_*> methods. #pod #pod Current API available since 0.077. #pod #pod =cut sub edit { my $self = shift; my $cb = shift; my $args = _get_args( shift, qw/binmode/ ); Carp::croak("Callback for edit() must be a code reference") unless defined($cb) && ref($cb) eq 'CODE'; local $_ = $self->slurp( exists( $args->{binmode} ) ? { binmode => $args->{binmode} } : () ); $cb->(); $self->spew( $args, $_ ); return; } # this is done long-hand to benefit from slurp_utf8 optimizations sub edit_utf8 { my ( $self, $cb ) = @_; Carp::croak("Callback for edit_utf8() must be a code reference") unless defined($cb) && ref($cb) eq 'CODE'; local $_ = $self->slurp_utf8; $cb->(); $self->spew_utf8($_); return; } sub edit_raw { $_[2] = { binmode => ":unix" }; goto &edit } #pod =method edit_lines, edit_lines_utf8, edit_lines_raw #pod #pod path("foo.txt")->edit_lines( \&callback, $options ); #pod path("foo.txt")->edit_lines_utf8( \&callback ); #pod path("foo.txt")->edit_lines_raw( \&callback ); #pod #pod These are convenience methods that allow "editing" a file's lines using a #pod single callback argument. They iterate over the file: for each line, the #pod line is put into a localized C<$_> variable, the callback function is #pod executed (without arguments) and then C<$_> is written to a temporary file. #pod When iteration is finished, the temporary file is atomically renamed over #pod the original. #pod #pod An optional hash reference may be used to pass options. The only option is #pod C<binmode>, which is passed to the method that open handles for reading and #pod writing. #pod #pod C<edit_lines_utf8> and C<edit_lines_raw> act like their respective #pod C<slurp_*> and C<spew_*> methods. #pod #pod Current API available since 0.077. #pod #pod =cut sub edit_lines { my $self = shift; my $cb = shift; my $args = _get_args( shift, qw/binmode/ ); Carp::croak("Callback for edit_lines() must be a code reference") unless defined($cb) && ref($cb) eq 'CODE'; my $binmode = $args->{binmode}; # get default binmode from caller's lexical scope (see "perldoc open") $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode; # writing need to follow the link and create the tempfile in the same # dir for later atomic rename my $resolved_path = $self->_resolve_symlinks; my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) ); my $temp_fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode ); my $in_fh = $self->filehandle( { locked => 1 }, '<', $binmode ); local $_; while (<$in_fh>) { $cb->(); $temp_fh->print($_); } close $temp_fh or $self->_throw( 'close', $temp ); close $in_fh or $self->_throw('close'); return $temp->move($resolved_path); } sub edit_lines_raw { $_[2] = { binmode => ":unix" }; goto &edit_lines } sub edit_lines_utf8 { $_[2] = { binmode => ":raw:encoding(UTF-8)" }; goto &edit_lines; } #pod =method exists, is_file, is_dir #pod #pod if ( path("/tmp")->exists ) { ... } # -e #pod if ( path("/tmp")->is_dir ) { ... } # -d #pod if ( path("/tmp")->is_file ) { ... } # -e && ! -d #pod #pod Implements file test operations, this means the file or directory actually has #pod to exist on the filesystem. Until then, it's just a path. #pod #pod B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>. #pod C<-f> means "plain file", excluding symlinks, devices, etc. that often can be #pod read just like files. #pod #pod Use C<-f> instead if you really mean to check for a plain file. #pod #pod Current API available since 0.053. #pod #pod =cut sub exists { -e $_[0]->[PATH] } sub is_file { -e $_[0]->[PATH] && !-d _ } sub is_dir { -d $_[0]->[PATH] } #pod =method filehandle #pod #pod $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode); #pod $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode); #pod $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode); #pod #pod Returns an open file handle. The C<$mode> argument must be a Perl-style #pod read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode> #pod is given, it is set during the C<open> call. #pod #pod An optional hash reference may be used to pass options. #pod #pod The C<locked> option governs file locking; if true, handles opened for writing, #pod appending or read-write are locked with C<LOCK_EX>; otherwise, they are #pod locked with C<LOCK_SH>. When using C<locked>, ">" or "+>" modes will delay #pod truncation until after the lock is acquired. #pod #pod The C<exclusive> option causes the open() call to fail if the file already #pod exists. This corresponds to the O_EXCL flag to sysopen / open(2). #pod C<exclusive> implies C<locked> and will set it for you if you forget it. #pod #pod See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar. #pod #pod Current API available since 0.066. #pod #pod =cut # Note: must put binmode on open line, not subsequent binmode() call, so things # like ":unix" actually stop perlio/crlf from being added sub filehandle { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked exclusive/ ); $args->{locked} = 1 if $args->{exclusive}; my ( $opentype, $binmode ) = @args; $opentype = "<" unless defined $opentype; Carp::croak("Invalid file mode '$opentype'") unless grep { $opentype eq $_ } qw/< +< > +> >> +>>/; $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $opentype, -1, 1 ) } unless defined $binmode; $binmode = "" unless defined $binmode; my ( $fh, $lock, $trunc ); if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) { require Fcntl; # truncating file modes shouldn't truncate until lock acquired if ( grep { $opentype eq $_ } qw( > +> ) ) { # sysopen in write mode without truncation my $flags = $opentype eq ">" ? Fcntl::O_WRONLY() : Fcntl::O_RDWR(); $flags |= Fcntl::O_CREAT(); $flags |= Fcntl::O_EXCL() if $args->{exclusive}; sysopen( $fh, $self->[PATH], $flags ) or $self->_throw("sysopen"); # fix up the binmode since sysopen() can't specify layers like # open() and binmode() can't start with just :unix like open() if ( $binmode =~ s/^:unix// ) { # eliminate pseudo-layers binmode( $fh, ":raw" ) or $self->_throw("binmode (:raw)"); # strip off real layers until only :unix is left while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { binmode( $fh, ":pop" ) or $self->_throw("binmode (:pop)"); } } # apply any remaining binmode layers if ( length $binmode ) { binmode( $fh, $binmode ) or $self->_throw("binmode ($binmode)"); } # ask for lock and truncation $lock = Fcntl::LOCK_EX(); $trunc = 1; } elsif ( $^O eq 'aix' && $opentype eq "<" ) { # AIX can only lock write handles, so upgrade to RW and LOCK_EX if # the file is writable; otherwise give up on locking. N.B. # checking -w before open to determine the open mode is an # unavoidable race condition if ( -w $self->[PATH] ) { $opentype = "+<"; $lock = Fcntl::LOCK_EX(); } } else { $lock = $opentype eq "<" ? Fcntl::LOCK_SH() : Fcntl::LOCK_EX(); } } unless ($fh) { my $mode = $opentype . $binmode; open $fh, $mode, $self->[PATH] or $self->_throw("open ($mode)"); } do { flock( $fh, $lock ) or $self->_throw("flock ($lock)") } if $lock; do { truncate( $fh, 0 ) or $self->_throw("truncate") } if $trunc; return $fh; } #pod =method is_absolute, is_relative #pod #pod if ( path("/tmp")->is_absolute ) { ... } #pod if ( path("/tmp")->is_relative ) { ... } #pod #pod Booleans for whether the path appears absolute or relative. #pod #pod Current API available since 0.001. #pod #pod =cut sub is_absolute { substr( $_[0]->dirname, 0, 1 ) eq '/' } sub is_relative { substr( $_[0]->dirname, 0, 1 ) ne '/' } #pod =method is_rootdir #pod #pod while ( ! $path->is_rootdir ) { #pod $path = $path->parent; #pod ... #pod } #pod #pod Boolean for whether the path is the root directory of the volume. I.e. the #pod C<dirname> is C<q[/]> and the C<basename> is C<q[]>. #pod #pod This works even on C<MSWin32> with drives and UNC volumes: #pod #pod path("C:/")->is_rootdir; # true #pod path("//server/share/")->is_rootdir; #true #pod #pod Current API available since 0.038. #pod #pod =cut sub is_rootdir { my ($self) = @_; $self->_splitpath unless defined $self->[DIR]; return $self->[DIR] eq '/' && $self->[FILE] eq ''; } #pod =method iterator #pod #pod $iter = path("/tmp")->iterator( \%options ); #pod #pod Returns a code reference that walks a directory lazily. Each invocation #pod returns a C<Path::Tiny> object or undef when the iterator is exhausted. #pod #pod $iter = path("/tmp")->iterator; #pod while ( $path = $iter->() ) { #pod ... #pod } #pod #pod The current and parent directory entries ("." and "..") will not #pod be included. #pod #pod If the C<recurse> option is true, the iterator will walk the directory #pod recursively, breadth-first. If the C<follow_symlinks> option is also true, #pod directory links will be followed recursively. There is no protection against #pod loops when following links. If a directory is not readable, it will not be #pod followed. #pod #pod The default is the same as: #pod #pod $iter = path("/tmp")->iterator( { #pod recurse => 0, #pod follow_symlinks => 0, #pod } ); #pod #pod For a more powerful, recursive iterator with built-in loop avoidance, see #pod L<Path::Iterator::Rule>. #pod #pod See also L</visit>. #pod #pod Current API available since 0.016. #pod #pod =cut sub iterator { my $self = shift; my $args = _get_args( shift, qw/recurse follow_symlinks/ ); my @dirs = $self; my $current; return sub { my $next; while (@dirs) { if ( ref $dirs[0] eq 'Path::Tiny' ) { if ( !-r $dirs[0] ) { # Directory is missing or not readable, so skip it. There # is still a race condition possible between the check and # the opendir, but we can't easily differentiate between # error cases that are OK to skip and those that we want # to be exceptions, so we live with the race and let opendir # be fatal. shift @dirs and next; } $current = $dirs[0]; my $dh; opendir( $dh, $current->[PATH] ) or $self->_throw( 'opendir', $current->[PATH] ); $dirs[0] = $dh; if ( -l $current->[PATH] && !$args->{follow_symlinks} ) { # Symlink attack! It was a real dir, but is now a symlink! # N.B. we check *after* opendir so the attacker has to win # two races: replace dir with symlink before opendir and # replace symlink with dir before -l check above shift @dirs and next; } } while ( defined( $next = readdir $dirs[0] ) ) { next if $next eq '.' || $next eq '..'; my $path = $current->child($next); push @dirs, $path if $args->{recurse} && -d $path && !( !$args->{follow_symlinks} && -l $path ); return $path; } shift @dirs; } return; }; } #pod =method lines, lines_raw, lines_utf8 #pod #pod @contents = path("/tmp/foo.txt")->lines; #pod @contents = path("/tmp/foo.txt")->lines(\%options); #pod @contents = path("/tmp/foo.txt")->lines_raw; #pod @contents = path("/tmp/foo.txt")->lines_utf8; #pod #pod @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } ); #pod #pod Returns a list of lines from a file. Optionally takes a hash-reference of #pod options. Valid options are C<binmode>, C<count> and C<chomp>. #pod #pod If C<binmode> is provided, it will be set on the handle prior to reading. #pod #pod If a positive C<count> is provided, that many lines will be returned from the #pod start of the file. If a negative C<count> is provided, the entire file will be #pod read, but only C<abs(count)> will be kept and returned. If C<abs(count)> #pod exceeds the number of lines in the file, all lines will be returned. #pod #pod If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or #pod C<LF>) will be removed from the lines returned. #pod #pod Because the return is a list, C<lines> in scalar context will return the number #pod of lines (and throw away the data). #pod #pod $number_of_lines = path("/tmp/foo.txt")->lines; #pod #pod C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>. We use C<:raw> #pod instead of C<:unix> so PerlIO buffering can manage reading by line. #pod #pod C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)> #pod (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw #pod UTF-8 slurp will be done and then the lines will be split. This is #pod actually faster than relying on C<:encoding(UTF-8)>, though a bit memory #pod intensive. If memory use is a concern, consider C<openr_utf8> and #pod iterating directly on the handle. #pod #pod Current API available since 0.065. #pod #pod =cut sub lines { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode; my $fh = $self->filehandle( { locked => 1 }, "<", $binmode ); my $chomp = $args->{chomp}; # XXX more efficient to read @lines then chomp(@lines) vs map? if ( $args->{count} ) { my ( $counter, $mod, @result ) = ( 0, abs( $args->{count} ) ); while ( my $line = <$fh> ) { $line =~ s/(?:\x{0d}?\x{0a}|\x{0d})\z// if $chomp; $result[ $counter++ ] = $line; # for positive count, terminate after right number of lines last if $counter == $args->{count}; # for negative count, eventually wrap around in the result array $counter %= $mod; } # reorder results if full and wrapped somewhere in the middle splice( @result, 0, 0, splice( @result, $counter ) ) if @result == $mod && $counter % $mod; return @result; } elsif ($chomp) { return map { s/(?:\x{0d}?\x{0a}|\x{0d})\z//; $_ } <$fh>; ## no critic } else { return wantarray ? <$fh> : ( my $count =()= <$fh> ); } } sub lines_raw { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); if ( $args->{chomp} && !$args->{count} ) { return split /\n/, slurp_raw($self); ## no critic } else { $args->{binmode} = ":raw"; return lines( $self, $args ); } } my $CRLF = qr/(?:\x{0d}?\x{0a}|\x{0d})/; sub lines_utf8 { my $self = shift; my $args = _get_args( shift, qw/binmode chomp count/ ); if ( ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) && $args->{chomp} && !$args->{count} ) { my $slurp = slurp_utf8($self); $slurp =~ s/$CRLF\z//; # like chomp, but full CR?LF|CR return split $CRLF, $slurp, -1; ## no critic } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $args->{binmode} = ":unix:utf8_strict"; return lines( $self, $args ); } else { $args->{binmode} = ":raw:encoding(UTF-8)"; return lines( $self, $args ); } } #pod =method mkpath #pod #pod path("foo/bar/baz")->mkpath; #pod path("foo/bar/baz")->mkpath( \%options ); #pod #pod Like calling C<make_path> from L<File::Path>. An optional hash reference #pod is passed through to C<make_path>. Errors will be trapped and an exception #pod thrown. Returns the list of directories created or an empty list if #pod the directories already exist, just like C<make_path>. #pod #pod Current API available since 0.001. #pod #pod =cut sub mkpath { my ( $self, $args ) = @_; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; require File::Path; my @dirs = File::Path::make_path( $self->[PATH], $args ); if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; Carp::croak("mkpath failed for $file: $message"); } return @dirs; } #pod =method move #pod #pod path("foo.txt")->move("bar.txt"); #pod #pod Move the current path to the given destination path using Perl's #pod built-in L<rename|perlfunc/rename> function. Returns the result #pod of the C<rename> function (except it throws an exception if it fails). #pod #pod Current API available since 0.001. #pod #pod =cut sub move { my ( $self, $dst ) = @_; return rename( $self->[PATH], $dst ) || $self->_throw( 'rename', $self->[PATH] . "' -> '$dst" ); } #pod =method openr, openw, openrw, opena #pod #pod $fh = path("foo.txt")->openr($binmode); # read #pod $fh = path("foo.txt")->openr_raw; #pod $fh = path("foo.txt")->openr_utf8; #pod #pod $fh = path("foo.txt")->openw($binmode); # write #pod $fh = path("foo.txt")->openw_raw; #pod $fh = path("foo.txt")->openw_utf8; #pod #pod $fh = path("foo.txt")->opena($binmode); # append #pod $fh = path("foo.txt")->opena_raw; #pod $fh = path("foo.txt")->opena_utf8; #pod #pod $fh = path("foo.txt")->openrw($binmode); # read/write #pod $fh = path("foo.txt")->openrw_raw; #pod $fh = path("foo.txt")->openrw_utf8; #pod #pod Returns a file handle opened in the specified mode. The C<openr> style methods #pod take a single C<binmode> argument. All of the C<open*> methods have #pod C<open*_raw> and C<open*_utf8> equivalents that use C<:raw> and #pod C<:raw:encoding(UTF-8)>, respectively. #pod #pod An optional hash reference may be used to pass options. The only option is #pod C<locked>. If true, handles opened for writing, appending or read-write are #pod locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>. #pod #pod $fh = path("foo.txt")->openrw_utf8( { locked => 1 } ); #pod #pod See L</filehandle> for more on locking. #pod #pod Current API available since 0.011. #pod #pod =cut # map method names to corresponding open mode my %opens = ( opena => ">>", openr => "<", openw => ">", openrw => "+<" ); while ( my ( $k, $v ) = each %opens ) { no strict 'refs'; # must check for lexical IO mode hint *{$k} = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); my ($binmode) = @args; $binmode = ( ( caller(0) )[10] || {} )->{ 'open' . substr( $v, -1, 1 ) } unless defined $binmode; $self->filehandle( $args, $v, $binmode ); }; *{ $k . "_raw" } = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); $self->filehandle( $args, $v, ":raw" ); }; *{ $k . "_utf8" } = sub { my ( $self, @args ) = @_; my $args = ( @args && ref $args[0] eq 'HASH' ) ? shift @args : {}; $args = _get_args( $args, qw/locked/ ); $self->filehandle( $args, $v, ":raw:encoding(UTF-8)" ); }; } #pod =method parent #pod #pod $parent = path("foo/bar/baz")->parent; # foo/bar #pod $parent = path("foo/wibble.txt")->parent; # foo #pod #pod $parent = path("foo/bar/baz")->parent(2); # foo #pod #pod Returns a C<Path::Tiny> object corresponding to the parent directory of the #pod original directory or file. An optional positive integer argument is the number #pod of parent directories upwards to return. C<parent> by itself is equivalent to #pod C<parent(1)>. #pod #pod Current API available since 0.014. #pod #pod =cut # XXX this is ugly and coverage is incomplete. I think it's there for windows # so need to check coverage there and compare sub parent { my ( $self, $level ) = @_; $level = 1 unless defined $level && $level > 0; $self->_splitpath unless defined $self->[FILE]; my $parent; if ( length $self->[FILE] ) { if ( $self->[FILE] eq '.' || $self->[FILE] eq ".." ) { $parent = path( $self->[PATH] . "/.." ); } else { $parent = path( _non_empty( $self->[VOL] . $self->[DIR] ) ); } } elsif ( length $self->[DIR] ) { # because of symlinks, any internal updir requires us to # just add more updirs at the end if ( $self->[DIR] =~ m{(?:^\.\./|/\.\./|/\.\.\z)} ) { $parent = path( $self->[VOL] . $self->[DIR] . "/.." ); } else { ( my $dir = $self->[DIR] ) =~ s{/[^\/]+/\z}{/}; $parent = path( $self->[VOL] . $dir ); } } else { $parent = path( _non_empty( $self->[VOL] ) ); } return $level == 1 ? $parent : $parent->parent( $level - 1 ); } sub _non_empty { my ($string) = shift; return ( ( defined($string) && length($string) ) ? $string : "." ); } #pod =method realpath #pod #pod $real = path("/baz/foo/../bar")->realpath; #pod $real = path("foo/../bar")->realpath; #pod #pod Returns a new C<Path::Tiny> object with all symbolic links and upward directory #pod parts resolved using L<Cwd>'s C<realpath>. Compared to C<absolute>, this is #pod more expensive as it must actually consult the filesystem. #pod #pod If the parent path can't be resolved (e.g. if it includes directories that #pod don't exist), an exception will be thrown: #pod #pod $real = path("doesnt_exist/foo")->realpath; # dies #pod #pod However, if the parent path exists and only the last component (e.g. filename) #pod doesn't exist, the realpath will be the realpath of the parent plus the #pod non-existent last component: #pod #pod $real = path("./aasdlfasdlf")->realpath; # works #pod #pod The underlying L<Cwd> module usually worked this way on Unix, but died on #pod Windows (and some Unixes) if the full path didn't exist. As of version 0.064, #pod it's safe to use anywhere. #pod #pod Current API available since 0.001. #pod #pod =cut # Win32 and some Unixes need parent path resolved separately so realpath # doesn't throw an error resolving non-existent basename sub realpath { my $self = shift; $self = $self->_resolve_symlinks; require Cwd; $self->_splitpath if !defined $self->[FILE]; my $check_parent = length $self->[FILE] && $self->[FILE] ne '.' && $self->[FILE] ne '..'; my $realpath = eval { # pure-perl Cwd can carp local $SIG{__WARN__} = sub { }; Cwd::realpath( $check_parent ? $self->parent->[PATH] : $self->[PATH] ); }; # parent realpath must exist; not all Cwd::realpath will error if it doesn't $self->_throw("resolving realpath") unless defined $realpath && length $realpath && -e $realpath; return ( $check_parent ? path( $realpath, $self->[FILE] ) : path($realpath) ); } #pod =method relative #pod #pod $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar #pod #pod Returns a C<Path::Tiny> object with a path relative to a new base path #pod given as an argument. If no argument is given, the current directory will #pod be used as the new base path. #pod #pod If either path is already relative, it will be made absolute based on the #pod current directly before determining the new relative path. #pod #pod The algorithm is roughly as follows: #pod #pod =for :list #pod * If the original and new base path are on different volumes, an exception #pod will be thrown. #pod * If the original and new base are identical, the relative path is C<".">. #pod * If the new base subsumes the original, the relative path is the original #pod path with the new base chopped off the front #pod * If the new base does not subsume the original, a common prefix path is #pod determined (possibly the root directory) and the relative path will #pod consist of updirs (C<"..">) to reach the common prefix, followed by the #pod original path less the common prefix. #pod #pod Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based #pod on a common prefix takes into account symlinks that could affect the updir #pod process. Given an original path "/A/B" and a new base "/A/C", #pod (where "A", "B" and "C" could each have multiple path components): #pod #pod =for :list #pod * Symlinks in "A" don't change the result unless the last component of A is #pod a symlink and the first component of "C" is an updir. #pod * Symlinks in "B" don't change the result and will exist in the result as #pod given. #pod * Symlinks and updirs in "C" must be resolved to actual paths, taking into #pod account the possibility that not all path components might exist on the #pod filesystem. #pod #pod Current API available since 0.001. New algorithm (that accounts for #pod symlinks) available since 0.079. #pod #pod =cut sub relative { my ( $self, $base ) = @_; $base = path( defined $base && length $base ? $base : '.' ); # relative paths must be converted to absolute first $self = $self->absolute if $self->is_relative; $base = $base->absolute if $base->is_relative; # normalize volumes if they exist $self = $self->absolute if !length $self->volume && length $base->volume; $base = $base->absolute if length $self->volume && !length $base->volume; # can't make paths relative across volumes if ( !_same( $self->volume, $base->volume ) ) { Carp::croak("relative() can't cross volumes: '$self' vs '$base'"); } # if same absolute path, relative is current directory return path(".") if _same( $self->[PATH], $base->[PATH] ); # if base is a prefix of self, chop prefix off self if ( $base->subsumes($self) ) { $base = "" if $base->is_rootdir; my $relative = "$self"; $relative =~ s{\A\Q$base/}{}; return path($relative); } # base is not a prefix, so must find a common prefix (even if root) my ( @common, @self_parts, @base_parts ); @base_parts = split /\//, $base->_just_filepath; # if self is rootdir, then common directory is root (shown as empty # string for later joins); otherwise, must be computed from path parts. if ( $self->is_rootdir ) { @common = (""); shift @base_parts; } else { @self_parts = split /\//, $self->_just_filepath; while ( @self_parts && @base_parts && _same( $self_parts[0], $base_parts[0] ) ) { push @common, shift @base_parts; shift @self_parts; } } # if there are any symlinks from common to base, we have a problem, as # you can't guarantee that updir from base reaches the common prefix; # we must resolve symlinks and try again; likewise, any updirs are # a problem as it throws off calculation of updirs needed to get from # self's path to the common prefix. if ( my $new_base = $self->_resolve_between( \@common, \@base_parts ) ) { return $self->relative($new_base); } # otherwise, symlinks in common or from common to A don't matter as # those don't involve updirs my @new_path = ( ("..") x ( 0+ @base_parts ), @self_parts ); return path(@new_path); } sub _just_filepath { my $self = shift; my $self_vol = $self->volume; return "$self" if !length $self_vol; ( my $self_path = "$self" ) =~ s{\A\Q$self_vol}{}; return $self_path; } sub _resolve_between { my ( $self, $common, $base ) = @_; my $path = $self->volume . join( "/", @$common ); my $changed = 0; for my $p (@$base) { $path .= "/$p"; if ( $p eq '..' ) { $changed = 1; if ( -e $path ) { $path = path($path)->realpath->[PATH]; } else { $path =~ s{/[^/]+/..\z}{/}; } } if ( -l $path ) { $changed = 1; $path = path($path)->realpath->[PATH]; } } return $changed ? path($path) : undef; } #pod =method remove #pod #pod path("foo.txt")->remove; #pod #pod This is just like C<unlink>, except for its error handling: if the path does #pod not exist, it returns false; if deleting the file fails, it throws an #pod exception. #pod #pod Current API available since 0.012. #pod #pod =cut sub remove { my $self = shift; return 0 if !-e $self->[PATH] && !-l $self->[PATH]; return unlink( $self->[PATH] ) || $self->_throw('unlink'); } #pod =method remove_tree #pod #pod # directory #pod path("foo/bar/baz")->remove_tree; #pod path("foo/bar/baz")->remove_tree( \%options ); #pod path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove #pod #pod Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode. #pod An optional hash reference is passed through to C<remove_tree>. Errors will be #pod trapped and an exception thrown. Returns the number of directories deleted, #pod just like C<remove_tree>. #pod #pod If you want to remove a directory only if it is empty, use the built-in #pod C<rmdir> function instead. #pod #pod rmdir path("foo/bar/baz/"); #pod #pod Current API available since 0.013. #pod #pod =cut sub remove_tree { my ( $self, $args ) = @_; return 0 if !-e $self->[PATH] && !-l $self->[PATH]; $args = {} unless ref $args eq 'HASH'; my $err; $args->{error} = \$err unless defined $args->{error}; $args->{safe} = 1 unless defined $args->{safe}; require File::Path; my $count = File::Path::remove_tree( $self->[PATH], $args ); if ( $err && @$err ) { my ( $file, $message ) = %{ $err->[0] }; Carp::croak("remove_tree failed for $file: $message"); } return $count; } #pod =method sibling #pod #pod $foo = path("/tmp/foo.txt"); #pod $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt #pod $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt #pod #pod Returns a new C<Path::Tiny> object relative to the parent of the original. #pod This is slightly more efficient than C<< $path->parent->child(...) >>. #pod #pod Current API available since 0.058. #pod #pod =cut sub sibling { my $self = shift; return path( $self->parent->[PATH], @_ ); } #pod =method slurp, slurp_raw, slurp_utf8 #pod #pod $data = path("foo.txt")->slurp; #pod $data = path("foo.txt")->slurp( {binmode => ":raw"} ); #pod $data = path("foo.txt")->slurp_raw; #pod $data = path("foo.txt")->slurp_utf8; #pod #pod Reads file contents into a scalar. Takes an optional hash reference which may #pod be used to pass options. The only available option is C<binmode>, which is #pod passed to C<binmode()> on the handle used for reading. #pod #pod C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for #pod a fast, unbuffered, raw read. #pod #pod C<slurp_utf8> is like C<slurp> with a C<binmode> of #pod C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> #pod 0.58+ is installed, a raw slurp will be done instead and the result decoded #pod with C<Unicode::UTF8>. This is just as strict and is roughly an order of #pod magnitude faster than using C<:encoding(UTF-8)>. #pod #pod B<Note>: C<slurp> and friends lock the filehandle before slurping. If #pod you plan to slurp from a file created with L<File::Temp>, be sure to #pod close other handles or open without locking to avoid a deadlock: #pod #pod my $tempfile = File::Temp->new(EXLOCK => 0); #pod my $guts = path($tempfile)->slurp; #pod #pod Current API available since 0.004. #pod #pod =cut sub slurp { my $self = shift; my $args = _get_args( shift, qw/binmode/ ); my $binmode = $args->{binmode}; $binmode = ( ( caller(0) )[10] || {} )->{'open<'} unless defined $binmode; my $fh = $self->filehandle( { locked => 1 }, "<", $binmode ); if ( ( defined($binmode) ? $binmode : "" ) eq ":unix" and my $size = -s $fh ) { my $buf; read $fh, $buf, $size; # File::Slurp in a nutshell return $buf; } else { local $/; return scalar <$fh>; } } sub slurp_raw { $_[1] = { binmode => ":unix" }; goto &slurp } sub slurp_utf8 { if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { return Unicode::UTF8::decode_utf8( slurp( $_[0], { binmode => ":unix" } ) ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { $_[1] = { binmode => ":unix:utf8_strict" }; goto &slurp; } else { $_[1] = { binmode => ":raw:encoding(UTF-8)" }; goto &slurp; } } #pod =method spew, spew_raw, spew_utf8 #pod #pod path("foo.txt")->spew(@data); #pod path("foo.txt")->spew(\@data); #pod path("foo.txt")->spew({binmode => ":raw"}, @data); #pod path("foo.txt")->spew_raw(@data); #pod path("foo.txt")->spew_utf8(@data); #pod #pod Writes data to a file atomically. The file is written to a temporary file in #pod the same directory, then renamed over the original. An optional hash reference #pod may be used to pass options. The only option is C<binmode>, which is passed to #pod C<binmode()> on the handle used for writing. #pod #pod C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast, #pod unbuffered, raw write. #pod #pod C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)> #pod (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw #pod spew will be done instead on the data encoded with C<Unicode::UTF8>. #pod #pod B<NOTE>: because the file is written to a temporary file and then renamed, the #pod new file will wind up with permissions based on your current umask. This is a #pod feature to protect you from a race condition that would otherwise give #pod different permissions than you might expect. If you really want to keep the #pod original mode flags, use L</append> with the C<truncate> option. #pod #pod Current API available since 0.011. #pod #pod =cut # XXX add "unsafe" option to disable flocking and atomic? Check benchmarks on append() first. sub spew { my ( $self, @data ) = @_; my $args = ( @data && ref $data[0] eq 'HASH' ) ? shift @data : {}; $args = _get_args( $args, qw/binmode/ ); my $binmode = $args->{binmode}; # get default binmode from caller's lexical scope (see "perldoc open") $binmode = ( ( caller(0) )[10] || {} )->{'open>'} unless defined $binmode; # spewing need to follow the link # and create the tempfile in the same dir my $resolved_path = $self->_resolve_symlinks; my $temp = path( $resolved_path . $$ . int( rand( 2**31 ) ) ); my $fh = $temp->filehandle( { exclusive => 1, locked => 1 }, ">", $binmode ); print {$fh} map { ref eq 'ARRAY' ? @$_ : $_ } @data; close $fh or $self->_throw( 'close', $temp->[PATH] ); return $temp->move($resolved_path); } sub spew_raw { splice @_, 1, 0, { binmode => ":unix" }; goto &spew } sub spew_utf8 { if ( defined($HAS_UU) ? $HAS_UU : ( $HAS_UU = _check_UU() ) ) { my $self = shift; spew( $self, { binmode => ":unix" }, map { Unicode::UTF8::encode_utf8($_) } map { ref eq 'ARRAY' ? @$_ : $_ } @_ ); } elsif ( defined($HAS_PU) ? $HAS_PU : ( $HAS_PU = _check_PU() ) ) { splice @_, 1, 0, { binmode => ":unix:utf8_strict" }; goto &spew; } else { splice @_, 1, 0, { binmode => ":unix:encoding(UTF-8)" }; goto &spew; } } #pod =method stat, lstat #pod #pod $stat = path("foo.txt")->stat; #pod $stat = path("/some/symlink")->lstat; #pod #pod Like calling C<stat> or C<lstat> from L<File::stat>. #pod #pod Current API available since 0.001. #pod #pod =cut # XXX break out individual stat() components as subs? sub stat { my $self = shift; require File::stat; return File::stat::stat( $self->[PATH] ) || $self->_throw('stat'); } sub lstat { my $self = shift; require File::stat; return File::stat::lstat( $self->[PATH] ) || $self->_throw('lstat'); } #pod =method stringify #pod #pod $path = path("foo.txt"); #pod say $path->stringify; # same as "$path" #pod #pod Returns a string representation of the path. Unlike C<canonpath>, this method #pod returns the path standardized with Unix-style C</> directory separators. #pod #pod Current API available since 0.001. #pod #pod =cut sub stringify { $_[0]->[PATH] } #pod =method subsumes #pod #pod path("foo/bar")->subsumes("foo/bar/baz"); # true #pod path("/foo/bar")->subsumes("/foo/baz"); # false #pod #pod Returns true if the first path is a prefix of the second path at a directory #pod boundary. #pod #pod This B<does not> resolve parent directory entries (C<..>) or symlinks: #pod #pod path("foo/bar")->subsumes("foo/bar/../baz"); # true #pod #pod If such things are important to you, ensure that both paths are resolved to #pod the filesystem with C<realpath>: #pod #pod my $p1 = path("foo/bar")->realpath; #pod my $p2 = path("foo/bar/../baz")->realpath; #pod if ( $p1->subsumes($p2) ) { ... } #pod #pod Current API available since 0.048. #pod #pod =cut sub subsumes { my $self = shift; Carp::croak("subsumes() requires a defined, positive-length argument") unless defined $_[0]; my $other = path(shift); # normalize absolute vs relative if ( $self->is_absolute && !$other->is_absolute ) { $other = $other->absolute; } elsif ( $other->is_absolute && !$self->is_absolute ) { $self = $self->absolute; } # normalize volume vs non-volume; do this after absolute path # adjustments above since that might add volumes already if ( length $self->volume && !length $other->volume ) { $other = $other->absolute; } elsif ( length $other->volume && !length $self->volume ) { $self = $self->absolute; } if ( $self->[PATH] eq '.' ) { return !!1; # cwd subsumes everything relative } elsif ( $self->is_rootdir ) { # a root directory ("/", "c:/") already ends with a separator return $other->[PATH] =~ m{^\Q$self->[PATH]\E}; } else { # exact match or prefix breaking at a separator return $other->[PATH] =~ m{^\Q$self->[PATH]\E(?:/|\z)}; } } #pod =method touch #pod #pod path("foo.txt")->touch; #pod path("foo.txt")->touch($epoch_secs); #pod #pod Like the Unix C<touch> utility. Creates the file if it doesn't exist, or else #pod changes the modification and access times to the current time. If the first #pod argument is the epoch seconds then it will be used. #pod #pod Returns the path object so it can be easily chained with other methods: #pod #pod # won't die if foo.txt doesn't exist #pod $content = path("foo.txt")->touch->slurp; #pod #pod Current API available since 0.015. #pod #pod =cut sub touch { my ( $self, $epoch ) = @_; if ( !-e $self->[PATH] ) { my $fh = $self->openw; close $fh or $self->_throw('close'); } if ( defined $epoch ) { utime $epoch, $epoch, $self->[PATH] or $self->_throw("utime ($epoch)"); } else { # literal undef prevents warnings :-( utime undef, undef, $self->[PATH] or $self->_throw("utime ()"); } return $self; } #pod =method touchpath #pod #pod path("bar/baz/foo.txt")->touchpath; #pod #pod Combines C<mkpath> and C<touch>. Creates the parent directory if it doesn't exist, #pod before touching the file. Returns the path object like C<touch> does. #pod #pod Current API available since 0.022. #pod #pod =cut sub touchpath { my ($self) = @_; my $parent = $self->parent; $parent->mkpath unless $parent->exists; $self->touch; } #pod =method visit #pod #pod path("/tmp")->visit( \&callback, \%options ); #pod #pod Executes a callback for each child of a directory. It returns a hash #pod reference with any state accumulated during iteration. #pod #pod The options are the same as for L</iterator> (which it uses internally): #pod C<recurse> and C<follow_symlinks>. Both default to false. #pod #pod The callback function will receive a C<Path::Tiny> object as the first argument #pod and a hash reference to accumulate state as the second argument. For example: #pod #pod # collect files sizes #pod my $sizes = path("/tmp")->visit( #pod sub { #pod my ($path, $state) = @_; #pod return if $path->is_dir; #pod $state->{$path} = -s $path; #pod }, #pod { recurse => 1 } #pod ); #pod #pod For convenience, the C<Path::Tiny> object will also be locally aliased as the #pod C<$_> global variable: #pod #pod # print paths matching /foo/ #pod path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} ); #pod #pod If the callback returns a B<reference> to a false scalar value, iteration will #pod terminate. This is not the same as "pruning" a directory search; this just #pod stops all iteration and returns the state hash reference. #pod #pod # find up to 10 files larger than 100K #pod my $files = path("/tmp")->visit( #pod sub { #pod my ($path, $state) = @_; #pod $state->{$path}++ if -s $path > 102400 #pod return \0 if keys %$state == 10; #pod }, #pod { recurse => 1 } #pod ); #pod #pod If you want more flexible iteration, use a module like L<Path::Iterator::Rule>. #pod #pod Current API available since 0.062. #pod #pod =cut sub visit { my $self = shift; my $cb = shift; my $args = _get_args( shift, qw/recurse follow_symlinks/ ); Carp::croak("Callback for visit() must be a code reference") unless defined($cb) && ref($cb) eq 'CODE'; my $next = $self->iterator($args); my $state = {}; while ( my $file = $next->() ) { local $_ = $file; my $r = $cb->( $file, $state ); last if ref($r) eq 'SCALAR' && !$$r; } return $state; } #pod =method volume #pod #pod $vol = path("/tmp/foo.txt")->volume; # "" #pod $vol = path("C:/tmp/foo.txt")->volume; # "C:" #pod #pod Returns the volume portion of the path. This is equivalent #pod to what L<File::Spec> would give from C<splitpath> and thus #pod usually is the empty string on Unix-like operating systems or the #pod drive letter for an absolute path on C<MSWin32>. #pod #pod Current API available since 0.001. #pod #pod =cut sub volume { my ($self) = @_; $self->_splitpath unless defined $self->[VOL]; return $self->[VOL]; } package Path::Tiny::Error; our @CARP_NOT = qw/Path::Tiny/; use overload ( q{""} => sub { (shift)->{msg} }, fallback => 1 ); sub throw { my ( $class, $op, $file, $err ) = @_; chomp( my $trace = Carp::shortmess ); my $msg = "Error $op on '$file': $err$trace\n"; die bless { op => $op, file => $file, err => $err, msg => $msg }, $class; } 1; # vim: ts=4 sts=4 sw=4 et: __END__ =pod =encoding UTF-8 =head1 NAME Path::Tiny - File path utility =head1 VERSION version 0.118 =head1 SYNOPSIS use Path::Tiny; # creating Path::Tiny objects $dir = path("/tmp"); $foo = path("foo.txt"); $subdir = $dir->child("foo"); $bar = $subdir->child("bar.txt"); # stringifies as cleaned up path $file = path("./foo.txt"); print $file; # "foo.txt" # reading files $guts = $file->slurp; $guts = $file->slurp_utf8; @lines = $file->lines; @lines = $file->lines_utf8; ($head) = $file->lines( {count => 1} ); ($tail) = $file->lines( {count => -1} ); # writing files $bar->spew( @data ); $bar->spew_utf8( @data ); # reading directories for ( $dir->children ) { ... } $iter = $dir->iterator; while ( my $next = $iter->() ) { ... } =head1 DESCRIPTION This module provides a small, fast utility for working with file paths. It is friendlier to use than L<File::Spec> and provides easy access to functions from several other core file handling modules. It aims to be smaller and faster than many alternatives on CPAN, while helping people do many common things in consistent and less error-prone ways. Path::Tiny does not try to work for anything except Unix-like and Win32 platforms. Even then, it might break if you try something particularly obscure or tortuous. (Quick! What does this mean: C<< ///../../..//./././a//b/.././c/././ >>? And how does it differ on Win32?) All paths are forced to have Unix-style forward slashes. Stringifying the object gives you back the path (after some clean up). File input/output methods C<flock> handles before reading or writing, as appropriate (if supported by the platform and/or filesystem). The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw mode. On Windows, that means they will not have CRLF translation from the C<:crlf> IO layer. Installing L<Unicode::UTF8> 0.58 or later will speed up C<*_utf8> situations in many cases and is highly recommended. Alternatively, installing L<PerlIO::utf8_strict> 0.003 or later will be used in place of the default C<:encoding(UTF-8)>. This module depends heavily on PerlIO layers for correct operation and thus requires Perl 5.008001 or later. =head1 CONSTRUCTORS =head2 path $path = path("foo/bar"); $path = path("/tmp", "file.txt"); # list $path = path("."); # cwd $path = path("~user/file.txt"); # tilde processing Constructs a C<Path::Tiny> object. It doesn't matter if you give a file or directory path. It's still up to you to call directory-like methods only on directories and file-like methods only on files. This function is exported automatically by default. The first argument must be defined and have non-zero length or an exception will be thrown. This prevents subtle, dangerous errors with code like C<< path( maybe_undef() )->remove_tree >>. If the first component of the path is a tilde ('~') then the component will be replaced with the output of C<glob('~')>. If the first component of the path is a tilde followed by a user name then the component will be replaced with output of C<glob('~username')>. Behaviour for non-existent users depends on the output of C<glob> on the system. On Windows, if the path consists of a drive identifier without a path component (C<C:> or C<D:>), it will be expanded to the absolute path of the current directory on that volume using C<Cwd::getdcwd()>. If called with a single C<Path::Tiny> argument, the original is returned unless the original is holding a temporary file or directory reference in which case a stringified copy is made. $path = path("foo/bar"); $temp = Path::Tiny->tempfile; $p2 = path($path); # like $p2 = $path $t2 = path($temp); # like $t2 = path( "$temp" ) This optimizes copies without proliferating references unexpectedly if a copy is made by code outside your control. Current API available since 0.017. =head2 new $path = Path::Tiny->new("foo/bar"); This is just like C<path>, but with method call overhead. (Why would you do that?) Current API available since 0.001. =head2 cwd $path = Path::Tiny->cwd; # path( Cwd::getcwd ) $path = cwd; # optional export Gives you the absolute path to the current directory as a C<Path::Tiny> object. This is slightly faster than C<< path(".")->absolute >>. C<cwd> may be exported on request and used as a function instead of as a method. Current API available since 0.018. =head2 rootdir $path = Path::Tiny->rootdir; # / $path = rootdir; # optional export Gives you C<< File::Spec->rootdir >> as a C<Path::Tiny> object if you're too picky for C<path("/")>. C<rootdir> may be exported on request and used as a function instead of as a method. Current API available since 0.018. =head2 tempfile, tempdir $temp = Path::Tiny->tempfile( @options ); $temp = Path::Tiny->tempdir( @options ); $temp = tempfile( @options ); # optional export $temp = tempdir( @options ); # optional export C<tempfile> passes the options to C<< File::Temp->new >> and returns a C<Path::Tiny> object with the file name. The C<TMPDIR> option is enabled by default. The resulting C<File::Temp> object is cached. When the C<Path::Tiny> object is destroyed, the C<File::Temp> object will be as well. C<File::Temp> annoyingly requires you to specify a custom template in slightly different ways depending on which function or method you call, but C<Path::Tiny> lets you ignore that and can take either a leading template or a C<TEMPLATE> option and does the right thing. $temp = Path::Tiny->tempfile( "customXXXXXXXX" ); # ok $temp = Path::Tiny->tempfile( TEMPLATE => "customXXXXXXXX" ); # ok The tempfile path object will be normalized to have an absolute path, even if created in a relative directory using C<DIR>. If you want it to have the C<realpath> instead, pass a leading options hash like this: $real_temp = tempfile({realpath => 1}, @options); C<tempdir> is just like C<tempfile>, except it calls C<< File::Temp->newdir >> instead. Both C<tempfile> and C<tempdir> may be exported on request and used as functions instead of as methods. B<Note>: for tempfiles, the filehandles from File::Temp are closed and not reused. This is not as secure as using File::Temp handles directly, but is less prone to deadlocks or access problems on some platforms. Think of what C<Path::Tiny> gives you to be just a temporary file B<name> that gets cleaned up. B<Note 2>: if you don't want these cleaned up automatically when the object is destroyed, File::Temp requires different options for directories and files. Use C<< CLEANUP => 0 >> for directories and C<< UNLINK => 0 >> for files. B<Note 3>: Don't lose the temporary object by chaining a method call instead of storing it: my $lost = tempdir()->child("foo"); # tempdir cleaned up right away B<Note 4>: The cached object may be accessed with the L</cached_temp> method. Keeping a reference to, or modifying the cached object may break the behavior documented above and is not supported. Use at your own risk. Current API available since 0.097. =head1 METHODS =head2 absolute $abs = path("foo/bar")->absolute; $abs = path("foo/bar")->absolute("/tmp"); Returns a new C<Path::Tiny> object with an absolute path (or itself if already absolute). If no argument is given, the current directory is used as the absolute base path. If an argument is given, it will be converted to an absolute path (if it is not already) and used as the absolute base path. This will not resolve upward directories ("foo/../bar") unless C<canonpath> in L<File::Spec> would normally do so on your platform. If you need them resolved, you must call the more expensive C<realpath> method instead. On Windows, an absolute path without a volume component will have it added based on the current drive. Current API available since 0.101. =head2 append, append_raw, append_utf8 path("foo.txt")->append(@data); path("foo.txt")->append(\@data); path("foo.txt")->append({binmode => ":raw"}, @data); path("foo.txt")->append_raw(@data); path("foo.txt")->append_utf8(@data); Appends data to a file. The file is locked with C<flock> prior to writing and closed afterwards. An optional hash reference may be used to pass options. Valid options are: =over 4 =item * C<binmode>: passed to C<binmode()> on the handle used for writing. =item * C<truncate>: truncates the file after locking and before appending =back The C<truncate> option is a way to replace the contents of a file B<in place>, unlike L</spew> which writes to a temporary file and then replaces the original (if it exists). C<append_raw> is like C<append> with a C<binmode> of C<:unix> for fast, unbuffered, raw write. C<append_utf8> is like C<append> with a C<binmode> of C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw append will be done instead on the data encoded with C<Unicode::UTF8>. Current API available since 0.060. =head2 assert $path = path("foo.txt")->assert( sub { $_->exists } ); Returns the invocant after asserting that a code reference argument returns true. When the assertion code reference runs, it will have the invocant object in the C<$_> variable. If it returns false, an exception will be thrown. The assertion code reference may also throw its own exception. If no assertion is provided, the invocant is returned without error. Current API available since 0.062. =head2 basename $name = path("foo/bar.txt")->basename; # bar.txt $name = path("foo.txt")->basename('.txt'); # foo $name = path("foo.txt")->basename(qr/.txt/); # foo $name = path("foo.txt")->basename(@suffixes); Returns the file portion or last directory portion of a path. Given a list of suffixes as strings or regular expressions, any that match at the end of the file portion or last directory portion will be removed before the result is returned. Current API available since 0.054. =head2 canonpath $canonical = path("foo/bar")->canonpath; # foo\bar on Windows Returns a string with the canonical format of the path name for the platform. In particular, this means directory separators will be C<\> on Windows. Current API available since 0.001. =head2 cached_temp Returns the cached C<File::Temp> or C<File::Temp::Dir> object if the C<Path::Tiny> object was created with C</tempfile> or C</tempdir>. If there is no such object, this method throws. B<WARNING>: Keeping a reference to, or modifying the cached object may break the behavior documented for temporary files and directories created with C<Path::Tiny> and is not supported. Use at your own risk. Current API available since 0.101. =head2 child $file = path("/tmp")->child("foo.txt"); # "/tmp/foo.txt" $file = path("/tmp")->child(@parts); Returns a new C<Path::Tiny> object relative to the original. Works like C<catfile> or C<catdir> from File::Spec, but without caring about file or directories. B<WARNING>: because the argument could contain C<..> or refer to symlinks, there is no guarantee that the new path refers to an actual descendent of the original. If this is important to you, transform parent and child with L</realpath> and check them with L</subsumes>. Current API available since 0.001. =head2 children @paths = path("/tmp")->children; @paths = path("/tmp")->children( qr/\.txt\z/ ); Returns a list of C<Path::Tiny> objects for all files and directories within a directory. Excludes "." and ".." automatically. If an optional C<qr//> argument is provided, it only returns objects for child names that match the given regular expression. Only the base name is used for matching: @paths = path("/tmp")->children( qr/^foo/ ); # matches children like the glob foo* Current API available since 0.028. =head2 chmod path("foo.txt")->chmod(0777); path("foo.txt")->chmod("0755"); path("foo.txt")->chmod("go-w"); path("foo.txt")->chmod("a=r,u+wx"); Sets file or directory permissions. The argument can be a numeric mode, a octal string beginning with a "0" or a limited subset of the symbolic mode use by F</bin/chmod>. The symbolic mode must be a comma-delimited list of mode clauses. Clauses must match C<< qr/\A([augo]+)([=+-])([rwx]+)\z/ >>, which defines "who", "op" and "perms" parameters for each clause. Unlike F</bin/chmod>, all three parameters are required for each clause, multiple ops are not allowed and permissions C<stugoX> are not supported. (See L<File::chmod> for more complex needs.) Current API available since 0.053. =head2 copy path("/tmp/foo.txt")->copy("/tmp/bar.txt"); Copies the current path to the given destination using L<File::Copy>'s C<copy> function. Upon success, returns the C<Path::Tiny> object for the newly copied file. Current API available since 0.070. =head2 digest $obj = path("/tmp/foo.txt")->digest; # SHA-256 $obj = path("/tmp/foo.txt")->digest("MD5"); # user-selected $obj = path("/tmp/foo.txt")->digest( { chunk_size => 1e6 }, "MD5" ); Returns a hexadecimal digest for a file. An optional hash reference of options may be given. The only option is C<chunk_size>. If C<chunk_size> is given, that many bytes will be read at a time. If not provided, the entire file will be slurped into memory to compute the digest. Any subsequent arguments are passed to the constructor for L<Digest> to select an algorithm. If no arguments are given, the default is SHA-256. Current API available since 0.056. =head2 dirname (deprecated) $name = path("/tmp/foo.txt")->dirname; # "/tmp/" Returns the directory portion you would get from calling C<< File::Spec->splitpath( $path->stringify ) >> or C<"."> for a path without a parent directory portion. Because L<File::Spec> is inconsistent, the result might or might not have a trailing slash. Because of this, this method is B<deprecated>. A better, more consistently approach is likely C<< $path->parent->stringify >>, which will not have a trailing slash except for a root directory. Deprecated in 0.056. =head2 edit, edit_raw, edit_utf8 path("foo.txt")->edit( \&callback, $options ); path("foo.txt")->edit_utf8( \&callback ); path("foo.txt")->edit_raw( \&callback ); These are convenience methods that allow "editing" a file using a single callback argument. They slurp the file using C<slurp>, place the contents inside a localized C<$_> variable, call the callback function (without arguments), and then write C<$_> (presumably mutated) back to the file with C<spew>. An optional hash reference may be used to pass options. The only option is C<binmode>, which is passed to C<slurp> and C<spew>. C<edit_utf8> and C<edit_raw> act like their respective C<slurp_*> and C<spew_*> methods. Current API available since 0.077. =head2 edit_lines, edit_lines_utf8, edit_lines_raw path("foo.txt")->edit_lines( \&callback, $options ); path("foo.txt")->edit_lines_utf8( \&callback ); path("foo.txt")->edit_lines_raw( \&callback ); These are convenience methods that allow "editing" a file's lines using a single callback argument. They iterate over the file: for each line, the line is put into a localized C<$_> variable, the callback function is executed (without arguments) and then C<$_> is written to a temporary file. When iteration is finished, the temporary file is atomically renamed over the original. An optional hash reference may be used to pass options. The only option is C<binmode>, which is passed to the method that open handles for reading and writing. C<edit_lines_utf8> and C<edit_lines_raw> act like their respective C<slurp_*> and C<spew_*> methods. Current API available since 0.077. =head2 exists, is_file, is_dir if ( path("/tmp")->exists ) { ... } # -e if ( path("/tmp")->is_dir ) { ... } # -d if ( path("/tmp")->is_file ) { ... } # -e && ! -d Implements file test operations, this means the file or directory actually has to exist on the filesystem. Until then, it's just a path. B<Note>: C<is_file> is not C<-f> because C<-f> is not the opposite of C<-d>. C<-f> means "plain file", excluding symlinks, devices, etc. that often can be read just like files. Use C<-f> instead if you really mean to check for a plain file. Current API available since 0.053. =head2 filehandle $fh = path("/tmp/foo.txt")->filehandle($mode, $binmode); $fh = path("/tmp/foo.txt")->filehandle({ locked => 1 }, $mode, $binmode); $fh = path("/tmp/foo.txt")->filehandle({ exclusive => 1 }, $mode, $binmode); Returns an open file handle. The C<$mode> argument must be a Perl-style read/write mode string ("<" ,">", ">>", etc.). If a C<$binmode> is given, it is set during the C<open> call. An optional hash reference may be used to pass options. The C<locked> option governs file locking; if true, handles opened for writing, appending or read-write are locked with C<LOCK_EX>; otherwise, they are locked with C<LOCK_SH>. When using C<locked>, ">" or "+>" modes will delay truncation until after the lock is acquired. The C<exclusive> option causes the open() call to fail if the file already exists. This corresponds to the O_EXCL flag to sysopen / open(2). C<exclusive> implies C<locked> and will set it for you if you forget it. See C<openr>, C<openw>, C<openrw>, and C<opena> for sugar. Current API available since 0.066. =head2 is_absolute, is_relative if ( path("/tmp")->is_absolute ) { ... } if ( path("/tmp")->is_relative ) { ... } Booleans for whether the path appears absolute or relative. Current API available since 0.001. =head2 is_rootdir while ( ! $path->is_rootdir ) { $path = $path->parent; ... } Boolean for whether the path is the root directory of the volume. I.e. the C<dirname> is C<q[/]> and the C<basename> is C<q[]>. This works even on C<MSWin32> with drives and UNC volumes: path("C:/")->is_rootdir; # true path("//server/share/")->is_rootdir; #true Current API available since 0.038. =head2 iterator $iter = path("/tmp")->iterator( \%options ); Returns a code reference that walks a directory lazily. Each invocation returns a C<Path::Tiny> object or undef when the iterator is exhausted. $iter = path("/tmp")->iterator; while ( $path = $iter->() ) { ... } The current and parent directory entries ("." and "..") will not be included. If the C<recurse> option is true, the iterator will walk the directory recursively, breadth-first. If the C<follow_symlinks> option is also true, directory links will be followed recursively. There is no protection against loops when following links. If a directory is not readable, it will not be followed. The default is the same as: $iter = path("/tmp")->iterator( { recurse => 0, follow_symlinks => 0, } ); For a more powerful, recursive iterator with built-in loop avoidance, see L<Path::Iterator::Rule>. See also L</visit>. Current API available since 0.016. =head2 lines, lines_raw, lines_utf8 @contents = path("/tmp/foo.txt")->lines; @contents = path("/tmp/foo.txt")->lines(\%options); @contents = path("/tmp/foo.txt")->lines_raw; @contents = path("/tmp/foo.txt")->lines_utf8; @contents = path("/tmp/foo.txt")->lines( { chomp => 1, count => 4 } ); Returns a list of lines from a file. Optionally takes a hash-reference of options. Valid options are C<binmode>, C<count> and C<chomp>. If C<binmode> is provided, it will be set on the handle prior to reading. If a positive C<count> is provided, that many lines will be returned from the start of the file. If a negative C<count> is provided, the entire file will be read, but only C<abs(count)> will be kept and returned. If C<abs(count)> exceeds the number of lines in the file, all lines will be returned. If C<chomp> is set, any end-of-line character sequences (C<CR>, C<CRLF>, or C<LF>) will be removed from the lines returned. Because the return is a list, C<lines> in scalar context will return the number of lines (and throw away the data). $number_of_lines = path("/tmp/foo.txt")->lines; C<lines_raw> is like C<lines> with a C<binmode> of C<:raw>. We use C<:raw> instead of C<:unix> so PerlIO buffering can manage reading by line. C<lines_utf8> is like C<lines> with a C<binmode> of C<:raw:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw UTF-8 slurp will be done and then the lines will be split. This is actually faster than relying on C<:encoding(UTF-8)>, though a bit memory intensive. If memory use is a concern, consider C<openr_utf8> and iterating directly on the handle. Current API available since 0.065. =head2 mkpath path("foo/bar/baz")->mkpath; path("foo/bar/baz")->mkpath( \%options ); Like calling C<make_path> from L<File::Path>. An optional hash reference is passed through to C<make_path>. Errors will be trapped and an exception thrown. Returns the list of directories created or an empty list if the directories already exist, just like C<make_path>. Current API available since 0.001. =head2 move path("foo.txt")->move("bar.txt"); Move the current path to the given destination path using Perl's built-in L<rename|perlfunc/rename> function. Returns the result of the C<rename> function (except it throws an exception if it fails). Current API available since 0.001. =head2 openr, openw, openrw, opena $fh = path("foo.txt")->openr($binmode); # read $fh = path("foo.txt")->openr_raw; $fh = path("foo.txt")->openr_utf8; $fh = path("foo.txt")->openw($binmode); # write $fh = path("foo.txt")->openw_raw; $fh = path("foo.txt")->openw_utf8; $fh = path("foo.txt")->opena($binmode); # append $fh = path("foo.txt")->opena_raw; $fh = path("foo.txt")->opena_utf8; $fh = path("foo.txt")->openrw($binmode); # read/write $fh = path("foo.txt")->openrw_raw; $fh = path("foo.txt")->openrw_utf8; Returns a file handle opened in the specified mode. The C<openr> style methods take a single C<binmode> argument. All of the C<open*> methods have C<open*_raw> and C<open*_utf8> equivalents that use C<:raw> and C<:raw:encoding(UTF-8)>, respectively. An optional hash reference may be used to pass options. The only option is C<locked>. If true, handles opened for writing, appending or read-write are locked with C<LOCK_EX>; otherwise, they are locked for C<LOCK_SH>. $fh = path("foo.txt")->openrw_utf8( { locked => 1 } ); See L</filehandle> for more on locking. Current API available since 0.011. =head2 parent $parent = path("foo/bar/baz")->parent; # foo/bar $parent = path("foo/wibble.txt")->parent; # foo $parent = path("foo/bar/baz")->parent(2); # foo Returns a C<Path::Tiny> object corresponding to the parent directory of the original directory or file. An optional positive integer argument is the number of parent directories upwards to return. C<parent> by itself is equivalent to C<parent(1)>. Current API available since 0.014. =head2 realpath $real = path("/baz/foo/../bar")->realpath; $real = path("foo/../bar")->realpath; Returns a new C<Path::Tiny> object with all symbolic links and upward directory parts resolved using L<Cwd>'s C<realpath>. Compared to C<absolute>, this is more expensive as it must actually consult the filesystem. If the parent path can't be resolved (e.g. if it includes directories that don't exist), an exception will be thrown: $real = path("doesnt_exist/foo")->realpath; # dies However, if the parent path exists and only the last component (e.g. filename) doesn't exist, the realpath will be the realpath of the parent plus the non-existent last component: $real = path("./aasdlfasdlf")->realpath; # works The underlying L<Cwd> module usually worked this way on Unix, but died on Windows (and some Unixes) if the full path didn't exist. As of version 0.064, it's safe to use anywhere. Current API available since 0.001. =head2 relative $rel = path("/tmp/foo/bar")->relative("/tmp"); # foo/bar Returns a C<Path::Tiny> object with a path relative to a new base path given as an argument. If no argument is given, the current directory will be used as the new base path. If either path is already relative, it will be made absolute based on the current directly before determining the new relative path. The algorithm is roughly as follows: =over 4 =item * If the original and new base path are on different volumes, an exception will be thrown. =item * If the original and new base are identical, the relative path is C<".">. =item * If the new base subsumes the original, the relative path is the original path with the new base chopped off the front =item * If the new base does not subsume the original, a common prefix path is determined (possibly the root directory) and the relative path will consist of updirs (C<"..">) to reach the common prefix, followed by the original path less the common prefix. =back Unlike C<File::Spec::abs2rel>, in the last case above, the calculation based on a common prefix takes into account symlinks that could affect the updir process. Given an original path "/A/B" and a new base "/A/C", (where "A", "B" and "C" could each have multiple path components): =over 4 =item * Symlinks in "A" don't change the result unless the last component of A is a symlink and the first component of "C" is an updir. =item * Symlinks in "B" don't change the result and will exist in the result as given. =item * Symlinks and updirs in "C" must be resolved to actual paths, taking into account the possibility that not all path components might exist on the filesystem. =back Current API available since 0.001. New algorithm (that accounts for symlinks) available since 0.079. =head2 remove path("foo.txt")->remove; This is just like C<unlink>, except for its error handling: if the path does not exist, it returns false; if deleting the file fails, it throws an exception. Current API available since 0.012. =head2 remove_tree # directory path("foo/bar/baz")->remove_tree; path("foo/bar/baz")->remove_tree( \%options ); path("foo/bar/baz")->remove_tree( { safe => 0 } ); # force remove Like calling C<remove_tree> from L<File::Path>, but defaults to C<safe> mode. An optional hash reference is passed through to C<remove_tree>. Errors will be trapped and an exception thrown. Returns the number of directories deleted, just like C<remove_tree>. If you want to remove a directory only if it is empty, use the built-in C<rmdir> function instead. rmdir path("foo/bar/baz/"); Current API available since 0.013. =head2 sibling $foo = path("/tmp/foo.txt"); $sib = $foo->sibling("bar.txt"); # /tmp/bar.txt $sib = $foo->sibling("baz", "bam.txt"); # /tmp/baz/bam.txt Returns a new C<Path::Tiny> object relative to the parent of the original. This is slightly more efficient than C<< $path->parent->child(...) >>. Current API available since 0.058. =head2 slurp, slurp_raw, slurp_utf8 $data = path("foo.txt")->slurp; $data = path("foo.txt")->slurp( {binmode => ":raw"} ); $data = path("foo.txt")->slurp_raw; $data = path("foo.txt")->slurp_utf8; Reads file contents into a scalar. Takes an optional hash reference which may be used to pass options. The only available option is C<binmode>, which is passed to C<binmode()> on the handle used for reading. C<slurp_raw> is like C<slurp> with a C<binmode> of C<:unix> for a fast, unbuffered, raw read. C<slurp_utf8> is like C<slurp> with a C<binmode> of C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw slurp will be done instead and the result decoded with C<Unicode::UTF8>. This is just as strict and is roughly an order of magnitude faster than using C<:encoding(UTF-8)>. B<Note>: C<slurp> and friends lock the filehandle before slurping. If you plan to slurp from a file created with L<File::Temp>, be sure to close other handles or open without locking to avoid a deadlock: my $tempfile = File::Temp->new(EXLOCK => 0); my $guts = path($tempfile)->slurp; Current API available since 0.004. =head2 spew, spew_raw, spew_utf8 path("foo.txt")->spew(@data); path("foo.txt")->spew(\@data); path("foo.txt")->spew({binmode => ":raw"}, @data); path("foo.txt")->spew_raw(@data); path("foo.txt")->spew_utf8(@data); Writes data to a file atomically. The file is written to a temporary file in the same directory, then renamed over the original. An optional hash reference may be used to pass options. The only option is C<binmode>, which is passed to C<binmode()> on the handle used for writing. C<spew_raw> is like C<spew> with a C<binmode> of C<:unix> for a fast, unbuffered, raw write. C<spew_utf8> is like C<spew> with a C<binmode> of C<:unix:encoding(UTF-8)> (or L<PerlIO::utf8_strict>). If L<Unicode::UTF8> 0.58+ is installed, a raw spew will be done instead on the data encoded with C<Unicode::UTF8>. B<NOTE>: because the file is written to a temporary file and then renamed, the new file will wind up with permissions based on your current umask. This is a feature to protect you from a race condition that would otherwise give different permissions than you might expect. If you really want to keep the original mode flags, use L</append> with the C<truncate> option. Current API available since 0.011. =head2 stat, lstat $stat = path("foo.txt")->stat; $stat = path("/some/symlink")->lstat; Like calling C<stat> or C<lstat> from L<File::stat>. Current API available since 0.001. =head2 stringify $path = path("foo.txt"); say $path->stringify; # same as "$path" Returns a string representation of the path. Unlike C<canonpath>, this method returns the path standardized with Unix-style C</> directory separators. Current API available since 0.001. =head2 subsumes path("foo/bar")->subsumes("foo/bar/baz"); # true path("/foo/bar")->subsumes("/foo/baz"); # false Returns true if the first path is a prefix of the second path at a directory boundary. This B<does not> resolve parent directory entries (C<..>) or symlinks: path("foo/bar")->subsumes("foo/bar/../baz"); # true If such things are important to you, ensure that both paths are resolved to the filesystem with C<realpath>: my $p1 = path("foo/bar")->realpath; my $p2 = path("foo/bar/../baz")->realpath; if ( $p1->subsumes($p2) ) { ... } Current API available since 0.048. =head2 touch path("foo.txt")->touch; path("foo.txt")->touch($epoch_secs); Like the Unix C<touch> utility. Creates the file if it doesn't exist, or else changes the modification and access times to the current time. If the first argument is the epoch seconds then it will be used. Returns the path object so it can be easily chained with other methods: # won't die if foo.txt doesn't exist $content = path("foo.txt")->touch->slurp; Current API available since 0.015. =head2 touchpath path("bar/baz/foo.txt")->touchpath; Combines C<mkpath> and C<touch>. Creates the parent directory if it doesn't exist, before touching the file. Returns the path object like C<touch> does. Current API available since 0.022. =head2 visit path("/tmp")->visit( \&callback, \%options ); Executes a callback for each child of a directory. It returns a hash reference with any state accumulated during iteration. The options are the same as for L</iterator> (which it uses internally): C<recurse> and C<follow_symlinks>. Both default to false. The callback function will receive a C<Path::Tiny> object as the first argument and a hash reference to accumulate state as the second argument. For example: # collect files sizes my $sizes = path("/tmp")->visit( sub { my ($path, $state) = @_; return if $path->is_dir; $state->{$path} = -s $path; }, { recurse => 1 } ); For convenience, the C<Path::Tiny> object will also be locally aliased as the C<$_> global variable: # print paths matching /foo/ path("/tmp")->visit( sub { say if /foo/ }, { recurse => 1} ); If the callback returns a B<reference> to a false scalar value, iteration will terminate. This is not the same as "pruning" a directory search; this just stops all iteration and returns the state hash reference. # find up to 10 files larger than 100K my $files = path("/tmp")->visit( sub { my ($path, $state) = @_; $state->{$path}++ if -s $path > 102400 return \0 if keys %$state == 10; }, { recurse => 1 } ); If you want more flexible iteration, use a module like L<Path::Iterator::Rule>. Current API available since 0.062. =head2 volume $vol = path("/tmp/foo.txt")->volume; # "" $vol = path("C:/tmp/foo.txt")->volume; # "C:" Returns the volume portion of the path. This is equivalent to what L<File::Spec> would give from C<splitpath> and thus usually is the empty string on Unix-like operating systems or the drive letter for an absolute path on C<MSWin32>. Current API available since 0.001. =for Pod::Coverage openr_utf8 opena_utf8 openw_utf8 openrw_utf8 openr_raw opena_raw openw_raw openrw_raw IS_WIN32 FREEZE THAW TO_JSON abs2rel =head1 EXCEPTION HANDLING Simple usage errors will generally croak. Failures of underlying Perl functions will be thrown as exceptions in the class C<Path::Tiny::Error>. A C<Path::Tiny::Error> object will be a hash reference with the following fields: =over 4 =item * C<op> — a description of the operation, usually function call and any extra info =item * C<file> — the file or directory relating to the error =item * C<err> — hold C<$!> at the time the error was thrown =item * C<msg> — a string combining the above data and a Carp-like short stack trace =back Exception objects will stringify as the C<msg> field. =head1 ENVIRONMENT =head2 PERL_PATH_TINY_NO_FLOCK If the environment variable C<PERL_PATH_TINY_NO_FLOCK> is set to a true value then flock will NOT be used when accessing files (this is not recommended). =head1 CAVEATS =head2 Subclassing not supported For speed, this class is implemented as an array based object and uses many direct function calls internally. You must not subclass it and expect things to work properly. =head2 File locking If flock is not supported on a platform, it will not be used, even if locking is requested. In situations where a platform normally would support locking, but the flock fails due to a filesystem limitation, Path::Tiny has some heuristics to detect this and will warn once and continue in an unsafe mode. If you want this failure to be fatal, you can fatalize the 'flock' warnings category: use warnings FATAL => 'flock'; See additional caveats below. =head3 NFS and BSD On BSD, Perl's flock implementation may not work to lock files on an NFS filesystem. If detected, this situation will warn once, as described above. =head3 Lustre The Lustre filesystem does not support flock. If detected, this situation will warn once, as described above. =head3 AIX and locking AIX requires a write handle for locking. Therefore, calls that normally open a read handle and take a shared lock instead will open a read-write handle and take an exclusive lock. If the user does not have write permission, no lock will be used. =head2 utf8 vs UTF-8 All the C<*_utf8> methods by default use C<:encoding(UTF-8)> -- either as C<:unix:encoding(UTF-8)> (unbuffered) or C<:raw:encoding(UTF-8)> (buffered) -- which is strict against the Unicode spec and disallows illegal Unicode codepoints or UTF-8 sequences. Unfortunately, C<:encoding(UTF-8)> is very, very slow. If you install L<Unicode::UTF8> 0.58 or later, that module will be used by some C<*_utf8> methods to encode or decode data after a raw, binary input/output operation, which is much faster. Alternatively, if you install L<PerlIO::utf8_strict>, that will be used instead of C<:encoding(UTF-8)> and is also very fast. If you need the performance and can accept the security risk, C<< slurp({binmode => ":unix:utf8"}) >> will be faster than C<:unix:encoding(UTF-8)> (but not as fast as C<Unicode::UTF8>). Note that the C<*_utf8> methods read in B<raw> mode. There is no CRLF translation on Windows. If you must have CRLF translation, use the regular input/output methods with an appropriate binmode: $path->spew_utf8($data); # raw $path->spew({binmode => ":encoding(UTF-8)"}, $data; # LF -> CRLF =head2 Default IO layers and the open pragma If you have Perl 5.10 or later, file input/output methods (C<slurp>, C<spew>, etc.) and high-level handle opening methods ( C<filehandle>, C<openr>, C<openw>, etc. ) respect default encodings set by the C<-C> switch or lexical L<open> settings of the caller. For UTF-8, this is almost certainly slower than using the dedicated C<_utf8> methods if you have L<Unicode::UTF8>. =head1 TYPE CONSTRAINTS AND COERCION A standard L<MooseX::Types> library is available at L<MooseX::Types::Path::Tiny>. A L<Type::Tiny> equivalent is available as L<Types::Path::Tiny>. =head1 SEE ALSO These are other file/path utilities, which may offer a different feature set than C<Path::Tiny>. =over 4 =item * L<File::chmod> =item * L<File::Fu> =item * L<IO::All> =item * L<Path::Class> =back These iterators may be slightly faster than the recursive iterator in C<Path::Tiny>: =over 4 =item * L<Path::Iterator::Rule> =item * L<File::Next> =back There are probably comparable, non-Tiny tools. Let me know if you want me to add a module to the list. This module was featured in the L<2013 Perl Advent Calendar|http://www.perladvent.org/2013/2013-12-18.html>. =head1 AUTHOR David Golden <dagolden@cpan.org> =head1 CONTRIBUTORS =for stopwords Alex Efros Aristotle Pagaltzis Chris Williams Dan Book Dave Rolsky David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis Ian Sillitoe James Hunt John Karr Karen Etheridge Mark Ellis Martin H. Sluka Kjeldsen Michael G. Schwern Nigel Gregoire Philippe Bruhat (BooK) regina-verbae Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim =over 4 =item * Alex Efros <powerman@powerman.name> =item * Aristotle Pagaltzis <pagaltzis@gmx.de> =item * Chris Williams <bingos@cpan.org> =item * Dan Book <grinnz@grinnz.com> =item * Dave Rolsky <autarch@urth.org> =item * David Steinbrunner <dsteinbrunner@pobox.com> =item * Doug Bell <madcityzen@gmail.com> =item * Gabor Szabo <szabgab@cpan.org> =item * Gabriel Andrade <gabiruh@gmail.com> =item * George Hartzell <hartzell@cpan.org> =item * Geraud Continsouzas <geraud@scsi.nc> =item * Goro Fuji <gfuji@cpan.org> =item * Graham Knop <haarg@haarg.org> =item * Graham Ollis <plicease@cpan.org> =item * Ian Sillitoe <ian@sillit.com> =item * James Hunt <james@niftylogic.com> =item * John Karr <brainbuz@brainbuz.org> =item * Karen Etheridge <ether@cpan.org> =item * Mark Ellis <mark.ellis@cartridgesave.co.uk> =item * Martin H. Sluka <fany@cpan.org> =item * Martin Kjeldsen <mk@bluepipe.dk> =item * Michael G. Schwern <mschwern@cpan.org> =item * Nigel Gregoire <nigelgregoire@gmail.com> =item * Philippe Bruhat (BooK) <book@cpan.org> =item * regina-verbae <regina-verbae@users.noreply.github.com> =item * Roy Ivy III <rivy@cpan.org> =item * Shlomi Fish <shlomif@shlomifish.org> =item * Smylers <Smylers@stripey.com> =item * Tatsuhiko Miyagawa <miyagawa@bulknews.net> =item * Toby Inkster <tobyink@cpan.org> =item * Yanick Champoux <yanick@babyl.dyndns.org> =item * 김도형 - Keedi Kim <keedi@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2014 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut perl5/CPAN/Meta.pm 0000444 00000070736 14711217523 0007556 0 ustar 00 use 5.006; use strict; use warnings; package CPAN::Meta; # VERSION $CPAN::Meta::VERSION = '2.143240'; #pod =head1 SYNOPSIS #pod #pod use v5.10; #pod use strict; #pod use warnings; #pod use CPAN::Meta; #pod use Module::Load; #pod #pod my $meta = CPAN::Meta->load_file('META.json'); #pod #pod printf "testing requirements for %s version %s\n", #pod $meta->name, #pod $meta->version; #pod #pod my $prereqs = $meta->effective_prereqs; #pod #pod for my $phase ( qw/configure runtime build test/ ) { #pod say "Requirements for $phase:"; #pod my $reqs = $prereqs->requirements_for($phase, "requires"); #pod for my $module ( sort $reqs->required_modules ) { #pod my $status; #pod if ( eval { load $module unless $module eq 'perl'; 1 } ) { #pod my $version = $module eq 'perl' ? $] : $module->VERSION; #pod $status = $reqs->accepts_module($module, $version) #pod ? "$version ok" : "$version not ok"; #pod } else { #pod $status = "missing" #pod }; #pod say " $module ($status)"; #pod } #pod } #pod #pod =head1 DESCRIPTION #pod #pod Software distributions released to the CPAN include a F<META.json> or, for #pod older distributions, F<META.yml>, which describes the distribution, its #pod contents, and the requirements for building and installing the distribution. #pod The data structure stored in the F<META.json> file is described in #pod L<CPAN::Meta::Spec>. #pod #pod CPAN::Meta provides a simple class to represent this distribution metadata (or #pod I<distmeta>), along with some helpful methods for interrogating that data. #pod #pod The documentation below is only for the methods of the CPAN::Meta object. For #pod information on the meaning of individual fields, consult the spec. #pod #pod =cut use Carp qw(carp croak); use CPAN::Meta::Feature; use CPAN::Meta::Prereqs; use CPAN::Meta::Converter; use CPAN::Meta::Validator; use Parse::CPAN::Meta 1.4414 (); BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone } #pod =head1 STRING DATA #pod #pod The following methods return a single value, which is the value for the #pod corresponding entry in the distmeta structure. Values should be either undef #pod or strings. #pod #pod =for :list #pod * abstract #pod * description #pod * dynamic_config #pod * generated_by #pod * name #pod * release_status #pod * version #pod #pod =cut BEGIN { my @STRING_READERS = qw( abstract description dynamic_config generated_by name release_status version ); no strict 'refs'; for my $attr (@STRING_READERS) { *$attr = sub { $_[0]{ $attr } }; } } #pod =head1 LIST DATA #pod #pod These methods return lists of string values, which might be represented in the #pod distmeta structure as arrayrefs or scalars: #pod #pod =for :list #pod * authors #pod * keywords #pod * licenses #pod #pod The C<authors> and C<licenses> methods may also be called as C<author> and #pod C<license>, respectively, to match the field name in the distmeta structure. #pod #pod =cut BEGIN { my @LIST_READERS = qw( author keywords license ); no strict 'refs'; for my $attr (@LIST_READERS) { *$attr = sub { my $value = $_[0]{ $attr }; croak "$attr must be called in list context" unless wantarray; return @{ _dclone($value) } if ref $value; return $value; }; } } sub authors { $_[0]->author } sub licenses { $_[0]->license } #pod =head1 MAP DATA #pod #pod These readers return hashrefs of arbitrary unblessed data structures, each #pod described more fully in the specification: #pod #pod =for :list #pod * meta_spec #pod * resources #pod * provides #pod * no_index #pod * prereqs #pod * optional_features #pod #pod =cut BEGIN { my @MAP_READERS = qw( meta-spec resources provides no_index prereqs optional_features ); no strict 'refs'; for my $attr (@MAP_READERS) { (my $subname = $attr) =~ s/-/_/; *$subname = sub { my $value = $_[0]{ $attr }; return _dclone($value) if $value; return {}; }; } } #pod =head1 CUSTOM DATA #pod #pod A list of custom keys are available from the C<custom_keys> method and #pod particular keys may be retrieved with the C<custom> method. #pod #pod say $meta->custom($_) for $meta->custom_keys; #pod #pod If a custom key refers to a data structure, a deep clone is returned. #pod #pod =cut sub custom_keys { return grep { /^x_/i } keys %{$_[0]}; } sub custom { my ($self, $attr) = @_; my $value = $self->{$attr}; return _dclone($value) if ref $value; return $value; } #pod =method new #pod #pod my $meta = CPAN::Meta->new($distmeta_struct, \%options); #pod #pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash #pod reference fails to validate. Older-format metadata will be up-converted to #pod version 2 if they validate against the original stated specification. #pod #pod It takes an optional hashref of options. Valid options include: #pod #pod =over #pod #pod =item * #pod #pod lazy_validation -- if true, new will attempt to convert the given metadata #pod to version 2 before attempting to validate it. This means than any #pod fixable errors will be handled by CPAN::Meta::Converter before validation. #pod (Note that this might result in invalid optional data being silently #pod dropped.) The default is false. #pod #pod =back #pod #pod =cut sub _new { my ($class, $struct, $options) = @_; my $self; if ( $options->{lazy_validation} ) { # try to convert to a valid structure; if succeeds, then return it my $cmc = CPAN::Meta::Converter->new( $struct ); $self = $cmc->convert( version => 2 ); # valid or dies return bless $self, $class; } else { # validate original struct my $cmv = CPAN::Meta::Validator->new( $struct ); unless ( $cmv->is_valid) { die "Invalid metadata structure. Errors: " . join(", ", $cmv->errors) . "\n"; } } # up-convert older spec versions my $version = $struct->{'meta-spec'}{version} || '1.0'; if ( $version == 2 ) { $self = $struct; } else { my $cmc = CPAN::Meta::Converter->new( $struct ); $self = $cmc->convert( version => 2 ); } return bless $self, $class; } sub new { my ($class, $struct, $options) = @_; my $self = eval { $class->_new($struct, $options) }; croak($@) if $@; return $self; } #pod =method create #pod #pod my $meta = CPAN::Meta->create($distmeta_struct, \%options); #pod #pod This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields #pod will be generated if not provided. This means the metadata structure is #pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>. #pod #pod =cut sub create { my ($class, $struct, $options) = @_; my $version = __PACKAGE__->VERSION || 2; $struct->{generated_by} ||= __PACKAGE__ . " version $version" ; $struct->{'meta-spec'}{version} ||= int($version); my $self = eval { $class->_new($struct, $options) }; croak ($@) if $@; return $self; } #pod =method load_file #pod #pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options); #pod #pod Given a pathname to a file containing metadata, this deserializes the file #pod according to its file suffix and constructs a new C<CPAN::Meta> object, just #pod like C<new()>. It will die if the deserialized version fails to validate #pod against its stated specification version. #pod #pod It takes the same options as C<new()> but C<lazy_validation> defaults to #pod true. #pod #pod =cut sub load_file { my ($class, $file, $options) = @_; $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; croak "load_file() requires a valid, readable filename" unless -r $file; my $self; eval { my $struct = Parse::CPAN::Meta->load_file( $file ); $self = $class->_new($struct, $options); }; croak($@) if $@; return $self; } #pod =method load_yaml_string #pod #pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); #pod #pod This method returns a new CPAN::Meta object using the first document in the #pod given YAML string. In other respects it is identical to C<load_file()>. #pod #pod =cut sub load_yaml_string { my ($class, $yaml, $options) = @_; $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; my $self; eval { my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml ); $self = $class->_new($struct, $options); }; croak($@) if $@; return $self; } #pod =method load_json_string #pod #pod my $meta = CPAN::Meta->load_json_string($json, \%options); #pod #pod This method returns a new CPAN::Meta object using the structure represented by #pod the given JSON string. In other respects it is identical to C<load_file()>. #pod #pod =cut sub load_json_string { my ($class, $json, $options) = @_; $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; my $self; eval { my $struct = Parse::CPAN::Meta->load_json_string( $json ); $self = $class->_new($struct, $options); }; croak($@) if $@; return $self; } #pod =method load_string #pod #pod my $meta = CPAN::Meta->load_string($string, \%options); #pod #pod If you don't know if a string contains YAML or JSON, this method will use #pod L<Parse::CPAN::Meta> to guess. In other respects it is identical to #pod C<load_file()>. #pod #pod =cut sub load_string { my ($class, $string, $options) = @_; $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; my $self; eval { my $struct = Parse::CPAN::Meta->load_string( $string ); $self = $class->_new($struct, $options); }; croak($@) if $@; return $self; } #pod =method save #pod #pod $meta->save($distmeta_file, \%options); #pod #pod Serializes the object as JSON and writes it to the given file. The only valid #pod option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file #pod is saved with UTF-8 encoding. #pod #pod For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP> #pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or #pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate #pod backend like L<JSON::XS>. #pod #pod For C<version> less than 2, the filename should end in '.yml'. #pod L<CPAN::Meta::Converter> is used to generate an older metadata structure, which #pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may #pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though #pod this is not recommended due to subtle incompatibilities between YAML parsers on #pod CPAN. #pod #pod =cut sub save { my ($self, $file, $options) = @_; my $version = $options->{version} || '2'; my $layer = $] ge '5.008001' ? ':utf8' : ''; if ( $version ge '2' ) { carp "'$file' should end in '.json'" unless $file =~ m{\.json$}; } else { carp "'$file' should end in '.yml'" unless $file =~ m{\.yml$}; } my $data = $self->as_string( $options ); open my $fh, ">$layer", $file or die "Error opening '$file' for writing: $!\n"; print {$fh} $data; close $fh or die "Error closing '$file': $!\n"; return 1; } #pod =method meta_spec_version #pod #pod This method returns the version part of the C<meta_spec> entry in the distmeta #pod structure. It is equivalent to: #pod #pod $meta->meta_spec->{version}; #pod #pod =cut sub meta_spec_version { my ($self) = @_; return $self->meta_spec->{version}; } #pod =method effective_prereqs #pod #pod my $prereqs = $meta->effective_prereqs; #pod #pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); #pod #pod This method returns a L<CPAN::Meta::Prereqs> object describing all the #pod prereqs for the distribution. If an arrayref of feature identifiers is given, #pod the prereqs for the identified features are merged together with the #pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. #pod #pod =cut sub effective_prereqs { my ($self, $features) = @_; $features ||= []; my $prereq = CPAN::Meta::Prereqs->new($self->prereqs); return $prereq unless @$features; my @other = map {; $self->feature($_)->prereqs } @$features; return $prereq->with_merged_prereqs(\@other); } #pod =method should_index_file #pod #pod ... if $meta->should_index_file( $filename ); #pod #pod This method returns true if the given file should be indexed. It decides this #pod by checking the C<file> and C<directory> keys in the C<no_index> property of #pod the distmeta structure. Note that neither the version format nor #pod C<release_status> are considered. #pod #pod C<$filename> should be given in unix format. #pod #pod =cut sub should_index_file { my ($self, $filename) = @_; for my $no_index_file (@{ $self->no_index->{file} || [] }) { return if $filename eq $no_index_file; } for my $no_index_dir (@{ $self->no_index->{directory} }) { $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z}; return if index($filename, $no_index_dir) == 0; } return 1; } #pod =method should_index_package #pod #pod ... if $meta->should_index_package( $package ); #pod #pod This method returns true if the given package should be indexed. It decides #pod this by checking the C<package> and C<namespace> keys in the C<no_index> #pod property of the distmeta structure. Note that neither the version format nor #pod C<release_status> are considered. #pod #pod =cut sub should_index_package { my ($self, $package) = @_; for my $no_index_pkg (@{ $self->no_index->{package} || [] }) { return if $package eq $no_index_pkg; } for my $no_index_ns (@{ $self->no_index->{namespace} }) { return if index($package, "${no_index_ns}::") == 0; } return 1; } #pod =method features #pod #pod my @feature_objects = $meta->features; #pod #pod This method returns a list of L<CPAN::Meta::Feature> objects, one for each #pod optional feature described by the distribution's metadata. #pod #pod =cut sub features { my ($self) = @_; my $opt_f = $self->optional_features; my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) } keys %$opt_f; return @features; } #pod =method feature #pod #pod my $feature_object = $meta->feature( $identifier ); #pod #pod This method returns a L<CPAN::Meta::Feature> object for the optional feature #pod with the given identifier. If no feature with that identifier exists, an #pod exception will be raised. #pod #pod =cut sub feature { my ($self, $ident) = @_; croak "no feature named $ident" unless my $f = $self->optional_features->{ $ident }; return CPAN::Meta::Feature->new($ident, $f); } #pod =method as_struct #pod #pod my $copy = $meta->as_struct( \%options ); #pod #pod This method returns a deep copy of the object's metadata as an unblessed hash #pod reference. It takes an optional hashref of options. If the hashref contains #pod a C<version> argument, the copied metadata will be converted to the version #pod of the specification and returned. For example: #pod #pod my $old_spec = $meta->as_struct( {version => "1.4"} ); #pod #pod =cut sub as_struct { my ($self, $options) = @_; my $struct = _dclone($self); if ( $options->{version} ) { my $cmc = CPAN::Meta::Converter->new( $struct ); $struct = $cmc->convert( version => $options->{version} ); } return $struct; } #pod =method as_string #pod #pod my $string = $meta->as_string( \%options ); #pod #pod This method returns a serialized copy of the object's metadata as a character #pod string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref #pod of options. If the hashref contains a C<version> argument, the copied metadata #pod will be converted to the version of the specification and returned. For #pod example: #pod #pod my $string = $meta->as_string( {version => "1.4"} ); #pod #pod For C<version> greater than or equal to 2, the string will be serialized as #pod JSON. For C<version> less than 2, the string will be serialized as YAML. In #pod both cases, the same rules are followed as in the C<save()> method for choosing #pod a serialization backend. #pod #pod =cut sub as_string { my ($self, $options) = @_; my $version = $options->{version} || '2'; my $struct; if ( $self->meta_spec_version ne $version ) { my $cmc = CPAN::Meta::Converter->new( $self->as_struct ); $struct = $cmc->convert( version => $version ); } else { $struct = $self->as_struct; } my ($data, $backend); if ( $version ge '2' ) { $backend = Parse::CPAN::Meta->json_backend(); $data = $backend->new->pretty->canonical->encode($struct); } else { $backend = Parse::CPAN::Meta->yaml_backend(); $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) }; if ( $@ ) { croak $backend->can('errstr') ? $backend->errstr : $@ } } return $data; } # Used by JSON::PP, etc. for "convert_blessed" sub TO_JSON { return { %{ $_[0] } }; } 1; # ABSTRACT: the distribution metadata for a CPAN dist __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta - the distribution metadata for a CPAN dist =head1 VERSION version 2.143240 =head1 SYNOPSIS use v5.10; use strict; use warnings; use CPAN::Meta; use Module::Load; my $meta = CPAN::Meta->load_file('META.json'); printf "testing requirements for %s version %s\n", $meta->name, $meta->version; my $prereqs = $meta->effective_prereqs; for my $phase ( qw/configure runtime build test/ ) { say "Requirements for $phase:"; my $reqs = $prereqs->requirements_for($phase, "requires"); for my $module ( sort $reqs->required_modules ) { my $status; if ( eval { load $module unless $module eq 'perl'; 1 } ) { my $version = $module eq 'perl' ? $] : $module->VERSION; $status = $reqs->accepts_module($module, $version) ? "$version ok" : "$version not ok"; } else { $status = "missing" }; say " $module ($status)"; } } =head1 DESCRIPTION Software distributions released to the CPAN include a F<META.json> or, for older distributions, F<META.yml>, which describes the distribution, its contents, and the requirements for building and installing the distribution. The data structure stored in the F<META.json> file is described in L<CPAN::Meta::Spec>. CPAN::Meta provides a simple class to represent this distribution metadata (or I<distmeta>), along with some helpful methods for interrogating that data. The documentation below is only for the methods of the CPAN::Meta object. For information on the meaning of individual fields, consult the spec. =head1 METHODS =head2 new my $meta = CPAN::Meta->new($distmeta_struct, \%options); Returns a valid CPAN::Meta object or dies if the supplied metadata hash reference fails to validate. Older-format metadata will be up-converted to version 2 if they validate against the original stated specification. It takes an optional hashref of options. Valid options include: =over =item * lazy_validation -- if true, new will attempt to convert the given metadata to version 2 before attempting to validate it. This means than any fixable errors will be handled by CPAN::Meta::Converter before validation. (Note that this might result in invalid optional data being silently dropped.) The default is false. =back =head2 create my $meta = CPAN::Meta->create($distmeta_struct, \%options); This is same as C<new()>, except that C<generated_by> and C<meta-spec> fields will be generated if not provided. This means the metadata structure is assumed to otherwise follow the latest L<CPAN::Meta::Spec>. =head2 load_file my $meta = CPAN::Meta->load_file($distmeta_file, \%options); Given a pathname to a file containing metadata, this deserializes the file according to its file suffix and constructs a new C<CPAN::Meta> object, just like C<new()>. It will die if the deserialized version fails to validate against its stated specification version. It takes the same options as C<new()> but C<lazy_validation> defaults to true. =head2 load_yaml_string my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); This method returns a new CPAN::Meta object using the first document in the given YAML string. In other respects it is identical to C<load_file()>. =head2 load_json_string my $meta = CPAN::Meta->load_json_string($json, \%options); This method returns a new CPAN::Meta object using the structure represented by the given JSON string. In other respects it is identical to C<load_file()>. =head2 load_string my $meta = CPAN::Meta->load_string($string, \%options); If you don't know if a string contains YAML or JSON, this method will use L<Parse::CPAN::Meta> to guess. In other respects it is identical to C<load_file()>. =head2 save $meta->save($distmeta_file, \%options); Serializes the object as JSON and writes it to the given file. The only valid option is C<version>, which defaults to '2'. On Perl 5.8.1 or later, the file is saved with UTF-8 encoding. For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP> is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate backend like L<JSON::XS>. For C<version> less than 2, the filename should end in '.yml'. L<CPAN::Meta::Converter> is used to generate an older metadata structure, which is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though this is not recommended due to subtle incompatibilities between YAML parsers on CPAN. =head2 meta_spec_version This method returns the version part of the C<meta_spec> entry in the distmeta structure. It is equivalent to: $meta->meta_spec->{version}; =head2 effective_prereqs my $prereqs = $meta->effective_prereqs; my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); This method returns a L<CPAN::Meta::Prereqs> object describing all the prereqs for the distribution. If an arrayref of feature identifiers is given, the prereqs for the identified features are merged together with the distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. =head2 should_index_file ... if $meta->should_index_file( $filename ); This method returns true if the given file should be indexed. It decides this by checking the C<file> and C<directory> keys in the C<no_index> property of the distmeta structure. Note that neither the version format nor C<release_status> are considered. C<$filename> should be given in unix format. =head2 should_index_package ... if $meta->should_index_package( $package ); This method returns true if the given package should be indexed. It decides this by checking the C<package> and C<namespace> keys in the C<no_index> property of the distmeta structure. Note that neither the version format nor C<release_status> are considered. =head2 features my @feature_objects = $meta->features; This method returns a list of L<CPAN::Meta::Feature> objects, one for each optional feature described by the distribution's metadata. =head2 feature my $feature_object = $meta->feature( $identifier ); This method returns a L<CPAN::Meta::Feature> object for the optional feature with the given identifier. If no feature with that identifier exists, an exception will be raised. =head2 as_struct my $copy = $meta->as_struct( \%options ); This method returns a deep copy of the object's metadata as an unblessed hash reference. It takes an optional hashref of options. If the hashref contains a C<version> argument, the copied metadata will be converted to the version of the specification and returned. For example: my $old_spec = $meta->as_struct( {version => "1.4"} ); =head2 as_string my $string = $meta->as_string( \%options ); This method returns a serialized copy of the object's metadata as a character string. (The strings are B<not> UTF-8 encoded.) It takes an optional hashref of options. If the hashref contains a C<version> argument, the copied metadata will be converted to the version of the specification and returned. For example: my $string = $meta->as_string( {version => "1.4"} ); For C<version> greater than or equal to 2, the string will be serialized as JSON. For C<version> less than 2, the string will be serialized as YAML. In both cases, the same rules are followed as in the C<save()> method for choosing a serialization backend. =head1 STRING DATA The following methods return a single value, which is the value for the corresponding entry in the distmeta structure. Values should be either undef or strings. =over 4 =item * abstract =item * description =item * dynamic_config =item * generated_by =item * name =item * release_status =item * version =back =head1 LIST DATA These methods return lists of string values, which might be represented in the distmeta structure as arrayrefs or scalars: =over 4 =item * authors =item * keywords =item * licenses =back The C<authors> and C<licenses> methods may also be called as C<author> and C<license>, respectively, to match the field name in the distmeta structure. =head1 MAP DATA These readers return hashrefs of arbitrary unblessed data structures, each described more fully in the specification: =over 4 =item * meta_spec =item * resources =item * provides =item * no_index =item * prereqs =item * optional_features =back =head1 CUSTOM DATA A list of custom keys are available from the C<custom_keys> method and particular keys may be retrieved with the C<custom> method. say $meta->custom($_) for $meta->custom_keys; If a custom key refers to a data structure, a deep clone is returned. =for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config generated_by keywords license licenses meta_spec name no_index optional_features prereqs provides release_status resources version =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 SEE ALSO =over 4 =item * L<CPAN::Meta::Converter> =item * L<CPAN::Meta::Validator> =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta> git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 CONTRIBUTORS =for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern moznion Olaf Alders Olivier Mengue Randy Sims =over 4 =item * Ansgar Burchardt <ansgar@cpan.org> =item * Avar Arnfjord Bjarmason <avar@cpan.org> =item * Christopher J. Madsen <cjm@cpan.org> =item * Chuck Adams <cja987@gmail.com> =item * Cory G Watson <gphat@cpan.org> =item * Damyan Ivanov <dam@cpan.org> =item * Eric Wilhelm <ewilhelm@cpan.org> =item * Graham Knop <haarg@haarg.org> =item * Gregor Hermann <gregoa@debian.org> =item * Karen Etheridge <ether@cpan.org> =item * Kenichi Ishigaki <ishigaki@cpan.org> =item * Ken Williams <kwilliams@cpan.org> =item * Lars Dieckow <daxim@cpan.org> =item * Leon Timmermans <leont@cpan.org> =item * majensen <maj@fortinbras.us> =item * Mark Fowler <markf@cpan.org> =item * Matt S Trout <mst@shadowcat.co.uk> =item * Michael G. Schwern <mschwern@cpan.org> =item * moznion <moznion@gmail.com> =item * Olaf Alders <olaf@wundersolutions.com> =item * Olivier Mengue <dolmen@cpan.org> =item * Randy Sims <randys@thepierianspring.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/Merge.pm 0000444 00000015365 14711217524 0010613 0 ustar 00 use strict; use warnings; package CPAN::Meta::Merge; # VERSION $CPAN::Meta::Merge::VERSION = '2.143240'; use Carp qw/croak/; use Scalar::Util qw/blessed/; use CPAN::Meta::Converter; sub _identical { my ($left, $right, $path) = @_; croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right unless $left eq $right; return $left; } sub _merge { my ($current, $next, $mergers, $path) = @_; for my $key (keys %{$next}) { if (not exists $current->{$key}) { $current->{$key} = $next->{$key}; } elsif (my $merger = $mergers->{$key}) { $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); } elsif ($merger = $mergers->{':default'}) { $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); } else { croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key; } } return $current; } sub _uniq { my %seen = (); return grep { not $seen{$_}++ } @_; } sub _set_addition { my ($left, $right) = @_; return [ +_uniq(@{$left}, @{$right}) ]; } sub _uniq_map { my ($left, $right, $path) = @_; for my $key (keys %{$right}) { if (not exists $left->{$key}) { $left->{$key} = $right->{$key}; } else { croak 'Duplication of element ' . join '.', @{$path}, $key; } } return $left; } sub _improvize { my ($left, $right, $path) = @_; my ($name) = reverse @{$path}; if ($name =~ /^x_/) { if (ref($left) eq 'ARRAY') { return _set_addition($left, $right, $path); } elsif (ref($left) eq 'HASH') { return _uniq_map($left, $right, $path); } else { return _identical($left, $right, $path); } } croak sprintf "Can't merge '%s'", join '.', @{$path}; } sub _optional_features { my ($left, $right, $path) = @_; for my $key (keys %{$right}) { if (not exists $left->{$key}) { $left->{$key} = $right->{$key}; } else { for my $subkey (keys %{ $right->{$key} }) { next if $subkey eq 'prereqs'; if (not exists $left->{$key}{$subkey}) { $left->{$key}{$subkey} = $right->{$key}{$subkey}; } else { Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} }; } } require CPAN::Meta::Prereqs; $left->{$key}{prereqs} = CPAN::Meta::Prereqs->new($left->{$key}{prereqs}) ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs})) ->as_string_hash; } } return $left; } my %default = ( abstract => \&_identical, author => \&_set_addition, dynamic_config => sub { my ($left, $right) = @_; return $left || $right; }, generated_by => sub { my ($left, $right) = @_; return join ', ', _uniq(split(/, /, $left), split(/, /, $right)); }, license => \&_set_addition, 'meta-spec' => { version => \&_identical, url => \&_identical }, name => \&_identical, release_status => \&_identical, version => \&_identical, description => \&_identical, keywords => \&_set_addition, no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ }, optional_features => \&_optional_features, prereqs => sub { require CPAN::Meta::Prereqs; my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1]; return $left->with_merged_prereqs($right)->as_string_hash; }, provides => \&_uniq_map, resources => { license => \&_set_addition, homepage => \&_identical, bugtracker => \&_uniq_map, repository => \&_uniq_map, ':default' => \&_improvize, }, ':default' => \&_improvize, ); sub new { my ($class, %arguments) = @_; croak 'default version required' if not exists $arguments{default_version}; my %mapping = %default; my %extra = %{ $arguments{extra_mappings} || {} }; for my $key (keys %extra) { if (ref($mapping{$key}) eq 'HASH') { $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } }; } else { $mapping{$key} = $extra{$key}; } } return bless { default_version => $arguments{default_version}, mapping => _coerce_mapping(\%mapping, []), }, $class; } my %coderef_for = ( set_addition => \&_set_addition, uniq_map => \&_uniq_map, identical => \&_identical, improvize => \&_improvize, ); sub _coerce_mapping { my ($orig, $map_path) = @_; my %ret; for my $key (keys %{$orig}) { my $value = $orig->{$key}; if (ref($orig->{$key}) eq 'CODE') { $ret{$key} = $value; } elsif (ref($value) eq 'HASH') { my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]); $ret{$key} = sub { my ($left, $right, $path) = @_; return _merge($left, $right, $mapping, [ @{$path} ]); }; } elsif ($coderef_for{$value}) { $ret{$key} = $coderef_for{$value}; } else { croak "Don't know what to do with " . join '.', @{$map_path}, $key; } } return \%ret; } sub merge { my ($self, @items) = @_; my $current = {}; for my $next (@items) { if ( blessed($next) && $next->isa('CPAN::Meta') ) { $next = $next->as_struct; } elsif ( ref($next) eq 'HASH' ) { my $cmc = CPAN::Meta::Converter->new( $next, default_version => $self->{default_version} ); $next = $cmc->upgrade_fragment; } else { croak "Don't know how to merge '$next'"; } $current = _merge($current, $next, $self->{mapping}, []); } return $current; } 1; # ABSTRACT: Merging CPAN Meta fragments __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Merge - Merging CPAN Meta fragments =head1 VERSION version 2.143240 =head1 SYNOPSIS my $merger = CPAN::Meta::Merge->new(default_version => "2"); my $meta = $merger->merge($base, @additional); =head1 DESCRIPTION =head1 METHODS =head2 new This creates a CPAN::Meta::Merge object. It takes one mandatory named argument, C<version>, declaring the version of the meta-spec that must be used for the merge. It can optionally take an C<extra_mappings> argument that allows one to add additional merging functions for specific elements. =head2 merge(@fragments) Merge all C<@fragments> together. It will accept both CPAN::Meta objects and (possibly incomplete) hashrefs of metadata. =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/History.pm 0000444 00000012317 14711217524 0011207 0 ustar 00 # vi:tw=72 use 5.006; use strict; use warnings; package CPAN::Meta::History; # VERSION $CPAN::Meta::History::VERSION = '2.143240'; 1; # ABSTRACT: history of CPAN Meta Spec changes __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::History - history of CPAN Meta Spec changes =head1 VERSION version 2.143240 =head1 DESCRIPTION The CPAN Meta Spec has gone through several iterations. It was originally written in HTML and later revised into POD (though published in HTML generated from the POD). Fields were added, removed or changed, sometimes by design and sometimes to reflect real-world usage after the fact. This document reconstructs the history of the CPAN Meta Spec based on change logs, repository commit messages and the published HTML files. In some cases, particularly prior to version 1.2, the exact version when certain fields were introduced or changed is inconsistent between sources. When in doubt, the published HTML files for versions 1.0 to 1.4 as they existed when version 2 was developed are used as the definitive source. Starting with version 2, the specification document is part of the CPAN-Meta distribution and will be published on CPAN as L<CPAN::Meta::Spec>. Going forward, specification version numbers will be integers and decimal portions will correspond to a release date for the CPAN::Meta library. =head1 HISTORY =head2 Version 2 April 2010 =over =item * Revised spec examples as perl data structures rather than YAML =item * Switched to JSON serialization from YAML =item * Specified allowed version number formats =item * Replaced 'requires', 'build_requires', 'configure_requires', 'recommends' and 'conflicts' with new 'prereqs' data structure divided by I<phase> (configure, build, test, runtime, etc.) and I<relationship> (requires, recommends, suggests, conflicts) =item * Added support for 'develop' phase for requirements for maintaining a list of authoring tools =item * Changed 'license' to a list and revised the set of valid licenses =item * Made 'dynamic_config' mandatory to reduce confusion =item * Changed 'resources' subkey 'repository' to a hash that clarifies repository type, url for browsing and url for checkout =item * Changed 'resources' subkey 'bugtracker' to a hash for either web or mailto resource =item * Changed specification of 'optional_features': =over =item * Added formal specification and usage guide instead of just example =item * Changed to use new prereqs data structure instead of individual keys =back =item * Clarified intended use of 'author' as generalized contact list =item * Added 'release_status' field to indicate stable, testing or unstable status to provide hints to indexers =item * Added 'description' field for a longer description of the distribution =item * Formalized use of "x_" or "X_" for all custom keys not listed in the official spec =back =head2 Version 1.4 June 2008 =over =item * Noted explicit support for 'perl' in prerequisites =item * Added 'configure_requires' prerequisite type =item * Changed 'optional_features' =over =item * Example corrected to show map of maps instead of list of maps (though descriptive text said 'map' even in v1.3) =item * Removed 'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys =back =back =head2 Version 1.3 November 2006 =over =item * Added 'no_index' subkey 'directory' and removed 'dir' to match actual usage in the wild =item * Added a 'repository' subkey to 'resources' =back =head2 Version 1.2 August 2005 =over =item * Re-wrote and restructured spec in POD syntax =item * Changed 'name' to be mandatory =item * Changed 'generated_by' to be mandatory =item * Changed 'license' to be mandatory =item * Added version range specifications for prerequisites =item * Added required 'abstract' field =item * Added required 'author' field =item * Added required 'meta-spec' field to define 'version' (and 'url') of the CPAN Meta Spec used for metadata =item * Added 'provides' field =item * Added 'no_index' field and deprecated 'private' field. 'no_index' subkeys include 'file', 'dir', 'package' and 'namespace' =item * Added 'keywords' field =item * Added 'resources' field with subkeys 'homepage', 'license', and 'bugtracker' =item * Added 'optional_features' field as an alternate under 'recommends'. Includes 'description', 'requires', 'build_requires', 'conflicts', 'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys =item * Removed 'license_uri' field =back =head2 Version 1.1 May 2003 =over =item * Changed 'version' to be mandatory =item * Added 'private' field =item * Added 'license_uri' field =back =head2 Version 1.0 March 2003 =over =item * Original release (in HTML format only) =item * Included 'name', 'version', 'license', 'distribution_type', 'requires', 'recommends', 'build_requires', 'conflicts', 'dynamic_config', 'generated_by' =back =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/YAML.pm 0000444 00000064562 14711217525 0010322 0 ustar 00 use 5.008001; # sane UTF-8 support use strict; use warnings; package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e # XXX-INGY is 5.8.1 too old/broken for utf8? # XXX-XDG Lancaster consensus was that it was sufficient until # proven otherwise $CPAN::Meta::YAML::VERSION = '0.018'; ; # original $VERSION removed by Doppelgaenger ##################################################################### # The CPAN::Meta::YAML API. # # These are the currently documented API functions/methods and # exports: use Exporter; our @ISA = qw{ Exporter }; our @EXPORT = qw{ Load Dump }; our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; ### # Functional/Export API: sub Dump { return CPAN::Meta::YAML->new(@_)->_dump_string; } # XXX-INGY Returning last document seems a bad behavior. # XXX-XDG I think first would seem more natural, but I don't know # that it's worth changing now sub Load { my $self = CPAN::Meta::YAML->_load_string(@_); if ( wantarray ) { return @$self; } else { # To match YAML.pm, return the last document return $self->[-1]; } } # XXX-INGY Do we really need freeze and thaw? # XXX-XDG I don't think so. I'd support deprecating them. BEGIN { *freeze = \&Dump; *thaw = \&Load; } sub DumpFile { my $file = shift; return CPAN::Meta::YAML->new(@_)->_dump_file($file); } sub LoadFile { my $file = shift; my $self = CPAN::Meta::YAML->_load_file($file); if ( wantarray ) { return @$self; } else { # Return only the last document to match YAML.pm, return $self->[-1]; } } ### # Object Oriented API: # Create an empty CPAN::Meta::YAML object # XXX-INGY Why do we use ARRAY object? # NOTE: I get it now, but I think it's confusing and not needed. # Will change it on a branch later, for review. # # XXX-XDG I don't support changing it yet. It's a very well-documented # "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested # we not change it until YAML.pm's own OO API is established so that # users only have one API change to digest, not two sub new { my $class = shift; bless [ @_ ], $class; } # XXX-INGY It probably doesn't matter, and it's probably too late to # change, but 'read/write' are the wrong names. Read and Write # are actions that take data from storage to memory # characters/strings. These take the data to/from storage to native # Perl objects, which the terms dump and load are meant. As long as # this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not # to add new {read,write}_* methods to this API. sub read_string { my $self = shift; $self->_load_string(@_); } sub write_string { my $self = shift; $self->_dump_string(@_); } sub read { my $self = shift; $self->_load_file(@_); } sub write { my $self = shift; $self->_dump_file(@_); } ##################################################################### # Constants # Printed form of the unprintable characters in the lowest range # of ASCII characters, listed by ASCII ordinal position. my @UNPRINTABLE = qw( 0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F ); # Printable characters for escapes my %UNESCAPES = ( 0 => "\x00", z => "\x00", N => "\x85", a => "\x07", b => "\x08", t => "\x09", n => "\x0a", v => "\x0b", f => "\x0c", r => "\x0d", e => "\x1b", '\\' => '\\', ); # XXX-INGY # I(ngy) need to decide if these values should be quoted in # CPAN::Meta::YAML or not. Probably yes. # These 3 values have special meaning when unquoted and using the # default YAML schema. They need quotes if they are strings. my %QUOTE = map { $_ => 1 } qw{ null true false }; # The commented out form is simpler, but overloaded the Perl regex # engine due to recursion and backtracking problems on strings # larger than 32,000ish characters. Keep it for reference purposes. # qr/\"((?:\\.|[^\"])*)\"/ my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/; my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/; # unquoted re gets trailing space that needs to be stripped my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/; my $re_trailing_comment = qr/(?:\s+\#.*)?/; my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/; ##################################################################### # CPAN::Meta::YAML Implementation. # # These are the private methods that do all the work. They may change # at any time. ### # Loader functions: # Create an object from a file sub _load_file { my $class = ref $_[0] ? ref shift : shift; # Check the file my $file = shift or $class->_error( 'You did not specify a file name' ); $class->_error( "File '$file' does not exist" ) unless -e $file; $class->_error( "'$file' is a directory, not a file" ) unless -f _; $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; # Open unbuffered with strict UTF-8 decoding and no translation layers open( my $fh, "<:unix:encoding(UTF-8)", $file ); unless ( $fh ) { $class->_error("Failed to open file '$file': $!"); } # flock if available (or warn if not possible for OS-specific reasons) if ( _can_flock() ) { flock( $fh, Fcntl::LOCK_SH() ) or warn "Couldn't lock '$file' for reading: $!"; } # slurp the contents my $contents = eval { use warnings FATAL => 'utf8'; local $/; <$fh> }; if ( my $err = $@ ) { $class->_error("Error reading from file '$file': $err"); } # close the file (release the lock) unless ( close $fh ) { $class->_error("Failed to close file '$file': $!"); } $class->_load_string( $contents ); } # Create an object from a string sub _load_string { my $class = ref $_[0] ? ref shift : shift; my $self = bless [], $class; my $string = $_[0]; eval { unless ( defined $string ) { die \"Did not provide a string to load"; } # Check if Perl has it marked as characters, but it's internally # inconsistent. E.g. maybe latin1 got read on a :utf8 layer if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { die \<<'...'; Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? ... } # Ensure Unicode character semantics, even for 0x80-0xff utf8::upgrade($string); # Check for and strip any leading UTF-8 BOM $string =~ s/^\x{FEFF}//; # Check for some special cases return $self unless length $string; # Split the file into lines my @lines = grep { ! /^\s*(?:\#.*)?\z/ } split /(?:\015{1,2}\012|\015|\012)/, $string; # Strip the initial YAML header @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; # A nibbling parser my $in_document = 0; while ( @lines ) { # Do we have a document header? if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { # Handle scalar documents shift @lines; if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { push @$self, $self->_load_scalar( "$1", [ undef ], \@lines ); next; } $in_document = 1; } if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { # A naked document push @$self, undef; while ( @lines and $lines[0] !~ /^---/ ) { shift @lines; } $in_document = 0; # XXX The final '-+$' is to look for -- which ends up being an # error later. } elsif ( ! $in_document && @$self ) { # only the first document can be explicit die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) { # An array at the root my $document = [ ]; push @$self, $document; $self->_load_array( $document, [ 0 ], \@lines ); } elsif ( $lines[0] =~ /^(\s*)\S/ ) { # A hash at the root my $document = { }; push @$self, $document; $self->_load_hash( $document, [ length($1) ], \@lines ); } else { # Shouldn't get here. @lines have whitespace-only lines # stripped, and previous match is a line with any # non-whitespace. So this clause should only be reachable via # a perlbug where \s is not symmetric with \S # uncoverable statement die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; } } }; my $err = $@; if ( ref $err eq 'SCALAR' ) { $self->_error(${$err}); } elsif ( $err ) { $self->_error($err); } return $self; } sub _unquote_single { my ($self, $string) = @_; return '' unless length $string; $string =~ s/\'\'/\'/g; return $string; } sub _unquote_double { my ($self, $string) = @_; return '' unless length $string; $string =~ s/\\"/"/g; $string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex; return $string; } # Load a YAML scalar string to the actual Perl scalar sub _load_scalar { my ($self, $string, $indent, $lines) = @_; # Trim trailing whitespace $string =~ s/\s*\z//; # Explitic null/undef return undef if $string eq '~'; # Single quote if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) { return $self->_unquote_single($1); } # Double quote. if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) { return $self->_unquote_double($1); } # Special cases if ( $string =~ /^[\'\"!&]/ ) { die \"CPAN::Meta::YAML does not support a feature in line '$string'"; } return {} if $string =~ /^{}(?:\s+\#.*)?\z/; return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; # Regular unquoted string if ( $string !~ /^[>|]/ ) { die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/; $string =~ s/\s+#.*\z//; return $string; } # Error die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines; # Check the indent depth $lines->[0] =~ /^(\s*)/; $indent->[-1] = length("$1"); if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; } # Pull the lines my @multiline = (); while ( @$lines ) { $lines->[0] =~ /^(\s*)/; last unless length($1) >= $indent->[-1]; push @multiline, substr(shift(@$lines), length($1)); } my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; return join( $j, @multiline ) . $t; } # Load an array sub _load_array { my ($self, $array, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; } if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { # Inline nested hash my $indent2 = length("$1"); $lines->[0] =~ s/-/ /; push @$array, { }; $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { shift @$lines; unless ( @$lines ) { push @$array, undef; return 1; } if ( $lines->[0] =~ /^(\s*)\-/ ) { my $indent2 = length("$1"); if ( $indent->[-1] == $indent2 ) { # Null array entry push @$array, undef; } else { # Naked indenter push @$array, [ ]; $self->_load_array( $array->[-1], [ @$indent, $indent2 ], $lines ); } } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { push @$array, { }; $self->_load_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); } else { die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; } } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { # Array entry with a value shift @$lines; push @$array, $self->_load_scalar( "$2", [ @$indent, undef ], $lines ); } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { # This is probably a structure like the following... # --- # foo: # - list # bar: value # # ... so lets return and let the hash parser handle it return 1; } else { die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; } } return 1; } # Load a hash sub _load_hash { my ($self, $hash, $indent, $lines) = @_; while ( @$lines ) { # Check for a new document if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { while ( @$lines and $lines->[0] !~ /^---/ ) { shift @$lines; } return 1; } # Check the indent level $lines->[0] =~ /^(\s*)/; if ( length($1) < $indent->[-1] ) { return 1; } elsif ( length($1) > $indent->[-1] ) { die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; } # Find the key my $key; # Quoted keys if ( $lines->[0] =~ s/^\s*$re_capture_single_quoted$re_key_value_separator// ) { $key = $self->_unquote_single($1); } elsif ( $lines->[0] =~ s/^\s*$re_capture_double_quoted$re_key_value_separator// ) { $key = $self->_unquote_double($1); } elsif ( $lines->[0] =~ s/^\s*$re_capture_unquoted_key$re_key_value_separator// ) { $key = $1; $key =~ s/\s+$//; } elsif ( $lines->[0] =~ /^\s*\?/ ) { die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"; } else { die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; } if ( exists $hash->{$key} ) { warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"; } # Do we have a value? if ( length $lines->[0] ) { # Yes $hash->{$key} = $self->_load_scalar( shift(@$lines), [ @$indent, undef ], $lines ); } else { # An indent shift @$lines; unless ( @$lines ) { $hash->{$key} = undef; return 1; } if ( $lines->[0] =~ /^(\s*)-/ ) { $hash->{$key} = []; $self->_load_array( $hash->{$key}, [ @$indent, length($1) ], $lines ); } elsif ( $lines->[0] =~ /^(\s*)./ ) { my $indent2 = length("$1"); if ( $indent->[-1] >= $indent2 ) { # Null hash entry $hash->{$key} = undef; } else { $hash->{$key} = {}; $self->_load_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); } } } } return 1; } ### # Dumper functions: # Save an object to a file sub _dump_file { my $self = shift; require Fcntl; # Check the file my $file = shift or $self->_error( 'You did not specify a file name' ); my $fh; # flock if available (or warn if not possible for OS-specific reasons) if ( _can_flock() ) { # Open without truncation (truncate comes after lock) my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT(); sysopen( $fh, $file, $flags ); unless ( $fh ) { $self->_error("Failed to open file '$file' for writing: $!"); } # Use no translation and strict UTF-8 binmode( $fh, ":raw:encoding(UTF-8)"); flock( $fh, Fcntl::LOCK_EX() ) or warn "Couldn't lock '$file' for reading: $!"; # truncate and spew contents truncate $fh, 0; seek $fh, 0, 0; } else { open $fh, ">:unix:encoding(UTF-8)", $file; } # serialize and spew to the handle print {$fh} $self->_dump_string; # close the file (release the lock) unless ( close $fh ) { $self->_error("Failed to close file '$file': $!"); } return 1; } # Save an object to a string sub _dump_string { my $self = shift; return '' unless ref $self && @$self; # Iterate over the documents my $indent = 0; my @lines = (); eval { foreach my $cursor ( @$self ) { push @lines, '---'; # An empty document if ( ! defined $cursor ) { # Do nothing # A scalar document } elsif ( ! ref $cursor ) { $lines[-1] .= ' ' . $self->_dump_scalar( $cursor ); # A list at the root } elsif ( ref $cursor eq 'ARRAY' ) { unless ( @$cursor ) { $lines[-1] .= ' []'; next; } push @lines, $self->_dump_array( $cursor, $indent, {} ); # A hash at the root } elsif ( ref $cursor eq 'HASH' ) { unless ( %$cursor ) { $lines[-1] .= ' {}'; next; } push @lines, $self->_dump_hash( $cursor, $indent, {} ); } else { die \("Cannot serialize " . ref($cursor)); } } }; if ( ref $@ eq 'SCALAR' ) { $self->_error(${$@}); } elsif ( $@ ) { $self->_error($@); } join '', map { "$_\n" } @lines; } sub _has_internal_string_value { my $value = shift; my $b_obj = B::svref_2object(\$value); # for round trip problem return $b_obj->FLAGS & B::SVf_POK(); } sub _dump_scalar { my $string = $_[1]; my $is_key = $_[2]; # Check this before checking length or it winds up looking like a string! my $has_string_flag = _has_internal_string_value($string); return '~' unless defined $string; return "''" unless length $string; if (Scalar::Util::looks_like_number($string)) { # keys and values that have been used as strings get quoted if ( $is_key || $has_string_flag ) { return qq['$string']; } else { return $string; } } if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) { $string =~ s/\\/\\\\/g; $string =~ s/"/\\"/g; $string =~ s/\n/\\n/g; $string =~ s/[\x85]/\\N/g; $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge; return qq|"$string"|; } if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string} ) { return "'$string'"; } return $string; } sub _dump_array { my ($self, $array, $indent, $seen) = @_; if ( $seen->{refaddr($array)}++ ) { die \"CPAN::Meta::YAML does not support circular references"; } my @lines = (); foreach my $el ( @$array ) { my $line = (' ' x $indent) . '-'; my $type = ref $el; if ( ! $type ) { $line .= ' ' . $self->_dump_scalar( $el ); push @lines, $line; } elsif ( $type eq 'ARRAY' ) { if ( @$el ) { push @lines, $line; push @lines, $self->_dump_array( $el, $indent + 1, $seen ); } else { $line .= ' []'; push @lines, $line; } } elsif ( $type eq 'HASH' ) { if ( keys %$el ) { push @lines, $line; push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); } else { $line .= ' {}'; push @lines, $line; } } else { die \"CPAN::Meta::YAML does not support $type references"; } } @lines; } sub _dump_hash { my ($self, $hash, $indent, $seen) = @_; if ( $seen->{refaddr($hash)}++ ) { die \"CPAN::Meta::YAML does not support circular references"; } my @lines = (); foreach my $name ( sort keys %$hash ) { my $el = $hash->{$name}; my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":"; my $type = ref $el; if ( ! $type ) { $line .= ' ' . $self->_dump_scalar( $el ); push @lines, $line; } elsif ( $type eq 'ARRAY' ) { if ( @$el ) { push @lines, $line; push @lines, $self->_dump_array( $el, $indent + 1, $seen ); } else { $line .= ' []'; push @lines, $line; } } elsif ( $type eq 'HASH' ) { if ( keys %$el ) { push @lines, $line; push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); } else { $line .= ' {}'; push @lines, $line; } } else { die \"CPAN::Meta::YAML does not support $type references"; } } @lines; } ##################################################################### # DEPRECATED API methods: # Error storage (DEPRECATED as of 1.57) our $errstr = ''; # Set error sub _error { require Carp; $errstr = $_[1]; $errstr =~ s/ at \S+ line \d+.*//; Carp::croak( $errstr ); } # Retrieve error my $errstr_warned; sub errstr { require Carp; Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" ) unless $errstr_warned++; $errstr; } ##################################################################### # Helper functions. Possibly not needed. # Use to detect nv or iv use B; # XXX-INGY Is flock CPAN::Meta::YAML's responsibility? # Some platforms can't flock :-( # XXX-XDG I think it is. When reading and writing files, we ought # to be locking whenever possible. People (foolishly) use YAML # files for things like session storage, which has race issues. my $HAS_FLOCK; sub _can_flock { if ( defined $HAS_FLOCK ) { return $HAS_FLOCK; } else { require Config; my $c = \%Config::Config; $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/; require Fcntl if $HAS_FLOCK; return $HAS_FLOCK; } } # XXX-INGY Is this core in 5.8.1? Can we remove this? # XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this ##################################################################### # Use Scalar::Util if possible, otherwise emulate it use Scalar::Util (); BEGIN { local $@; if ( eval { Scalar::Util->VERSION(1.18); } ) { *refaddr = *Scalar::Util::refaddr; } else { eval <<'END_PERL'; # Scalar::Util failed to load or too old sub refaddr { my $pkg = ref($_[0]) or return undef; if ( !! UNIVERSAL::can($_[0], 'can') ) { bless $_[0], 'Scalar::Util::Fake'; } else { $pkg = undef; } "$_[0]" =~ /0x(\w+)/; my $i = do { no warnings 'portable'; hex $1 }; bless $_[0], $pkg if defined $pkg; $i; } END_PERL } } delete $CPAN::Meta::YAML::{refaddr}; 1; # XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong # but leaving grey area stuff up here. # # I would like to change Read/Write to Load/Dump below without # changing the actual API names. # # It might be better to put Load/Dump API in the SYNOPSIS instead of the # dubious OO API. # # null and bool explanations may be outdated. =pod =encoding UTF-8 =head1 NAME CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files =head1 VERSION version 0.018 =head1 SYNOPSIS use CPAN::Meta::YAML; # reading a META file open $fh, "<:utf8", "META.yml"; $yaml_text = do { local $/; <$fh> }; $yaml = CPAN::Meta::YAML->read_string($yaml_text) or die CPAN::Meta::YAML->errstr; # finding the metadata $meta = $yaml->[0]; # writing a META file $yaml_text = $yaml->write_string or die CPAN::Meta::YAML->errstr; open $fh, ">:utf8", "META.yml"; print $fh $yaml_text; =head1 DESCRIPTION This module implements a subset of the YAML specification for use in reading and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should not be used for any other general YAML parsing or generation task. NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are responsible for proper encoding and decoding. In particular, the C<read> and C<write> methods do B<not> support UTF-8 and should not be used. =head1 SUPPORT This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If there are bugs in how it parses a particular META.yml file, please file a bug report in the YAML::Tiny bugtracker: L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues> =head1 SEE ALSO L<YAML::Tiny>, L<YAML>, L<YAML::XS> =head1 AUTHORS =over 4 =item * Adam Kennedy <adamk@cpan.org> =item * David Golden <dagolden@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by Adam Kennedy. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ # ABSTRACT: Read and write a subset of YAML for CPAN Meta files perl5/CPAN/Meta/Requirements.pm 0000444 00000076014 14711217530 0012232 0 ustar 00 use 5.006; # keep at v5.6 for CPAN.pm use strict; use warnings; package CPAN::Meta::Requirements; # ABSTRACT: a set of version requirements for a CPAN dist our $VERSION = '2.140'; #pod =head1 SYNOPSIS #pod #pod use CPAN::Meta::Requirements; #pod #pod my $build_requires = CPAN::Meta::Requirements->new; #pod #pod $build_requires->add_minimum('Library::Foo' => 1.208); #pod #pod $build_requires->add_minimum('Library::Foo' => 2.602); #pod #pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); #pod #pod $METAyml->{build_requires} = $build_requires->as_string_hash; #pod #pod =head1 DESCRIPTION #pod #pod A CPAN::Meta::Requirements object models a set of version constraints like #pod those specified in the F<META.yml> or F<META.json> files in CPAN distributions, #pod and as defined by L<CPAN::Meta::Spec>; #pod It can be built up by adding more and more constraints, and it will reduce them #pod to the simplest representation. #pod #pod Logically impossible constraints will be identified immediately by thrown #pod exceptions. #pod #pod =cut use Carp (); # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls # before 5.10, we fall back to the EUMM bundled compatibility version module if # that's the only thing available. This shouldn't ever happen in a normal CPAN # install of CPAN::Meta::Requirements, as version.pm will be picked up from # prereqs and be available at runtime. BEGIN { eval "use version ()"; ## no critic if ( my $err = $@ ) { eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic } } # Perl 5.10.0 didn't have "is_qv" in version.pm *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; # construct once, reuse many times my $V0 = version->new(0); #pod =method new #pod #pod my $req = CPAN::Meta::Requirements->new; #pod #pod This returns a new CPAN::Meta::Requirements object. It takes an optional #pod hash reference argument. Currently, only one key is supported: #pod #pod =for :list #pod * C<bad_version_hook> -- if provided, when a version cannot be parsed into #pod a version object, this code reference will be called with the invalid #pod version string as first argument, and the module name as second #pod argument. It must return a valid version object. #pod #pod All other keys are ignored. #pod #pod =cut my @valid_options = qw( bad_version_hook ); sub new { my ($class, $options) = @_; $options ||= {}; Carp::croak "Argument to $class\->new() must be a hash reference" unless ref $options eq 'HASH'; my %self = map {; $_ => $options->{$_}} @valid_options; return bless \%self => $class; } # from version::vpp sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } # safe if given an unblessed reference sub _isa_version { UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version') } sub _version_object { my ($self, $module, $version) = @_; my ($vobj, $err); if (not defined $version or (!ref($version) && $version eq '0')) { return $V0; } elsif ( ref($version) eq 'version' || ( ref($version) && _isa_version($version) ) ) { $vobj = $version; } else { # hack around version::vpp not handling <3 character vstring literals if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) { my $magic = _find_magic_vstring( $version ); $version = $magic if length $magic; } # pad to 3 characters if before 5.8.1 and appears to be a v-string if ( $] < 5.008001 && $version !~ /\A[0-9]/ && substr($version,0,1) ne 'v' && length($version) < 3 ) { $version .= "\0" x (3 - length($version)); } eval { local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" }; # avoid specific segfault on some older version.pm versions die "Invalid version: $version" if $version eq 'version'; $vobj = version->new($version); }; if ( my $err = $@ ) { my $hook = $self->{bad_version_hook}; $vobj = eval { $hook->($version, $module) } if ref $hook eq 'CODE'; unless (eval { $vobj->isa("version") }) { $err =~ s{ at .* line \d+.*$}{}; die "Can't convert '$version': $err"; } } } # ensure no leading '.' if ( $vobj =~ m{\A\.} ) { $vobj = version->new("0$vobj"); } # ensure normal v-string form if ( _is_qv($vobj) ) { $vobj = version->new($vobj->normal); } return $vobj; } #pod =method add_minimum #pod #pod $req->add_minimum( $module => $version ); #pod #pod This adds a new minimum version requirement. If the new requirement is #pod redundant to the existing specification, this has no effect. #pod #pod Minimum requirements are inclusive. C<$version> is required, along with any #pod greater version number. #pod #pod This method returns the requirements object. #pod #pod =method add_maximum #pod #pod $req->add_maximum( $module => $version ); #pod #pod This adds a new maximum version requirement. If the new requirement is #pod redundant to the existing specification, this has no effect. #pod #pod Maximum requirements are inclusive. No version strictly greater than the given #pod version is allowed. #pod #pod This method returns the requirements object. #pod #pod =method add_exclusion #pod #pod $req->add_exclusion( $module => $version ); #pod #pod This adds a new excluded version. For example, you might use these three #pod method calls: #pod #pod $req->add_minimum( $module => '1.00' ); #pod $req->add_maximum( $module => '1.82' ); #pod #pod $req->add_exclusion( $module => '1.75' ); #pod #pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for #pod 1.75. #pod #pod This method returns the requirements object. #pod #pod =method exact_version #pod #pod $req->exact_version( $module => $version ); #pod #pod This sets the version required for the given module to I<exactly> the given #pod version. No other version would be considered acceptable. #pod #pod This method returns the requirements object. #pod #pod =cut BEGIN { for my $type (qw(maximum exclusion exact_version)) { my $method = "with_$type"; my $to_add = $type eq 'exact_version' ? $type : "add_$type"; my $code = sub { my ($self, $name, $version) = @_; $version = $self->_version_object( $name, $version ); $self->__modify_entry_for($name, $method, $version); return $self; }; no strict 'refs'; *$to_add = $code; } } # add_minimum is optimized compared to generated subs above because # it is called frequently and with "0" or equivalent input sub add_minimum { my ($self, $name, $version) = @_; # stringify $version so that version->new("0.00")->stringify ne "0" # which preserves the user's choice of "0.00" as the requirement if (not defined $version or "$version" eq '0') { return $self if $self->__entry_for($name); Carp::confess("can't add new requirements to finalized requirements") if $self->is_finalized; $self->{requirements}{ $name } = CPAN::Meta::Requirements::_Range::Range->with_minimum($V0, $name); } else { $version = $self->_version_object( $name, $version ); $self->__modify_entry_for($name, 'with_minimum', $version); } return $self; } #pod =method add_requirements #pod #pod $req->add_requirements( $another_req_object ); #pod #pod This method adds all the requirements in the given CPAN::Meta::Requirements #pod object to the requirements object on which it was called. If there are any #pod conflicts, an exception is thrown. #pod #pod This method returns the requirements object. #pod #pod =cut sub add_requirements { my ($self, $req) = @_; for my $module ($req->required_modules) { my $modifiers = $req->__entry_for($module)->as_modifiers; for my $modifier (@$modifiers) { my ($method, @args) = @$modifier; $self->$method($module => @args); }; } return $self; } #pod =method accepts_module #pod #pod my $bool = $req->accepts_module($module => $version); #pod #pod Given an module and version, this method returns true if the version #pod specification for the module accepts the provided version. In other words, #pod given: #pod #pod Module => '>= 1.00, < 2.00' #pod #pod We will accept 1.00 and 1.75 but not 0.50 or 2.00. #pod #pod For modules that do not appear in the requirements, this method will return #pod true. #pod #pod =cut sub accepts_module { my ($self, $module, $version) = @_; $version = $self->_version_object( $module, $version ); return 1 unless my $range = $self->__entry_for($module); return $range->_accepts($version); } #pod =method clear_requirement #pod #pod $req->clear_requirement( $module ); #pod #pod This removes the requirement for a given module from the object. #pod #pod This method returns the requirements object. #pod #pod =cut sub clear_requirement { my ($self, $module) = @_; return $self unless $self->__entry_for($module); Carp::confess("can't clear requirements on finalized requirements") if $self->is_finalized; delete $self->{requirements}{ $module }; return $self; } #pod =method requirements_for_module #pod #pod $req->requirements_for_module( $module ); #pod #pod This returns a string containing the version requirements for a given module in #pod the format described in L<CPAN::Meta::Spec> or undef if the given module has no #pod requirements. This should only be used for informational purposes such as error #pod messages and should not be interpreted or used for comparison (see #pod L</accepts_module> instead). #pod #pod =cut sub requirements_for_module { my ($self, $module) = @_; my $entry = $self->__entry_for($module); return unless $entry; return $entry->as_string; } #pod =method structured_requirements_for_module #pod #pod $req->structured_requirements_for_module( $module ); #pod #pod This returns a data structure containing the version requirements for a given #pod module or undef if the given module has no requirements. This should #pod not be used for version checks (see L</accepts_module> instead). #pod #pod Added in version 2.134. #pod #pod =cut sub structured_requirements_for_module { my ($self, $module) = @_; my $entry = $self->__entry_for($module); return unless $entry; return $entry->as_struct; } #pod =method required_modules #pod #pod This method returns a list of all the modules for which requirements have been #pod specified. #pod #pod =cut sub required_modules { keys %{ $_[0]{requirements} } } #pod =method clone #pod #pod $req->clone; #pod #pod This method returns a clone of the invocant. The clone and the original object #pod can then be changed independent of one another. #pod #pod =cut sub clone { my ($self) = @_; my $new = (ref $self)->new; return $new->add_requirements($self); } sub __entry_for { $_[0]{requirements}{ $_[1] } } sub __modify_entry_for { my ($self, $name, $method, $version) = @_; my $fin = $self->is_finalized; my $old = $self->__entry_for($name); Carp::confess("can't add new requirements to finalized requirements") if $fin and not $old; my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range') ->$method($version, $name); Carp::confess("can't modify finalized requirements") if $fin and $old->as_string ne $new->as_string; $self->{requirements}{ $name } = $new; } #pod =method is_simple #pod #pod This method returns true if and only if all requirements are inclusive minimums #pod -- that is, if their string expression is just the version number. #pod #pod =cut sub is_simple { my ($self) = @_; for my $module ($self->required_modules) { # XXX: This is a complete hack, but also entirely correct. return if $self->__entry_for($module)->as_string =~ /\s/; } return 1; } #pod =method is_finalized #pod #pod This method returns true if the requirements have been finalized by having the #pod C<finalize> method called on them. #pod #pod =cut sub is_finalized { $_[0]{finalized} } #pod =method finalize #pod #pod This method marks the requirements finalized. Subsequent attempts to change #pod the requirements will be fatal, I<if> they would result in a change. If they #pod would not alter the requirements, they have no effect. #pod #pod If a finalized set of requirements is cloned, the cloned requirements are not #pod also finalized. #pod #pod =cut sub finalize { $_[0]{finalized} = 1 } #pod =method as_string_hash #pod #pod This returns a reference to a hash describing the requirements using the #pod strings in the L<CPAN::Meta::Spec> specification. #pod #pod For example after the following program: #pod #pod my $req = CPAN::Meta::Requirements->new; #pod #pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102); #pod #pod $req->add_minimum('Library::Foo' => 1.208); #pod #pod $req->add_maximum('Library::Foo' => 2.602); #pod #pod $req->add_minimum('Module::Bar' => 'v1.2.3'); #pod #pod $req->add_exclusion('Module::Bar' => 'v1.2.8'); #pod #pod $req->exact_version('Xyzzy' => '6.01'); #pod #pod my $hashref = $req->as_string_hash; #pod #pod C<$hashref> would contain: #pod #pod { #pod 'CPAN::Meta::Requirements' => '0.102', #pod 'Library::Foo' => '>= 1.208, <= 2.206', #pod 'Module::Bar' => '>= v1.2.3, != v1.2.8', #pod 'Xyzzy' => '== 6.01', #pod } #pod #pod =cut sub as_string_hash { my ($self) = @_; my %hash = map {; $_ => $self->{requirements}{$_}->as_string } $self->required_modules; return \%hash; } #pod =method add_string_requirement #pod #pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); #pod $req->add_string_requirement('Library::Foo' => v1.208); #pod #pod This method parses the passed in string and adds the appropriate requirement #pod for the given module. A version can be a Perl "v-string". It understands #pod version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For #pod example: #pod #pod =over 4 #pod #pod =item 1.3 #pod #pod =item >= 1.3 #pod #pod =item <= 1.3 #pod #pod =item == 1.3 #pod #pod =item != 1.3 #pod #pod =item > 1.3 #pod #pod =item < 1.3 #pod #pod =item >= 1.3, != 1.5, <= 2.0 #pod #pod A version number without an operator is equivalent to specifying a minimum #pod (C<E<gt>=>). Extra whitespace is allowed. #pod #pod =back #pod #pod =cut my %methods_for_op = ( '==' => [ qw(exact_version) ], '!=' => [ qw(add_exclusion) ], '>=' => [ qw(add_minimum) ], '<=' => [ qw(add_maximum) ], '>' => [ qw(add_minimum add_exclusion) ], '<' => [ qw(add_maximum add_exclusion) ], ); sub add_string_requirement { my ($self, $module, $req) = @_; unless ( defined $req && length $req ) { $req = 0; $self->_blank_carp($module); } my $magic = _find_magic_vstring( $req ); if (length $magic) { $self->add_minimum($module => $magic); return; } my @parts = split qr{\s*,\s*}, $req; for my $part (@parts) { my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z}; if (! defined $op) { $self->add_minimum($module => $part); } else { Carp::confess("illegal requirement string: $req") unless my $methods = $methods_for_op{ $op }; $self->$_($module => $ver) for @$methods; } } } #pod =method from_string_hash #pod #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); #pod #pod This is an alternate constructor for a CPAN::Meta::Requirements #pod object. It takes a hash of module names and version requirement #pod strings and returns a new CPAN::Meta::Requirements object. As with #pod add_string_requirement, a version can be a Perl "v-string". Optionally, #pod you can supply a hash-reference of options, exactly as with the L</new> #pod method. #pod #pod =cut sub _blank_carp { my ($self, $module) = @_; Carp::carp("Undefined requirement for $module treated as '0'"); } sub from_string_hash { my ($class, $hash, $options) = @_; my $self = $class->new($options); for my $module (keys %$hash) { my $req = $hash->{$module}; unless ( defined $req && length $req ) { $req = 0; $class->_blank_carp($module); } $self->add_string_requirement($module, $req); } return $self; } ############################################################## { package CPAN::Meta::Requirements::_Range::Exact; sub _new { bless { version => $_[1] } => $_[0] } sub _accepts { return $_[0]{version} == $_[1] } sub as_string { return "== $_[0]{version}" } sub as_struct { return [ [ '==', "$_[0]{version}" ] ] } sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] } sub _reject_requirements { my ($self, $module, $error) = @_; Carp::confess("illegal requirements for $module: $error") } sub _clone { (ref $_[0])->_new( version->new( $_[0]{version} ) ) } sub with_exact_version { my ($self, $version, $module) = @_; $module = 'module' unless defined $module; return $self->_clone if $self->_accepts($version); $self->_reject_requirements( $module, "can't be exactly $version when exact requirement is already $self->{version}", ); } sub with_minimum { my ($self, $minimum, $module) = @_; $module = 'module' unless defined $module; return $self->_clone if $self->{version} >= $minimum; $self->_reject_requirements( $module, "minimum $minimum exceeds exact specification $self->{version}", ); } sub with_maximum { my ($self, $maximum, $module) = @_; $module = 'module' unless defined $module; return $self->_clone if $self->{version} <= $maximum; $self->_reject_requirements( $module, "maximum $maximum below exact specification $self->{version}", ); } sub with_exclusion { my ($self, $exclusion, $module) = @_; $module = 'module' unless defined $module; return $self->_clone unless $exclusion == $self->{version}; $self->_reject_requirements( $module, "tried to exclude $exclusion, which is already exactly specified", ); } } ############################################################## { package CPAN::Meta::Requirements::_Range::Range; sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) } sub _clone { return (bless { } => $_[0]) unless ref $_[0]; my ($s) = @_; my %guts = ( (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()), (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()), (exists $s->{exclusions} ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ]) : ()), ); bless \%guts => ref($s); } sub as_modifiers { my ($self) = @_; my @mods; push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum}; push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum}; push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []}; return \@mods; } sub as_struct { my ($self) = @_; return 0 if ! keys %$self; my @exclusions = @{ $self->{exclusions} || [] }; my @parts; for my $tuple ( [ qw( >= > minimum ) ], [ qw( <= < maximum ) ], ) { my ($op, $e_op, $k) = @$tuple; if (exists $self->{$k}) { my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions; if (@new_exclusions == @exclusions) { push @parts, [ $op, "$self->{ $k }" ]; } else { push @parts, [ $e_op, "$self->{ $k }" ]; @exclusions = @new_exclusions; } } } push @parts, map {; [ "!=", "$_" ] } @exclusions; return \@parts; } sub as_string { my ($self) = @_; my @parts = @{ $self->as_struct }; return $parts[0][1] if @parts == 1 and $parts[0][0] eq '>='; return join q{, }, map {; join q{ }, @$_ } @parts; } sub _reject_requirements { my ($self, $module, $error) = @_; Carp::confess("illegal requirements for $module: $error") } sub with_exact_version { my ($self, $version, $module) = @_; $module = 'module' unless defined $module; $self = $self->_clone; unless ($self->_accepts($version)) { $self->_reject_requirements( $module, "exact specification $version outside of range " . $self->as_string ); } return CPAN::Meta::Requirements::_Range::Exact->_new($version); } sub _simplify { my ($self, $module) = @_; if (defined $self->{minimum} and defined $self->{maximum}) { if ($self->{minimum} == $self->{maximum}) { if (grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }) { $self->_reject_requirements( $module, "minimum and maximum are both $self->{minimum}, which is excluded", ); } return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum}) } if ($self->{minimum} > $self->{maximum}) { $self->_reject_requirements( $module, "minimum $self->{minimum} exceeds maximum $self->{maximum}", ); } } # eliminate irrelevant exclusions if ($self->{exclusions}) { my %seen; @{ $self->{exclusions} } = grep { (! defined $self->{minimum} or $_ >= $self->{minimum}) and (! defined $self->{maximum} or $_ <= $self->{maximum}) and ! $seen{$_}++ } @{ $self->{exclusions} }; } return $self; } sub with_minimum { my ($self, $minimum, $module) = @_; $module = 'module' unless defined $module; $self = $self->_clone; if (defined (my $old_min = $self->{minimum})) { $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0]; } else { $self->{minimum} = $minimum; } return $self->_simplify($module); } sub with_maximum { my ($self, $maximum, $module) = @_; $module = 'module' unless defined $module; $self = $self->_clone; if (defined (my $old_max = $self->{maximum})) { $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0]; } else { $self->{maximum} = $maximum; } return $self->_simplify($module); } sub with_exclusion { my ($self, $exclusion, $module) = @_; $module = 'module' unless defined $module; $self = $self->_clone; push @{ $self->{exclusions} ||= [] }, $exclusion; return $self->_simplify($module); } sub _accepts { my ($self, $version) = @_; return if defined $self->{minimum} and $version < $self->{minimum}; return if defined $self->{maximum} and $version > $self->{maximum}; return if defined $self->{exclusions} and grep { $version == $_ } @{ $self->{exclusions} }; return 1; } } 1; # vim: ts=2 sts=2 sw=2 et: __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Requirements - a set of version requirements for a CPAN dist =head1 VERSION version 2.140 =head1 SYNOPSIS use CPAN::Meta::Requirements; my $build_requires = CPAN::Meta::Requirements->new; $build_requires->add_minimum('Library::Foo' => 1.208); $build_requires->add_minimum('Library::Foo' => 2.602); $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); $METAyml->{build_requires} = $build_requires->as_string_hash; =head1 DESCRIPTION A CPAN::Meta::Requirements object models a set of version constraints like those specified in the F<META.yml> or F<META.json> files in CPAN distributions, and as defined by L<CPAN::Meta::Spec>; It can be built up by adding more and more constraints, and it will reduce them to the simplest representation. Logically impossible constraints will be identified immediately by thrown exceptions. =head1 METHODS =head2 new my $req = CPAN::Meta::Requirements->new; This returns a new CPAN::Meta::Requirements object. It takes an optional hash reference argument. Currently, only one key is supported: =over 4 =item * C<bad_version_hook> -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object. =back All other keys are ignored. =head2 add_minimum $req->add_minimum( $module => $version ); This adds a new minimum version requirement. If the new requirement is redundant to the existing specification, this has no effect. Minimum requirements are inclusive. C<$version> is required, along with any greater version number. This method returns the requirements object. =head2 add_maximum $req->add_maximum( $module => $version ); This adds a new maximum version requirement. If the new requirement is redundant to the existing specification, this has no effect. Maximum requirements are inclusive. No version strictly greater than the given version is allowed. This method returns the requirements object. =head2 add_exclusion $req->add_exclusion( $module => $version ); This adds a new excluded version. For example, you might use these three method calls: $req->add_minimum( $module => '1.00' ); $req->add_maximum( $module => '1.82' ); $req->add_exclusion( $module => '1.75' ); Any version between 1.00 and 1.82 inclusive would be acceptable, except for 1.75. This method returns the requirements object. =head2 exact_version $req->exact_version( $module => $version ); This sets the version required for the given module to I<exactly> the given version. No other version would be considered acceptable. This method returns the requirements object. =head2 add_requirements $req->add_requirements( $another_req_object ); This method adds all the requirements in the given CPAN::Meta::Requirements object to the requirements object on which it was called. If there are any conflicts, an exception is thrown. This method returns the requirements object. =head2 accepts_module my $bool = $req->accepts_module($module => $version); Given an module and version, this method returns true if the version specification for the module accepts the provided version. In other words, given: Module => '>= 1.00, < 2.00' We will accept 1.00 and 1.75 but not 0.50 or 2.00. For modules that do not appear in the requirements, this method will return true. =head2 clear_requirement $req->clear_requirement( $module ); This removes the requirement for a given module from the object. This method returns the requirements object. =head2 requirements_for_module $req->requirements_for_module( $module ); This returns a string containing the version requirements for a given module in the format described in L<CPAN::Meta::Spec> or undef if the given module has no requirements. This should only be used for informational purposes such as error messages and should not be interpreted or used for comparison (see L</accepts_module> instead). =head2 structured_requirements_for_module $req->structured_requirements_for_module( $module ); This returns a data structure containing the version requirements for a given module or undef if the given module has no requirements. This should not be used for version checks (see L</accepts_module> instead). Added in version 2.134. =head2 required_modules This method returns a list of all the modules for which requirements have been specified. =head2 clone $req->clone; This method returns a clone of the invocant. The clone and the original object can then be changed independent of one another. =head2 is_simple This method returns true if and only if all requirements are inclusive minimums -- that is, if their string expression is just the version number. =head2 is_finalized This method returns true if the requirements have been finalized by having the C<finalize> method called on them. =head2 finalize This method marks the requirements finalized. Subsequent attempts to change the requirements will be fatal, I<if> they would result in a change. If they would not alter the requirements, they have no effect. If a finalized set of requirements is cloned, the cloned requirements are not also finalized. =head2 as_string_hash This returns a reference to a hash describing the requirements using the strings in the L<CPAN::Meta::Spec> specification. For example after the following program: my $req = CPAN::Meta::Requirements->new; $req->add_minimum('CPAN::Meta::Requirements' => 0.102); $req->add_minimum('Library::Foo' => 1.208); $req->add_maximum('Library::Foo' => 2.602); $req->add_minimum('Module::Bar' => 'v1.2.3'); $req->add_exclusion('Module::Bar' => 'v1.2.8'); $req->exact_version('Xyzzy' => '6.01'); my $hashref = $req->as_string_hash; C<$hashref> would contain: { 'CPAN::Meta::Requirements' => '0.102', 'Library::Foo' => '>= 1.208, <= 2.206', 'Module::Bar' => '>= v1.2.3, != v1.2.8', 'Xyzzy' => '== 6.01', } =head2 add_string_requirement $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); $req->add_string_requirement('Library::Foo' => v1.208); This method parses the passed in string and adds the appropriate requirement for the given module. A version can be a Perl "v-string". It understands version ranges as described in the L<CPAN::Meta::Spec/Version Ranges>. For example: =over 4 =item 1.3 =item >= 1.3 =item <= 1.3 =item == 1.3 =item != 1.3 =item > 1.3 =item < 1.3 =item >= 1.3, != 1.5, <= 2.0 A version number without an operator is equivalent to specifying a minimum (C<E<gt>=>). Extra whitespace is allowed. =back =head2 from_string_hash my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); This is an alternate constructor for a CPAN::Meta::Requirements object. It takes a hash of module names and version requirement strings and returns a new CPAN::Meta::Requirements object. As with add_string_requirement, a version can be a Perl "v-string". Optionally, you can supply a hash-reference of options, exactly as with the L</new> method. =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements> git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 CONTRIBUTORS =for stopwords Ed J Karen Etheridge Leon Timmermans robario =over 4 =item * Ed J <mohawk2@users.noreply.github.com> =item * Karen Etheridge <ether@cpan.org> =item * Leon Timmermans <fawaka@gmail.com> =item * robario <webmaster@robario.com> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/Feature.pm 0000444 00000006430 14711217531 0011136 0 ustar 00 use 5.006; use strict; use warnings; package CPAN::Meta::Feature; # VERSION $CPAN::Meta::Feature::VERSION = '2.143240'; use CPAN::Meta::Prereqs; #pod =head1 DESCRIPTION #pod #pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN #pod distribution and specified in the distribution's F<META.json> (or F<META.yml>) #pod file. #pod #pod For the most part, this class will only be used when operating on the result of #pod the C<feature> or C<features> methods on a L<CPAN::Meta> object. #pod #pod =method new #pod #pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); #pod #pod This returns a new Feature object. The C<%spec> argument to the constructor #pod should be the same as the value of the C<optional_feature> entry in the #pod distmeta. It must contain entries for C<description> and C<prereqs>. #pod #pod =cut sub new { my ($class, $identifier, $spec) = @_; my %guts = ( identifier => $identifier, description => $spec->{description}, prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}), ); bless \%guts => $class; } #pod =method identifier #pod #pod This method returns the feature's identifier. #pod #pod =cut sub identifier { $_[0]{identifier} } #pod =method description #pod #pod This method returns the feature's long description. #pod #pod =cut sub description { $_[0]{description} } #pod =method prereqs #pod #pod This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs> #pod object. #pod #pod =cut sub prereqs { $_[0]{prereqs} } 1; # ABSTRACT: an optional feature provided by a CPAN distribution __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Feature - an optional feature provided by a CPAN distribution =head1 VERSION version 2.143240 =head1 DESCRIPTION A CPAN::Meta::Feature object describes an optional feature offered by a CPAN distribution and specified in the distribution's F<META.json> (or F<META.yml>) file. For the most part, this class will only be used when operating on the result of the C<feature> or C<features> methods on a L<CPAN::Meta> object. =head1 METHODS =head2 new my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); This returns a new Feature object. The C<%spec> argument to the constructor should be the same as the value of the C<optional_feature> entry in the distmeta. It must contain entries for C<description> and C<prereqs>. =head2 identifier This method returns the feature's identifier. =head2 description This method returns the feature's long description. =head2 prereqs This method returns the feature's prerequisites as a L<CPAN::Meta::Prereqs> object. =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/Converter.pm 0000444 00000140237 14711217532 0011517 0 ustar 00 use 5.006; use strict; use warnings; package CPAN::Meta::Converter; # VERSION $CPAN::Meta::Converter::VERSION = '2.143240'; #pod =head1 SYNOPSIS #pod #pod my $struct = decode_json_file('META.json'); #pod #pod my $cmc = CPAN::Meta::Converter->new( $struct ); #pod #pod my $new_struct = $cmc->convert( version => "2" ); #pod #pod =head1 DESCRIPTION #pod #pod This module converts CPAN Meta structures from one form to another. The #pod primary use is to convert older structures to the most modern version of #pod the specification, but other transformations may be implemented in the #pod future as needed. (E.g. stripping all custom fields or stripping all #pod optional fields.) #pod #pod =cut use CPAN::Meta::Validator; use CPAN::Meta::Requirements; use Parse::CPAN::Meta 1.4400 (); # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls # before 5.10, we fall back to the EUMM bundled compatibility version module if # that's the only thing available. This shouldn't ever happen in a normal CPAN # install of CPAN::Meta::Requirements, as version.pm will be picked up from # prereqs and be available at runtime. BEGIN { eval "use version ()"; ## no critic if ( my $err = $@ ) { eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic } } # Perl 5.10.0 didn't have "is_qv" in version.pm *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; sub _dclone { my $ref = shift; # if an object is in the data structure and doesn't specify how to # turn itself into JSON, we just stringify the object. That does the # right thing for typical things that might be there, like version objects, # Path::Class objects, etc. no warnings 'once'; no warnings 'redefine'; local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; my $json = Parse::CPAN::Meta->json_backend()->new ->utf8 ->allow_blessed ->convert_blessed; $json->decode($json->encode($ref)) } my %known_specs = ( '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' ); my @spec_list = sort { $a <=> $b } keys %known_specs; my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; #--------------------------------------------------------------------------# # converters # # called as $converter->($element, $field_name, $full_meta, $to_version) # # defined return value used for field # undef return value means field is skipped #--------------------------------------------------------------------------# sub _keep { $_[0] } sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } sub _generated_by { my $gen = shift; my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>"); return $sig unless defined $gen and length $gen; return $gen if $gen =~ /\Q$sig/; return "$gen, $sig"; } sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } sub _prefix_custom { my $key = shift; $key =~ s/^(?!x_) # Unless it already starts with x_ (?:x-?)? # Remove leading x- or x (if present) /x_/ix; # and prepend x_ return $key; } sub _ucfirst_custom { my $key = shift; $key = ucfirst $key unless $key =~ /[A-Z]/; return $key; } sub _no_prefix_ucfirst_custom { my $key = shift; $key =~ s/^x_//; return _ucfirst_custom($key); } sub _change_meta_spec { my ($element, undef, undef, $version) = @_; return { version => $version, url => $known_specs{$version}, }; } my @open_source = ( 'perl', 'gpl', 'apache', 'artistic', 'artistic_2', 'lgpl', 'bsd', 'gpl', 'mit', 'mozilla', 'open_source', ); my %is_open_source = map {; $_ => 1 } @open_source; my @valid_licenses_1 = ( @open_source, 'unrestricted', 'restrictive', 'unknown', ); my %license_map_1 = ( ( map { $_ => $_ } @valid_licenses_1 ), artistic2 => 'artistic_2', ); sub _license_1 { my ($element) = @_; return 'unknown' unless defined $element; if ( $license_map_1{lc $element} ) { return $license_map_1{lc $element}; } else { return 'unknown'; } } my @valid_licenses_2 = qw( agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown ); # The "old" values were defined by Module::Build, and were often vague. I have # made the decisions below based on reading Module::Build::API and how clearly # it specifies the version of the license. my %license_map_2 = ( (map { $_ => $_ } @valid_licenses_2), apache => 'apache_2_0', # clearly stated as 2.0 artistic => 'artistic_1', # clearly stated as 1 artistic2 => 'artistic_2', # clearly stated as 2 gpl => 'open_source', # we don't know which GPL; punt lgpl => 'open_source', # we don't know which LGPL; punt mozilla => 'open_source', # we don't know which MPL; punt perl => 'perl_5', # clearly Perl 5 restrictive => 'restricted', ); sub _license_2 { my ($element) = @_; return [ 'unknown' ] unless defined $element; $element = [ $element ] unless ref $element eq 'ARRAY'; my @new_list; for my $lic ( @$element ) { next unless defined $lic; if ( my $new = $license_map_2{lc $lic} ) { push @new_list, $new; } } return @new_list ? \@new_list : [ 'unknown' ]; } my %license_downgrade_map = qw( agpl_3 open_source apache_1_1 apache apache_2_0 apache artistic_1 artistic artistic_2 artistic_2 bsd bsd freebsd open_source gfdl_1_2 open_source gfdl_1_3 open_source gpl_1 gpl gpl_2 gpl gpl_3 gpl lgpl_2_1 lgpl lgpl_3_0 lgpl mit mit mozilla_1_0 mozilla mozilla_1_1 mozilla openssl open_source perl_5 perl qpl_1_0 open_source ssleay open_source sun open_source zlib open_source open_source open_source restricted restrictive unrestricted unrestricted unknown unknown ); sub _downgrade_license { my ($element) = @_; if ( ! defined $element ) { return "unknown"; } elsif( ref $element eq 'ARRAY' ) { if ( @$element > 1) { if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) { return 'unknown'; } else { return 'open_source'; } } elsif ( @$element == 1 ) { return $license_downgrade_map{lc $element->[0]} || "unknown"; } } elsif ( ! ref $element ) { return $license_downgrade_map{lc $element} || "unknown"; } return "unknown"; } my $no_index_spec_1_2 = { 'file' => \&_listify, 'dir' => \&_listify, 'package' => \&_listify, 'namespace' => \&_listify, }; my $no_index_spec_1_3 = { 'file' => \&_listify, 'directory' => \&_listify, 'package' => \&_listify, 'namespace' => \&_listify, }; my $no_index_spec_2 = { 'file' => \&_listify, 'directory' => \&_listify, 'package' => \&_listify, 'namespace' => \&_listify, ':custom' => \&_prefix_custom, }; sub _no_index_1_2 { my (undef, undef, $meta) = @_; my $no_index = $meta->{no_index} || $meta->{private}; return unless $no_index; # cleanup wrong format if ( ! ref $no_index ) { my $item = $no_index; $no_index = { dir => [ $item ], file => [ $item ] }; } elsif ( ref $no_index eq 'ARRAY' ) { my $list = $no_index; $no_index = { dir => [ @$list ], file => [ @$list ] }; } # common mistake: files -> file if ( exists $no_index->{files} ) { $no_index->{file} = delete $no_index->{file}; } # common mistake: modules -> module if ( exists $no_index->{modules} ) { $no_index->{module} = delete $no_index->{module}; } return _convert($no_index, $no_index_spec_1_2); } sub _no_index_directory { my ($element, $key, $meta, $version) = @_; return unless $element; # cleanup wrong format if ( ! ref $element ) { my $item = $element; $element = { directory => [ $item ], file => [ $item ] }; } elsif ( ref $element eq 'ARRAY' ) { my $list = $element; $element = { directory => [ @$list ], file => [ @$list ] }; } if ( exists $element->{dir} ) { $element->{directory} = delete $element->{dir}; } # common mistake: files -> file if ( exists $element->{files} ) { $element->{file} = delete $element->{file}; } # common mistake: modules -> module if ( exists $element->{modules} ) { $element->{module} = delete $element->{module}; } my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; return _convert($element, $spec); } sub _is_module_name { my $mod = shift; return unless defined $mod && length $mod; return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; } sub _clean_version { my ($element) = @_; return 0 if ! defined $element; $element =~ s{^\s*}{}; $element =~ s{\s*$}{}; $element =~ s{^\.}{0.}; return 0 if ! length $element; return 0 if ( $element eq 'undef' || $element eq '<undef>' ); my $v = eval { version->new($element) }; # XXX check defined $v and not just $v because version objects leak memory # in boolean context -- dagolden, 2012-02-03 if ( defined $v ) { return _is_qv($v) ? $v->normal : $element; } else { return 0; } } sub _bad_version_hook { my ($v) = @_; $v =~ s{[a-z]+$}{}; # strip trailing alphabetics my $vobj = eval { version->new($v) }; return defined($vobj) ? $vobj : version->new(0); # or give up } sub _version_map { my ($element) = @_; return unless defined $element; if ( ref $element eq 'HASH' ) { # XXX turn this into CPAN::Meta::Requirements with bad version hook # and then turn it back into a hash my $new_map = CPAN::Meta::Requirements->new( { bad_version_hook => \&_bad_version_hook } # punt ); while ( my ($k,$v) = each %$element ) { next unless _is_module_name($k); if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) { $v = 0; } # some weird, old META have bad yml with module => module # so check if value is like a module name and not like a version if ( _is_module_name($v) && ! version::is_lax($v) ) { $new_map->add_minimum($k => 0); $new_map->add_minimum($v => 0); } $new_map->add_string_requirement($k => $v); } return $new_map->as_string_hash; } elsif ( ref $element eq 'ARRAY' ) { my $hashref = { map { $_ => 0 } @$element }; return _version_map($hashref); # cleanup any weird stuff } elsif ( ref $element eq '' && length $element ) { return { $element => 0 } } return; } sub _prereqs_from_1 { my (undef, undef, $meta) = @_; my $prereqs = {}; for my $phase ( qw/build configure/ ) { my $key = "${phase}_requires"; $prereqs->{$phase}{requires} = _version_map($meta->{$key}) if $meta->{$key}; } for my $rel ( qw/requires recommends conflicts/ ) { $prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) if $meta->{$rel}; } return $prereqs; } my $prereqs_spec = { configure => \&_prereqs_rel, build => \&_prereqs_rel, test => \&_prereqs_rel, runtime => \&_prereqs_rel, develop => \&_prereqs_rel, ':custom' => \&_prefix_custom, }; my $relation_spec = { requires => \&_version_map, recommends => \&_version_map, suggests => \&_version_map, conflicts => \&_version_map, ':custom' => \&_prefix_custom, }; sub _cleanup_prereqs { my ($prereqs, $key, $meta, $to_version) = @_; return unless $prereqs && ref $prereqs eq 'HASH'; return _convert( $prereqs, $prereqs_spec, $to_version ); } sub _prereqs_rel { my ($relation, $key, $meta, $to_version) = @_; return unless $relation && ref $relation eq 'HASH'; return _convert( $relation, $relation_spec, $to_version ); } BEGIN { my @old_prereqs = qw( requires configure_requires recommends conflicts ); for ( @old_prereqs ) { my $sub = "_get_$_"; my ($phase,$type) = split qr/_/, $_; if ( ! defined $type ) { $type = $phase; $phase = 'runtime'; } no strict 'refs'; *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; } } sub _get_build_requires { my ($data, $key, $meta) = @_; my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); $test_req->add_requirements($build_req)->as_string_hash; } sub _extract_prereqs { my ($prereqs, $phase, $type) = @_; return unless ref $prereqs eq 'HASH'; return scalar _version_map($prereqs->{$phase}{$type}); } sub _downgrade_optional_features { my (undef, undef, $meta) = @_; return unless exists $meta->{optional_features}; my $origin = $meta->{optional_features}; my $features = {}; for my $name ( keys %$origin ) { $features->{$name} = { description => $origin->{$name}{description}, requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), }; for my $k (keys %{$features->{$name}} ) { delete $features->{$name}{$k} unless defined $features->{$name}{$k}; } } return $features; } sub _upgrade_optional_features { my (undef, undef, $meta) = @_; return unless exists $meta->{optional_features}; my $origin = $meta->{optional_features}; my $features = {}; for my $name ( keys %$origin ) { $features->{$name} = { description => $origin->{$name}{description}, prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), }; delete $features->{$name}{prereqs}{configure}; } return $features; } my $optional_features_2_spec = { description => \&_keep, prereqs => \&_cleanup_prereqs, ':custom' => \&_prefix_custom, }; sub _feature_2 { my ($element, $key, $meta, $to_version) = @_; return unless $element && ref $element eq 'HASH'; _convert( $element, $optional_features_2_spec, $to_version ); } sub _cleanup_optional_features_2 { my ($element, $key, $meta, $to_version) = @_; return unless $element && ref $element eq 'HASH'; my $new_data = {}; for my $k ( keys %$element ) { $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); } return unless keys %$new_data; return $new_data; } sub _optional_features_1_4 { my ($element) = @_; return unless $element; $element = _optional_features_as_map($element); for my $name ( keys %$element ) { for my $drop ( qw/requires_packages requires_os excluded_os/ ) { delete $element->{$name}{$drop}; } } return $element; } sub _optional_features_as_map { my ($element) = @_; return unless $element; if ( ref $element eq 'ARRAY' ) { my %map; for my $feature ( @$element ) { my (@parts) = %$feature; $map{$parts[0]} = $parts[1]; } $element = \%map; } return $element; } sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } sub _url_or_drop { my ($element) = @_; return $element if _is_urlish($element); return; } sub _url_list { my ($element) = @_; return unless $element; $element = _listify( $element ); $element = [ grep { _is_urlish($_) } @$element ]; return unless @$element; return $element; } sub _author_list { my ($element) = @_; return [ 'unknown' ] unless $element; $element = _listify( $element ); $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; return [ 'unknown' ] unless @$element; return $element; } my $resource2_upgrade = { license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, homepage => \&_url_or_drop, bugtracker => sub { my ($item) = @_; return unless $item; if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } elsif( _is_urlish($item) ) { return { web => $item } } else { return } }, repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, ':custom' => \&_prefix_custom, }; sub _upgrade_resources_2 { my (undef, undef, $meta, $version) = @_; return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource2_upgrade); } my $bugtracker2_spec = { web => \&_url_or_drop, mailto => \&_keep, ':custom' => \&_prefix_custom, }; sub _repo_type { my ($element, $key, $meta, $to_version) = @_; return $element if defined $element; return unless exists $meta->{url}; my $repo_url = $meta->{url}; for my $type ( qw/git svn/ ) { return $type if $repo_url =~ m{\A$type}; } return; } my $repository2_spec = { web => \&_url_or_drop, url => \&_url_or_drop, type => \&_repo_type, ':custom' => \&_prefix_custom, }; my $resources2_cleanup = { license => \&_url_list, homepage => \&_url_or_drop, bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, ':custom' => \&_prefix_custom, }; sub _cleanup_resources_2 { my ($resources, $key, $meta, $to_version) = @_; return unless $resources && ref $resources eq 'HASH'; return _convert($resources, $resources2_cleanup, $to_version); } my $resource1_spec = { license => \&_url_or_drop, homepage => \&_url_or_drop, bugtracker => \&_url_or_drop, repository => \&_url_or_drop, ':custom' => \&_keep, }; sub _resources_1_3 { my (undef, undef, $meta, $version) = @_; return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource1_spec); } *_resources_1_4 = *_resources_1_3; sub _resources_1_2 { my (undef, undef, $meta) = @_; my $resources = $meta->{resources} || {}; if ( $meta->{license_url} && ! $resources->{license} ) { $resources->{license} = $meta->{license_url} if _is_urlish($meta->{license_url}); } return unless keys %$resources; return _convert($resources, $resource1_spec); } my $resource_downgrade_spec = { license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, homepage => \&_url_or_drop, bugtracker => sub { return $_[0]->{web} }, repository => sub { return $_[0]->{url} || $_[0]->{web} }, ':custom' => \&_no_prefix_ucfirst_custom, }; sub _downgrade_resources { my (undef, undef, $meta, $version) = @_; return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource_downgrade_spec); } sub _release_status { my ($element, undef, $meta) = @_; return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; return _release_status_from_version(undef, undef, $meta); } sub _release_status_from_version { my (undef, undef, $meta) = @_; my $version = $meta->{version} || ''; return ( $version =~ /_/ ) ? 'testing' : 'stable'; } my $provides_spec = { file => \&_keep, version => \&_keep, }; my $provides_spec_2 = { file => \&_keep, version => \&_keep, ':custom' => \&_prefix_custom, }; sub _provides { my ($element, $key, $meta, $to_version) = @_; return unless defined $element && ref $element eq 'HASH'; my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; my $new_data = {}; for my $k ( keys %$element ) { $new_data->{$k} = _convert($element->{$k}, $spec, $to_version); $new_data->{$k}{version} = _clean_version($element->{$k}{version}) if exists $element->{$k}{version}; } return $new_data; } sub _convert { my ($data, $spec, $to_version, $is_fragment) = @_; my $new_data = {}; for my $key ( keys %$spec ) { next if $key eq ':custom' || $key eq ':drop'; next unless my $fcn = $spec->{$key}; if ( $is_fragment && $key eq 'generated_by' ) { $fcn = \&_keep; } die "spec for '$key' is not a coderef" unless ref $fcn && ref $fcn eq 'CODE'; my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); $new_data->{$key} = $new_value if defined $new_value; } my $drop_list = $spec->{':drop'}; my $customizer = $spec->{':custom'} || \&_keep; for my $key ( keys %$data ) { next if $drop_list && grep { $key eq $_ } @$drop_list; next if exists $spec->{$key}; # we handled it $new_data->{ $customizer->($key) } = $data->{$key}; } return $new_data; } #--------------------------------------------------------------------------# # define converters for each conversion #--------------------------------------------------------------------------# # each converts from prior version # special ":custom" field is used for keys not recognized in spec my %up_convert = ( '2-from-1.4' => { # PRIOR MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_2, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # CHANGED TO MANDATORY 'dynamic_config' => \&_keep_or_one, # ADDED MANDATORY 'release_status' => \&_release_status_from_version, # PRIOR OPTIONAL 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_upgrade_optional_features, 'provides' => \&_provides, 'resources' => \&_upgrade_resources_2, # ADDED OPTIONAL 'description' => \&_keep, 'prereqs' => \&_prereqs_from_1, # drop these deprecated fields, but only after we convert ':drop' => [ qw( build_requires configure_requires conflicts distribution_type license_url private recommends requires ) ], # other random keys need x_ prefixing ':custom' => \&_prefix_custom, }, '1.4-from-1.3' => { # PRIOR MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_optional_features_1_4, 'provides' => \&_provides, 'recommends' => \&_version_map, 'requires' => \&_version_map, 'resources' => \&_resources_1_4, # ADDED OPTIONAL 'configure_requires' => \&_keep, # drop these deprecated fields, but only after we convert ':drop' => [ qw( license_url private )], # other random keys are OK if already valid ':custom' => \&_keep }, '1.3-from-1.2' => { # PRIOR MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_optional_features_as_map, 'provides' => \&_provides, 'recommends' => \&_version_map, 'requires' => \&_version_map, 'resources' => \&_resources_1_3, # drop these deprecated fields, but only after we convert ':drop' => [ qw( license_url private )], # other random keys are OK if already valid ':custom' => \&_keep }, '1.2-from-1.1' => { # PRIOR MANDATORY 'version' => \&_keep, # CHANGED TO MANDATORY 'license' => \&_license_1, 'name' => \&_keep, 'generated_by' => \&_generated_by, # ADDED MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'meta-spec' => \&_change_meta_spec, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'recommends' => \&_version_map, 'requires' => \&_version_map, # ADDED OPTIONAL 'keywords' => \&_keep, 'no_index' => \&_no_index_1_2, 'optional_features' => \&_optional_features_as_map, 'provides' => \&_provides, 'resources' => \&_resources_1_2, # drop these deprecated fields, but only after we convert ':drop' => [ qw( license_url private )], # other random keys are OK if already valid ':custom' => \&_keep }, '1.1-from-1.0' => { # CHANGED TO MANDATORY 'version' => \&_keep, # IMPLIED MANDATORY 'name' => \&_keep, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'recommends' => \&_version_map, 'requires' => \&_version_map, # ADDED OPTIONAL 'license_url' => \&_url_or_drop, 'private' => \&_keep, # other random keys are OK if already valid ':custom' => \&_keep }, ); my %down_convert = ( '1.4-from-2' => { # MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_downgrade_license, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # OPTIONAL 'build_requires' => \&_get_build_requires, 'configure_requires' => \&_get_configure_requires, 'conflicts' => \&_get_conflicts, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_downgrade_optional_features, 'provides' => \&_provides, 'recommends' => \&_get_recommends, 'requires' => \&_get_requires, 'resources' => \&_downgrade_resources, # drop these unsupported fields (after conversion) ':drop' => [ qw( description prereqs release_status )], # custom keys will be left unchanged ':custom' => \&_keep }, '1.3-from-1.4' => { # MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_optional_features_as_map, 'provides' => \&_provides, 'recommends' => \&_version_map, 'requires' => \&_version_map, 'resources' => \&_resources_1_3, # drop these unsupported fields, but only after we convert ':drop' => [ qw( configure_requires )], # other random keys are OK if already valid ':custom' => \&_keep, }, '1.2-from-1.3' => { # MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_1_2, 'optional_features' => \&_optional_features_as_map, 'provides' => \&_provides, 'recommends' => \&_version_map, 'requires' => \&_version_map, 'resources' => \&_resources_1_3, # other random keys are OK if already valid ':custom' => \&_keep, }, '1.1-from-1.2' => { # MANDATORY 'version' => \&_keep, # IMPLIED MANDATORY 'name' => \&_keep, 'meta-spec' => \&_change_meta_spec, # OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'private' => \&_keep, 'recommends' => \&_version_map, 'requires' => \&_version_map, # drop unsupported fields ':drop' => [ qw( abstract author provides no_index keywords resources )], # other random keys are OK if already valid ':custom' => \&_keep, }, '1.0-from-1.1' => { # IMPLIED MANDATORY 'name' => \&_keep, 'meta-spec' => \&_change_meta_spec, 'version' => \&_keep, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'recommends' => \&_version_map, 'requires' => \&_version_map, # other random keys are OK if already valid ':custom' => \&_keep, }, ); my %cleanup = ( '2' => { # PRIOR MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_2, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # CHANGED TO MANDATORY 'dynamic_config' => \&_keep_or_one, # ADDED MANDATORY 'release_status' => \&_release_status, # PRIOR OPTIONAL 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_cleanup_optional_features_2, 'provides' => \&_provides, 'resources' => \&_cleanup_resources_2, # ADDED OPTIONAL 'description' => \&_keep, 'prereqs' => \&_cleanup_prereqs, # drop these deprecated fields, but only after we convert ':drop' => [ qw( build_requires configure_requires conflicts distribution_type license_url private recommends requires ) ], # other random keys need x_ prefixing ':custom' => \&_prefix_custom, }, '1.4' => { # PRIOR MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_optional_features_1_4, 'provides' => \&_provides, 'recommends' => \&_version_map, 'requires' => \&_version_map, 'resources' => \&_resources_1_4, # ADDED OPTIONAL 'configure_requires' => \&_keep, # other random keys are OK if already valid ':custom' => \&_keep }, '1.3' => { # PRIOR MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'meta-spec' => \&_change_meta_spec, 'name' => \&_keep, 'version' => \&_keep, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'keywords' => \&_keep, 'no_index' => \&_no_index_directory, 'optional_features' => \&_optional_features_as_map, 'provides' => \&_provides, 'recommends' => \&_version_map, 'requires' => \&_version_map, 'resources' => \&_resources_1_3, # other random keys are OK if already valid ':custom' => \&_keep }, '1.2' => { # PRIOR MANDATORY 'version' => \&_keep, # CHANGED TO MANDATORY 'license' => \&_license_1, 'name' => \&_keep, 'generated_by' => \&_generated_by, # ADDED MANDATORY 'abstract' => \&_keep_or_unknown, 'author' => \&_author_list, 'meta-spec' => \&_change_meta_spec, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'recommends' => \&_version_map, 'requires' => \&_version_map, # ADDED OPTIONAL 'keywords' => \&_keep, 'no_index' => \&_no_index_1_2, 'optional_features' => \&_optional_features_as_map, 'provides' => \&_provides, 'resources' => \&_resources_1_2, # other random keys are OK if already valid ':custom' => \&_keep }, '1.1' => { # CHANGED TO MANDATORY 'version' => \&_keep, # IMPLIED MANDATORY 'name' => \&_keep, 'meta-spec' => \&_change_meta_spec, # PRIOR OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'recommends' => \&_version_map, 'requires' => \&_version_map, # ADDED OPTIONAL 'license_url' => \&_url_or_drop, 'private' => \&_keep, # other random keys are OK if already valid ':custom' => \&_keep }, '1.0' => { # IMPLIED MANDATORY 'name' => \&_keep, 'meta-spec' => \&_change_meta_spec, 'version' => \&_keep, # IMPLIED OPTIONAL 'build_requires' => \&_version_map, 'conflicts' => \&_version_map, 'distribution_type' => \&_keep, 'dynamic_config' => \&_keep_or_one, 'generated_by' => \&_generated_by, 'license' => \&_license_1, 'recommends' => \&_version_map, 'requires' => \&_version_map, # other random keys are OK if already valid ':custom' => \&_keep, }, ); # for a given field in a spec version, what fields will it feed # into in the *latest* spec (i.e. v2); meta-spec omitted because # we always expect a meta-spec to be generated my %fragments_generate = ( '2' => { 'abstract' => 'abstract', 'author' => 'author', 'generated_by' => 'generated_by', 'license' => 'license', 'name' => 'name', 'version' => 'version', 'dynamic_config' => 'dynamic_config', 'release_status' => 'release_status', 'keywords' => 'keywords', 'no_index' => 'no_index', 'optional_features' => 'optional_features', 'provides' => 'provides', 'resources' => 'resources', 'description' => 'description', 'prereqs' => 'prereqs', }, '1.4' => { 'abstract' => 'abstract', 'author' => 'author', 'generated_by' => 'generated_by', 'license' => 'license', 'name' => 'name', 'version' => 'version', 'build_requires' => 'prereqs', 'conflicts' => 'prereqs', 'distribution_type' => 'distribution_type', 'dynamic_config' => 'dynamic_config', 'keywords' => 'keywords', 'no_index' => 'no_index', 'optional_features' => 'optional_features', 'provides' => 'provides', 'recommends' => 'prereqs', 'requires' => 'prereqs', 'resources' => 'resources', 'configure_requires' => 'prereqs', }, ); # this is not quite true but will work well enough # as 1.4 is a superset of earlier ones $fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/; #--------------------------------------------------------------------------# # Code #--------------------------------------------------------------------------# #pod =method new #pod #pod my $cmc = CPAN::Meta::Converter->new( $struct ); #pod #pod The constructor should be passed a valid metadata structure but invalid #pod structures are accepted. If no meta-spec version is provided, version 1.0 will #pod be assumed. #pod #pod Optionally, you can provide a C<default_version> argument after C<$struct>: #pod #pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); #pod #pod This is only needed when converting a metadata fragment that does not include a #pod C<meta-spec> field. #pod #pod =cut sub new { my ($class,$data,%args) = @_; # create an attributes hash my $self = { 'data' => $data, 'spec' => _extract_spec_version($data, $args{default_version}), }; # create the object return bless $self, $class; } sub _extract_spec_version { my ($data, $default) = @_; my $spec = $data->{'meta-spec'}; # is meta-spec there and valid? return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec? # does the version key look like a valid version? my $v = $spec->{version}; if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) { return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2 } # otherwise, use heuristics: look for 1.x vs 2.0 fields return "2" if exists $data->{prereqs}; return "1.4" if exists $data->{configure_requires}; return( $default || "1.2" ); # when meta-spec was first defined } #pod =method convert #pod #pod my $new_struct = $cmc->convert( version => "2" ); #pod #pod Returns a new hash reference with the metadata converted to a different form. #pod C<convert> will die if any conversion/standardization still results in an #pod invalid structure. #pod #pod Valid parameters include: #pod #pod =over #pod #pod =item * #pod #pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). #pod Defaults to the latest version of the CPAN Meta Spec. #pod #pod =back #pod #pod Conversion proceeds through each version in turn. For example, a version 1.2 #pod structure might be converted to 1.3 then 1.4 then finally to version 2. The #pod conversion process attempts to clean-up simple errors and standardize data. #pod For example, if C<author> is given as a scalar, it will converted to an array #pod reference containing the item. (Converting a structure to its own version will #pod also clean-up and standardize.) #pod #pod When data are cleaned and standardized, missing or invalid fields will be #pod replaced with sensible defaults when possible. This may be lossy or imprecise. #pod For example, some badly structured META.yml files on CPAN have prerequisite #pod modules listed as both keys and values: #pod #pod requires => { 'Foo::Bar' => 'Bam::Baz' } #pod #pod These would be split and each converted to a prerequisite with a minimum #pod version of zero. #pod #pod When some mandatory fields are missing or invalid, the conversion will attempt #pod to provide a sensible default or will fill them with a value of 'unknown'. For #pod example a missing or unrecognized C<license> field will result in a C<license> #pod field of 'unknown'. Fields that may get an 'unknown' include: #pod #pod =for :list #pod * abstract #pod * author #pod * license #pod #pod =cut sub convert { my ($self, %args) = @_; my $args = { %args }; my $new_version = $args->{version} || $HIGHEST; my $is_fragment = $args->{is_fragment}; my ($old_version) = $self->{spec}; my $converted = _dclone($self->{data}); if ( $old_version == $new_version ) { $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment ); unless ( $args->{is_fragment} ) { my $cmv = CPAN::Meta::Validator->new( $converted ); unless ( $cmv->is_valid ) { my $errs = join("\n", $cmv->errors); die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; } } return $converted; } elsif ( $old_version > $new_version ) { my @vers = sort { $b <=> $a } keys %known_specs; for my $i ( 0 .. $#vers-1 ) { next if $vers[$i] > $old_version; last if $vers[$i+1] < $new_version; my $spec_string = "$vers[$i+1]-from-$vers[$i]"; $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment ); unless ( $args->{is_fragment} ) { my $cmv = CPAN::Meta::Validator->new( $converted ); unless ( $cmv->is_valid ) { my $errs = join("\n", $cmv->errors); die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; } } } return $converted; } else { my @vers = sort { $a <=> $b } keys %known_specs; for my $i ( 0 .. $#vers-1 ) { next if $vers[$i] < $old_version; last if $vers[$i+1] > $new_version; my $spec_string = "$vers[$i+1]-from-$vers[$i]"; $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment ); unless ( $args->{is_fragment} ) { my $cmv = CPAN::Meta::Validator->new( $converted ); unless ( $cmv->is_valid ) { my $errs = join("\n", $cmv->errors); die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; } } } return $converted; } } #pod =method upgrade_fragment #pod #pod my $new_struct = $cmc->upgrade_fragment; #pod #pod Returns a new hash reference with the metadata converted to the latest version #pod of the CPAN Meta Spec. No validation is done on the result -- you must #pod validate after merging fragments into a complete metadata document. #pod #pod =cut sub upgrade_fragment { my ($self) = @_; my ($old_version) = $self->{spec}; my %expected = map {; $_ => 1 } grep { defined } map { $fragments_generate{$old_version}{$_} } keys %{ $self->{data} }; my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 ); for my $key ( keys %$converted ) { next if $key =~ /^x_/i || $key eq 'meta-spec'; delete $converted->{$key} unless $expected{$key}; } return $converted; } 1; # ABSTRACT: Convert CPAN distribution metadata structures =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Converter - Convert CPAN distribution metadata structures =head1 VERSION version 2.143240 =head1 SYNOPSIS my $struct = decode_json_file('META.json'); my $cmc = CPAN::Meta::Converter->new( $struct ); my $new_struct = $cmc->convert( version => "2" ); =head1 DESCRIPTION This module converts CPAN Meta structures from one form to another. The primary use is to convert older structures to the most modern version of the specification, but other transformations may be implemented in the future as needed. (E.g. stripping all custom fields or stripping all optional fields.) =head1 METHODS =head2 new my $cmc = CPAN::Meta::Converter->new( $struct ); The constructor should be passed a valid metadata structure but invalid structures are accepted. If no meta-spec version is provided, version 1.0 will be assumed. Optionally, you can provide a C<default_version> argument after C<$struct>: my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); This is only needed when converting a metadata fragment that does not include a C<meta-spec> field. =head2 convert my $new_struct = $cmc->convert( version => "2" ); Returns a new hash reference with the metadata converted to a different form. C<convert> will die if any conversion/standardization still results in an invalid structure. Valid parameters include: =over =item * C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). Defaults to the latest version of the CPAN Meta Spec. =back Conversion proceeds through each version in turn. For example, a version 1.2 structure might be converted to 1.3 then 1.4 then finally to version 2. The conversion process attempts to clean-up simple errors and standardize data. For example, if C<author> is given as a scalar, it will converted to an array reference containing the item. (Converting a structure to its own version will also clean-up and standardize.) When data are cleaned and standardized, missing or invalid fields will be replaced with sensible defaults when possible. This may be lossy or imprecise. For example, some badly structured META.yml files on CPAN have prerequisite modules listed as both keys and values: requires => { 'Foo::Bar' => 'Bam::Baz' } These would be split and each converted to a prerequisite with a minimum version of zero. When some mandatory fields are missing or invalid, the conversion will attempt to provide a sensible default or will fill them with a value of 'unknown'. For example a missing or unrecognized C<license> field will result in a C<license> field of 'unknown'. Fields that may get an 'unknown' include: =over 4 =item * abstract =item * author =item * license =back =head2 upgrade_fragment my $new_struct = $cmc->upgrade_fragment; Returns a new hash reference with the metadata converted to the latest version of the CPAN Meta Spec. No validation is done on the result -- you must validate after merging fragments into a complete metadata document. =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ # vim: ts=2 sts=2 sw=2 et: perl5/CPAN/Meta/Prereqs.pm 0000444 00000027175 14711217533 0011177 0 ustar 00 use 5.006; use strict; use warnings; package CPAN::Meta::Prereqs; # VERSION $CPAN::Meta::Prereqs::VERSION = '2.143240'; #pod =head1 DESCRIPTION #pod #pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN #pod distribution or one of its optional features. Each set of prereqs is #pod organized by phase and type, as described in L<CPAN::Meta::Prereqs>. #pod #pod =cut use Carp qw(confess); use Scalar::Util qw(blessed); use CPAN::Meta::Requirements 2.121; #pod =method new #pod #pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); #pod #pod This method returns a new set of Prereqs. The input should look like the #pod contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning #pod something more or less like this: #pod #pod my $prereq = CPAN::Meta::Prereqs->new({ #pod runtime => { #pod requires => { #pod 'Some::Module' => '1.234', #pod ..., #pod }, #pod ..., #pod }, #pod ..., #pod }); #pod #pod You can also construct an empty set of prereqs with: #pod #pod my $prereqs = CPAN::Meta::Prereqs->new; #pod #pod This empty set of prereqs is useful for accumulating new prereqs before finally #pod dumping the whole set into a structure or string. #pod #pod =cut sub __legal_phases { qw(configure build test runtime develop) } sub __legal_types { qw(requires recommends suggests conflicts) } # expect a prereq spec from META.json -- rjbs, 2010-04-11 sub new { my ($class, $prereq_spec) = @_; $prereq_spec ||= {}; my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases; my %is_legal_type = map {; $_ => 1 } $class->__legal_types; my %guts; PHASE: for my $phase (keys %$prereq_spec) { next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase}; my $phase_spec = $prereq_spec->{ $phase }; next PHASE unless keys %$phase_spec; TYPE: for my $type (keys %$phase_spec) { next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type}; my $spec = $phase_spec->{ $type }; next TYPE unless keys %$spec; $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash( $spec ); } } return bless \%guts => $class; } #pod =method requirements_for #pod #pod my $requirements = $prereqs->requirements_for( $phase, $type ); #pod #pod This method returns a L<CPAN::Meta::Requirements> object for the given #pod phase/type combination. If no prerequisites are registered for that #pod combination, a new CPAN::Meta::Requirements object will be returned, and it may #pod be added to as needed. #pod #pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will #pod be raised. #pod #pod =cut sub requirements_for { my ($self, $phase, $type) = @_; confess "requirements_for called without phase" unless defined $phase; confess "requirements_for called without type" unless defined $type; unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { confess "requested requirements for unknown phase: $phase"; } unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { confess "requested requirements for unknown type: $type"; } my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new); $req->finalize if $self->is_finalized; return $req; } #pod =method with_merged_prereqs #pod #pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); #pod #pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); #pod #pod This method returns a new CPAN::Meta::Prereqs objects in which all the #pod other prerequisites given are merged into the current set. This is primarily #pod provided for combining a distribution's core prereqs with the prereqs of one of #pod its optional features. #pod #pod The new prereqs object has no ties to the originals, and altering it further #pod will not alter them. #pod #pod =cut sub with_merged_prereqs { my ($self, $other) = @_; my @other = blessed($other) ? $other : @$other; my @prereq_objs = ($self, @other); my %new_arg; for my $phase ($self->__legal_phases) { for my $type ($self->__legal_types) { my $req = CPAN::Meta::Requirements->new; for my $prereq (@prereq_objs) { my $this_req = $prereq->requirements_for($phase, $type); next unless $this_req->required_modules; $req->add_requirements($this_req); } next unless $req->required_modules; $new_arg{ $phase }{ $type } = $req->as_string_hash; } } return (ref $self)->new(\%new_arg); } #pod =method merged_requirements #pod #pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); #pod my $new_reqs = $prereqs->merged_requirements( \@phases ); #pod my $new_reqs = $preerqs->merged_requirements(); #pod #pod This method joins together all requirements across a number of phases #pod and types into a new L<CPAN::Meta::Requirements> object. If arguments #pod are omitted, it defaults to "runtime", "build" and "test" for phases #pod and "requires" and "recommends" for types. #pod #pod =cut sub merged_requirements { my ($self, $phases, $types) = @_; $phases = [qw/runtime build test/] unless defined $phases; $types = [qw/requires recommends/] unless defined $types; confess "merged_requirements phases argument must be an arrayref" unless ref $phases eq 'ARRAY'; confess "merged_requirements types argument must be an arrayref" unless ref $types eq 'ARRAY'; my $req = CPAN::Meta::Requirements->new; for my $phase ( @$phases ) { unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { confess "requested requirements for unknown phase: $phase"; } for my $type ( @$types ) { unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { confess "requested requirements for unknown type: $type"; } $req->add_requirements( $self->requirements_for($phase, $type) ); } } $req->finalize if $self->is_finalized; return $req; } #pod =method as_string_hash #pod #pod This method returns a hashref containing structures suitable for dumping into a #pod distmeta data structure. It is made up of hashes and strings, only; there will #pod be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it. #pod #pod =cut sub as_string_hash { my ($self) = @_; my %hash; for my $phase ($self->__legal_phases) { for my $type ($self->__legal_types) { my $req = $self->requirements_for($phase, $type); next unless $req->required_modules; $hash{ $phase }{ $type } = $req->as_string_hash; } } return \%hash; } #pod =method is_finalized #pod #pod This method returns true if the set of prereqs has been marked "finalized," and #pod cannot be altered. #pod #pod =cut sub is_finalized { $_[0]{finalized} } #pod =method finalize #pod #pod Calling C<finalize> on a Prereqs object will close it for further modification. #pod Attempting to make any changes that would actually alter the prereqs will #pod result in an exception being thrown. #pod #pod =cut sub finalize { my ($self) = @_; $self->{finalized} = 1; for my $phase (keys %{ $self->{prereqs} }) { $_->finalize for values %{ $self->{prereqs}{$phase} }; } } #pod =method clone #pod #pod my $cloned_prereqs = $prereqs->clone; #pod #pod This method returns a Prereqs object that is identical to the original object, #pod but can be altered without affecting the original object. Finalization does #pod not survive cloning, meaning that you may clone a finalized set of prereqs and #pod then modify the clone. #pod #pod =cut sub clone { my ($self) = @_; my $clone = (ref $self)->new( $self->as_string_hash ); } 1; # ABSTRACT: a set of distribution prerequisites by phase and type __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type =head1 VERSION version 2.143240 =head1 DESCRIPTION A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN distribution or one of its optional features. Each set of prereqs is organized by phase and type, as described in L<CPAN::Meta::Prereqs>. =head1 METHODS =head2 new my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); This method returns a new set of Prereqs. The input should look like the contents of the C<prereqs> field described in L<CPAN::Meta::Spec>, meaning something more or less like this: my $prereq = CPAN::Meta::Prereqs->new({ runtime => { requires => { 'Some::Module' => '1.234', ..., }, ..., }, ..., }); You can also construct an empty set of prereqs with: my $prereqs = CPAN::Meta::Prereqs->new; This empty set of prereqs is useful for accumulating new prereqs before finally dumping the whole set into a structure or string. =head2 requirements_for my $requirements = $prereqs->requirements_for( $phase, $type ); This method returns a L<CPAN::Meta::Requirements> object for the given phase/type combination. If no prerequisites are registered for that combination, a new CPAN::Meta::Requirements object will be returned, and it may be added to as needed. If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will be raised. =head2 with_merged_prereqs my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); This method returns a new CPAN::Meta::Prereqs objects in which all the other prerequisites given are merged into the current set. This is primarily provided for combining a distribution's core prereqs with the prereqs of one of its optional features. The new prereqs object has no ties to the originals, and altering it further will not alter them. =head2 merged_requirements my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); my $new_reqs = $prereqs->merged_requirements( \@phases ); my $new_reqs = $preerqs->merged_requirements(); This method joins together all requirements across a number of phases and types into a new L<CPAN::Meta::Requirements> object. If arguments are omitted, it defaults to "runtime", "build" and "test" for phases and "requires" and "recommends" for types. =head2 as_string_hash This method returns a hashref containing structures suitable for dumping into a distmeta data structure. It is made up of hashes and strings, only; there will be no Prereqs, CPAN::Meta::Requirements, or C<version> objects inside it. =head2 is_finalized This method returns true if the set of prereqs has been marked "finalized," and cannot be altered. =head2 finalize Calling C<finalize> on a Prereqs object will close it for further modification. Attempting to make any changes that would actually alter the prereqs will result in an exception being thrown. =head2 clone my $cloned_prereqs = $prereqs->clone; This method returns a Prereqs object that is identical to the original object, but can be altered without affecting the original object. Finalization does not survive cloning, meaning that you may clone a finalized set of prereqs and then modify the clone. =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/Spec.pm 0000444 00000110007 14711217533 0010433 0 ustar 00 # XXX RULES FOR PATCHING THIS FILE XXX # Patches that fix typos or formatting are acceptable. Patches # that change semantics are not acceptable without prior approval # by David Golden or Ricardo Signes. use 5.006; use strict; use warnings; package CPAN::Meta::Spec; # VERSION $CPAN::Meta::Spec::VERSION = '2.143240'; 1; # ABSTRACT: specification for CPAN distribution metadata # vi:tw=72 __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Spec - specification for CPAN distribution metadata =head1 VERSION version 2.143240 =head1 SYNOPSIS my $distmeta = { name => 'Module-Build', abstract => 'Build and install Perl modules', description => "Module::Build is a system for " . "building, testing, and installing Perl modules. " . "It is meant to ... blah blah blah ...", version => '0.36', release_status => 'stable', author => [ 'Ken Williams <kwilliams@cpan.org>', 'Module-Build List <module-build@perl.org>', # additional contact ], license => [ 'perl_5' ], prereqs => { runtime => { requires => { 'perl' => '5.006', 'ExtUtils::Install' => '0', 'File::Basename' => '0', 'File::Compare' => '0', 'IO::File' => '0', }, recommends => { 'Archive::Tar' => '1.00', 'ExtUtils::Install' => '0.3', 'ExtUtils::ParseXS' => '2.02', }, }, build => { requires => { 'Test::More' => '0', }, } }, resources => { license => ['http://dev.perl.org/licenses/'], }, optional_features => { domination => { description => 'Take over the world', prereqs => { develop => { requires => { 'Genius::Evil' => '1.234' } }, runtime => { requires => { 'Machine::Weather' => '2.0' } }, }, }, }, dynamic_config => 1, keywords => [ qw/ toolchain cpan dual-life / ], 'meta-spec' => { version => '2', url => 'https://metacpan.org/pod/CPAN::Meta::Spec', }, generated_by => 'Module::Build version 0.36', }; =head1 DESCRIPTION This document describes version 2 of the CPAN distribution metadata specification, also known as the "CPAN Meta Spec". Revisions of this specification for typo corrections and prose clarifications may be issued as CPAN::Meta::Spec 2.I<x>. These revisions will never change semantics or add or remove specified behavior. Distribution metadata describe important properties of Perl distributions. Distribution building tools like Module::Build, Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a metadata file in accordance with this specification and include it with the distribution for use by automated tools that index, examine, package or install Perl distributions. =head1 TERMINOLOGY =over 4 =item distribution This is the primary object described by the metadata. In the context of this document it usually refers to a collection of modules, scripts, and/or documents that are distributed together for other developers to use. Examples of distributions are C<Class-Container>, C<libwww-perl>, or C<DBI>. =item module This refers to a reusable library of code contained in a single file. Modules usually contain one or more packages and are often referred to by the name of a primary package that can be mapped to the file name. For example, one might refer to C<File::Spec> instead of F<File/Spec.pm> =item package This refers to a namespace declared with the Perl C<package> statement. In Perl, packages often have a version number property given by the C<$VERSION> variable in the namespace. =item consumer This refers to code that reads a metadata file, deserializes it into a data structure in memory, or interprets a data structure of metadata elements. =item producer This refers to code that constructs a metadata data structure, serializes into a bytestream and/or writes it to disk. =item must, should, may, etc. These terms are interpreted as described in IETF RFC 2119. =back =head1 DATA TYPES Fields in the L</STRUCTURE> section describe data elements, each of which has an associated data type as described herein. There are four primitive types: Boolean, String, List and Map. Other types are subtypes of primitives and define compound data structures or define constraints on the values of a data element. =head2 Boolean A I<Boolean> is used to provide a true or false value. It B<must> be represented as a defined value. =head2 String A I<String> is data element containing a non-zero length sequence of Unicode characters, such as an ordinary Perl scalar that is not a reference. =head2 List A I<List> is an ordered collection of zero or more data elements. Elements of a List may be of mixed types. Producers B<must> represent List elements using a data structure which unambiguously indicates that multiple values are possible, such as a reference to a Perl array (an "arrayref"). Consumers expecting a List B<must> consider a String as equivalent to a List of length 1. =head2 Map A I<Map> is an unordered collection of zero or more data elements ("values"), indexed by associated String elements ("keys"). The Map's value elements may be of mixed types. =head2 License String A I<License String> is a subtype of String with a restricted set of values. Valid values are described in detail in the description of the L</license> field. =head2 URL I<URL> is a subtype of String containing a Uniform Resource Locator or Identifier. [ This type is called URL and not URI for historical reasons. ] =head2 Version A I<Version> is a subtype of String containing a value that describes the version number of packages or distributions. Restrictions on format are described in detail in the L</Version Formats> section. =head2 Version Range The I<Version Range> type is a subtype of String. It describes a range of Versions that may be present or installed to fulfill prerequisites. It is specified in detail in the L</Version Ranges> section. =head1 STRUCTURE The metadata structure is a data element of type Map. This section describes valid keys within the Map. Any keys not described in this specification document (whether top-level or within compound data structures described herein) are considered I<custom keys> and B<must> begin with an "x" or "X" and be followed by an underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a custom key refers to a compound data structure, subkeys within it do not need an "x_" or "X_" prefix. Consumers of metadata may ignore any or all custom keys. All other keys not described herein are invalid and should be ignored by consumers. Producers must not generate or output invalid keys. For each key, an example is provided followed by a description. The description begins with the version of spec in which the key was added or in which the definition was modified, whether the key is I<required> or I<optional> and the data type of the corresponding data element. These items are in parentheses, brackets and braces, respectively. If a data type is a Map or Map subtype, valid subkeys will be described as well. Some fields are marked I<Deprecated>. These are shown for historical context and must not be produced in or consumed from any metadata structure of version 2 or higher. =head2 REQUIRED FIELDS =head3 abstract Example: abstract => 'Build and install Perl modules' (Spec 1.2) [required] {String} This is a short description of the purpose of the distribution. =head3 author Example: author => [ 'Ken Williams <kwilliams@cpan.org>' ] (Spec 1.2) [required] {List of one or more Strings} This List indicates the person(s) to contact concerning the distribution. The preferred form of the contact string is: contact-name <email-address> This field provides a general contact list independent of other structured fields provided within the L</resources> field, such as C<bugtracker>. The addressee(s) can be contacted for any purpose including but not limited to (security) problems with the distribution, questions about the distribution or bugs in the distribution. A distribution's original author is usually the contact listed within this field. Co-maintainers, successor maintainers or mailing lists devoted to the distribution may also be listed in addition to or instead of the original author. =head3 dynamic_config Example: dynamic_config => 1 (Spec 2) [required] {Boolean} A boolean flag indicating whether a F<Build.PL> or F<Makefile.PL> (or similar) must be executed to determine prerequisites. This field should be set to a true value if the distribution performs some dynamic configuration (asking questions, sensing the environment, etc.) as part of its configuration. This field should be set to a false value to indicate that prerequisites included in metadata may be considered final and valid for static analysis. Note: when this field is true, post-configuration prerequisites are not guaranteed to bear any relation whatsoever to those stated in the metadata, and relying on them doing so is an error. See also L</Prerequisites for dynamically configured distributions> in the implementors' notes. This field explicitly B<does not> indicate whether installation may be safely performed without using a Makefile or Build file, as there may be special files to install or custom installation targets (e.g. for dual-life modules that exist on CPAN as well as in the Perl core). This field only defines whether or not prerequisites are exactly as given in the metadata. =head3 generated_by Example: generated_by => 'Module::Build version 0.36' (Spec 1.0) [required] {String} This field indicates the tool that was used to create this metadata. There are no defined semantics for this field, but it is traditional to use a string in the form "Generating::Package version 1.23" or the author's name, if the file was generated by hand. =head3 license Example: license => [ 'perl_5' ] license => [ 'apache_2_0', 'mozilla_1_0' ] (Spec 2) [required] {List of one or more License Strings} One or more licenses that apply to some or all of the files in the distribution. If multiple licenses are listed, the distribution documentation should be consulted to clarify the interpretation of multiple licenses. The following list of license strings are valid: string description ------------- ----------------------------------------------- agpl_3 GNU Affero General Public License, Version 3 apache_1_1 Apache Software License, Version 1.1 apache_2_0 Apache License, Version 2.0 artistic_1 Artistic License, (Version 1) artistic_2 Artistic License, Version 2.0 bsd BSD License (three-clause) freebsd FreeBSD License (two-clause) gfdl_1_2 GNU Free Documentation License, Version 1.2 gfdl_1_3 GNU Free Documentation License, Version 1.3 gpl_1 GNU General Public License, Version 1 gpl_2 GNU General Public License, Version 2 gpl_3 GNU General Public License, Version 3 lgpl_2_1 GNU Lesser General Public License, Version 2.1 lgpl_3_0 GNU Lesser General Public License, Version 3.0 mit MIT (aka X11) License mozilla_1_0 Mozilla Public License, Version 1.0 mozilla_1_1 Mozilla Public License, Version 1.1 openssl OpenSSL License perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later) qpl_1_0 Q Public License, Version 1.0 ssleay Original SSLeay License sun Sun Internet Standards Source License (SISSL) zlib zlib License The following license strings are also valid and indicate other licensing not described above: string description ------------- ----------------------------------------------- open_source Other Open Source Initiative (OSI) approved license restricted Requires special permission from copyright holder unrestricted Not an OSI approved license, but not restricted unknown License not provided in metadata All other strings are invalid in the license field. =head3 meta-spec Example: 'meta-spec' => { version => '2', url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', } (Spec 1.2) [required] {Map} This field indicates the version of the CPAN Meta Spec that should be used to interpret the metadata. Consumers must check this key as soon as possible and abort further metadata processing if the meta-spec version is not supported by the consumer. The following keys are valid, but only C<version> is required. =over =item version This subkey gives the integer I<Version> of the CPAN Meta Spec against which the document was generated. =item url This is a I<URL> of the metadata specification document corresponding to the given version. This is strictly for human-consumption and should not impact the interpretation of the document. For the version 2 spec, either of these are recommended: =over 4 =item * C<https://metacpan.org/pod/CPAN::Meta::Spec> =item * C<http://search.cpan.org/perldoc?CPAN::Meta::Spec> =back =back =head3 name Example: name => 'Module-Build' (Spec 1.0) [required] {String} This field is the name of the distribution. This is often created by taking the "main package" in the distribution and changing C<::> to C<->, but the name may be completely unrelated to the packages within the distribution. For example, L<LWP::UserAgent> is distributed as part of the distribution name "libwww-perl". =head3 release_status Example: release_status => 'stable' (Spec 2) [required] {String} This field provides the release status of this distribution. If the C<version> field contains an underscore character, then C<release_status> B<must not> be "stable." The C<release_status> field B<must> have one of the following values: =over =item stable This indicates an ordinary, "final" release that should be indexed by PAUSE or other indexers. =item testing This indicates a "beta" release that is substantially complete, but has an elevated risk of bugs and requires additional testing. The distribution should not be installed over a stable release without an explicit request or other confirmation from a user. This release status may also be used for "release candidate" versions of a distribution. =item unstable This indicates an "alpha" release that is under active development, but has been released for early feedback or testing and may be missing features or may have serious bugs. The distribution should not be installed over a stable release without an explicit request or other confirmation from a user. =back Consumers B<may> use this field to determine how to index the distribution for CPAN or other repositories in addition to or in replacement of heuristics based on version number or file name. =head3 version Example: version => '0.36' (Spec 1.0) [required] {Version} This field gives the version of the distribution to which the metadata structure refers. =head2 OPTIONAL FIELDS =head3 description Example: description => "Module::Build is a system for " . "building, testing, and installing Perl modules. " . "It is meant to ... blah blah blah ...", (Spec 2) [optional] {String} A longer, more complete description of the purpose or intended use of the distribution than the one provided by the C<abstract> key. =head3 keywords Example: keywords => [ qw/ toolchain cpan dual-life / ] (Spec 1.1) [optional] {List of zero or more Strings} A List of keywords that describe this distribution. Keywords B<must not> include whitespace. =head3 no_index Example: no_index => { file => [ 'My/Module.pm' ], directory => [ 'My/Private' ], package => [ 'My::Module::Secret' ], namespace => [ 'My::Module::Sample' ], } (Spec 1.2) [optional] {Map} This Map describes any files, directories, packages, and namespaces that are private to the packaging or implementation of the distribution and should be ignored by indexing or search tools. Note that this is a list of exclusions, and the spec does not define what to I<include> - see L</Indexing distributions a la PAUSE> in the implementors notes for more information. Valid subkeys are as follows: =over =item file A I<List> of relative paths to files. Paths B<must be> specified with unix conventions. =item directory A I<List> of relative paths to directories. Paths B<must be> specified with unix conventions. [ Note: previous editions of the spec had C<dir> instead of C<directory> ] =item package A I<List> of package names. =item namespace A I<List> of package namespaces, where anything below the namespace must be ignored, but I<not> the namespace itself. In the example above for C<no_index>, C<My::Module::Sample::Foo> would be ignored, but C<My::Module::Sample> would not. =back =head3 optional_features Example: optional_features => { sqlite => { description => 'Provides SQLite support', prereqs => { runtime => { requires => { 'DBD::SQLite' => '1.25' } } } } } (Spec 2) [optional] {Map} This Map describes optional features with incremental prerequisites. Each key of the C<optional_features> Map is a String used to identify the feature and each value is a Map with additional information about the feature. Valid subkeys include: =over =item description This is a String describing the feature. Every optional feature should provide a description =item prereqs This entry is required and has the same structure as that of the C<L</prereqs>> key. It provides a list of package requirements that must be satisfied for the feature to be supported or enabled. There is one crucial restriction: the prereqs of an optional feature B<must not> include C<configure> phase prereqs. =back Consumers B<must not> include optional features as prerequisites without explicit instruction from users (whether via interactive prompting, a function parameter or a configuration value, etc. ). If an optional feature is used by a consumer to add additional prerequisites, the consumer should merge the optional feature prerequisites into those given by the C<prereqs> key using the same semantics. See L</Merging and Resolving Prerequisites> for details on merging prerequisites. I<Suggestion for disuse:> Because there is currently no way for a distribution to specify a dependency on an optional feature of another dependency, the use of C<optional_feature> is discouraged. Instead, create a separate, installable distribution that ensures the desired feature is available. For example, if C<Foo::Bar> has a C<Baz> feature, release a separate C<Foo-Bar-Baz> distribution that satisfies requirements for the feature. =head3 prereqs Example: prereqs => { runtime => { requires => { 'perl' => '5.006', 'File::Spec' => '0.86', 'JSON' => '2.16', }, recommends => { 'JSON::XS' => '2.26', }, suggests => { 'Archive::Tar' => '0', }, }, build => { requires => { 'Alien::SDL' => '1.00', }, }, test => { recommends => { 'Test::Deep' => '0.10', }, } } (Spec 2) [optional] {Map} This is a Map that describes all the prerequisites of the distribution. The keys are phases of activity, such as C<configure>, C<build>, C<test> or C<runtime>. Values are Maps in which the keys name the type of prerequisite relationship such as C<requires>, C<recommends>, or C<suggests> and the value provides a set of prerequisite relations. The set of relations B<must> be specified as a Map of package names to version ranges. The full definition for this field is given in the L</Prereq Spec> section. =head3 provides Example: provides => { 'Foo::Bar' => { file => 'lib/Foo/Bar.pm', version => '0.27_02', }, 'Foo::Bar::Blah' => { file => 'lib/Foo/Bar/Blah.pm', }, 'Foo::Bar::Baz' => { file => 'lib/Foo/Bar/Baz.pm', version => '0.3', }, } (Spec 1.2) [optional] {Map} This describes all packages provided by this distribution. This information is used by distribution and automation mechanisms like PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in which distribution various packages can be found. The keys of C<provides> are package names that can be found within the distribution. If a package name key is provided, it must have a Map with the following valid subkeys: =over =item file This field is required. It must contain a Unix-style relative file path from the root of the distribution directory to a file that contains or generates the package. It may be given as C<META.yml> or C<META.json> to claim a package for indexing without needing a C<*.pm>. =item version If it exists, this field must contains a I<Version> String for the package. If the package does not have a C<$VERSION>, this field must be omitted. =back =head3 resources Example: resources => { license => [ 'http://dev.perl.org/licenses/' ], homepage => 'http://sourceforge.net/projects/module-build', bugtracker => { web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta', mailto => 'meta-bugs@example.com', }, repository => { url => 'git://github.com/dagolden/cpan-meta.git', web => 'http://github.com/dagolden/cpan-meta', type => 'git', }, x_twitter => 'http://twitter.com/cpan_linked/', } (Spec 2) [optional] {Map} This field describes resources related to this distribution. Valid subkeys include: =over =item homepage The official home of this project on the web. =item license A List of I<URL>'s that relate to this distribution's license. As with the top-level C<license> field, distribution documentation should be consulted to clarify the interpretation of multiple licenses provided here. =item bugtracker This entry describes the bug tracking system for this distribution. It is a Map with the following valid keys: web - a URL pointing to a web front-end for the bug tracker mailto - an email address to which bugs can be sent =item repository This entry describes the source control repository for this distribution. It is a Map with the following valid keys: url - a URL pointing to the repository itself web - a URL pointing to a web front-end for the repository type - a lowercase string indicating the VCS used Because a url like C<http://myrepo.example.com/> is ambiguous as to type, producers should provide a C<type> whenever a C<url> key is given. The C<type> field should be the name of the most common program used to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>, C<bzr> or C<hg>. =back =head2 DEPRECATED FIELDS =head3 build_requires I<(Deprecated in Spec 2)> [optional] {String} Replaced by C<prereqs> =head3 configure_requires I<(Deprecated in Spec 2)> [optional] {String} Replaced by C<prereqs> =head3 conflicts I<(Deprecated in Spec 2)> [optional] {String} Replaced by C<prereqs> =head3 distribution_type I<(Deprecated in Spec 2)> [optional] {String} This field indicated 'module' or 'script' but was considered meaningless, since many distributions are hybrids of several kinds of things. =head3 license_uri I<(Deprecated in Spec 1.2)> [optional] {URL} Replaced by C<license> in C<resources> =head3 private I<(Deprecated in Spec 1.2)> [optional] {Map} This field has been renamed to L</"no_index">. =head3 recommends I<(Deprecated in Spec 2)> [optional] {String} Replaced by C<prereqs> =head3 requires I<(Deprecated in Spec 2)> [optional] {String} Replaced by C<prereqs> =head1 VERSION NUMBERS =head2 Version Formats This section defines the Version type, used by several fields in the CPAN Meta Spec. Version numbers must be treated as strings, not numbers. For example, C<1.200> B<must not> be serialized as C<1.2>. Version comparison should be delegated to the Perl L<version> module, version 0.80 or newer. Unless otherwise specified, version numbers B<must> appear in one of two formats: =over =item Decimal versions Decimal versions are regular "decimal numbers", with some limitations. They B<must> be non-negative and B<must> begin and end with a digit. A single underscore B<may> be included, but B<must> be between two digits. They B<must not> use exponential notation ("1.23e-2"). version => '1.234' # OK version => '1.23_04' # OK version => '1.23_04_05' # Illegal version => '1.' # Illegal version => '.1' # Illegal =item Dotted-integer versions Dotted-integer (also known as dotted-decimal) versions consist of positive integers separated by full stop characters (i.e. "dots", "periods" or "decimal points"). This are equivalent in format to Perl "v-strings", with some additional restrictions on form. They must be given in "normal" form, which has a leading "v" character and at least three integer components. To retain a one-to-one mapping with decimal versions, all components after the first B<should> be restricted to the range 0 to 999. The final component B<may> be separated by an underscore character instead of a period. version => 'v1.2.3' # OK version => 'v1.2_3' # OK version => 'v1.2.3.4' # OK version => 'v1.2.3_4' # OK version => 'v2009.10.31' # OK version => 'v1.2' # Illegal version => '1.2.3' # Illegal version => 'v1.2_3_4' # Illegal version => 'v1.2009.10.31' # Not recommended =back =head2 Version Ranges Some fields (prereq, optional_features) indicate the particular version(s) of some other module that may be required as a prerequisite. This section details the Version Range type used to provide this information. The simplest format for a Version Range is just the version number itself, e.g. C<2.4>. This means that B<at least> version 2.4 must be present. To indicate that B<any> version of a prerequisite is okay, even if the prerequisite doesn't define a version at all, use the version C<0>. Alternatively, a version range B<may> use the operators E<lt> (less than), E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than or equal), == (equal), and != (not equal). For example, the specification C<E<lt> 2.0> means that any version of the prerequisite less than 2.0 is suitable. For more complicated situations, version specifications B<may> be AND-ed together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt> 2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0, and B<not equal to> 1.5. =head1 PREREQUISITES =head2 Prereq Spec The C<prereqs> key in the top-level metadata and within C<optional_features> define the relationship between a distribution and other packages. The prereq spec structure is a hierarchical data structure which divides prerequisites into I<Phases> of activity in the installation process and I<Relationships> that indicate how prerequisites should be resolved. For example, to specify that C<Data::Dumper> is C<required> during the C<test> phase, this entry would appear in the distribution metadata: prereqs => { test => { requires => { 'Data::Dumper' => '2.00' } } } =head3 Phases Requirements for regular use must be listed in the C<runtime> phase. Other requirements should be listed in the earliest stage in which they are required and consumers must accumulate and satisfy requirements across phases before executing the activity. For example, C<build> requirements must also be available during the C<test> phase. before action requirements that must be met ---------------- -------------------------------- perl Build.PL configure perl Makefile.PL make configure, runtime, build Build make test configure, runtime, build, test Build test Consumers that install the distribution must ensure that I<runtime> requirements are also installed and may install dependencies from other phases. after action requirements that must be met ---------------- -------------------------------- make install runtime Build install =over =item configure The configure phase occurs before any dynamic configuration has been attempted. Libraries required by the configure phase B<must> be available for use before the distribution building tool has been executed. =item build The build phase is when the distribution's source code is compiled (if necessary) and otherwise made ready for installation. =item test The test phase is when the distribution's automated test suite is run. Any library that is needed only for testing and not for subsequent use should be listed here. =item runtime The runtime phase refers not only to when the distribution's contents are installed, but also to its continued use. Any library that is a prerequisite for regular use of this distribution should be indicated here. =item develop The develop phase's prereqs are libraries needed to work on the distribution's source code as its author does. These tools might be needed to build a release tarball, to run author-only tests, or to perform other tasks related to developing new versions of the distribution. =back =head3 Relationships =over =item requires These dependencies B<must> be installed for proper completion of the phase. =item recommends Recommended dependencies are I<strongly> encouraged and should be satisfied except in resource constrained environments. =item suggests These dependencies are optional, but are suggested for enhanced operation of the described distribution. =item conflicts These libraries cannot be installed when the phase is in operation. This is a very rare situation, and the C<conflicts> relationship should be used with great caution, or not at all. =back =head2 Merging and Resolving Prerequisites Whenever metadata consumers merge prerequisites, either from different phases or from C<optional_features>, they should merged in a way which preserves the intended semantics of the prerequisite structure. Generally, this means concatenating the version specifications using commas, as described in the L<Version Ranges> section. Another subtle error that can occur in resolving prerequisites comes from the way that modules in prerequisites are indexed to distribution files on CPAN. When a module is deleted from a distribution, prerequisites calling for that module could indicate an older distribution should be installed, potentially overwriting files from a newer distribution. For example, as of Oct 31, 2009, the CPAN index file contained these module-distribution mappings: Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz Consider the case where "Class::MOP" 0.94 is installed. If a distribution specified "Class::MOP::Class::Immutable" as a prerequisite, it could result in Class-MOP-0.36.tar.gz being installed, overwriting any files from Class-MOP-0.94.tar.gz. Consumers of metadata B<should> test whether prerequisites would result in installed module files being "downgraded" to an older version and B<may> warn users or ignore the prerequisite that would cause such a result. =head1 SERIALIZATION Distribution metadata should be serialized (as a hashref) as JSON-encoded data and packaged with distributions as the file F<META.json>. In the past, the distribution metadata structure had been packed with distributions as F<META.yml>, a file in the YAML Tiny format (for which, see L<YAML::Tiny>). Tools that consume distribution metadata from disk should be capable of loading F<META.yml>, but should prefer F<META.json> if both are found. =head1 NOTES FOR IMPLEMENTORS =head2 Extracting Version Numbers from Perl Modules To get the version number from a Perl module, consumers should use the C<< MM->parse_version($file) >> method provided by L<ExtUtils::MakeMaker> or L<Module::Metadata>. For example, for the module given by C<$mod>, the version may be retrieved in one of the following ways: # via ExtUtils::MakeMaker my $file = MM->_installed_file_for_module($mod); my $version = MM->parse_version($file) The private C<_installed_file_for_module> method may be replaced with other methods for locating a module in C<@INC>. # via Module::Metadata my $info = Module::Metadata->new_from_module($mod); my $version = $info->version; If only a filename is available, the following approach may be used: # via Module::Build my $info = Module::Metadata->new_from_file($file); my $version = $info->version; =head2 Comparing Version Numbers The L<version> module provides the most reliable way to compare version numbers in all the various ways they might be provided or might exist within modules. Given two strings containing version numbers, C<$v1> and C<$v2>, they should be converted to C<version> objects before using ordinary comparison operators. For example: use version; if ( version->new($v1) <=> version->new($v2) ) { print "Versions are not equal\n"; } If the only comparison needed is whether an installed module is of a sufficiently high version, a direct test may be done using the string form of C<eval> and the C<use> function. For example, for module C<$mod> and version prerequisite C<$prereq>: if ( eval "use $mod $prereq (); 1" ) { print "Module $mod version is OK.\n"; } If the values of C<$mod> and C<$prereq> have not been scrubbed, however, this presents security implications. =head2 Prerequisites for dynamically configured distributions When C<dynamic_config> is true, it is an error to presume that the prerequisites given in distribution metadata will have any relationship whatsoever to the actual prerequisites of the distribution. In practice, however, one can generally expect such prerequisites to be one of two things: =over 4 =item * The minimum prerequisites for the distribution, to which dynamic configuration will only add items =item * Whatever the distribution configured with on the releaser's machine at release time =back The second case often turns out to have identical results to the first case, albeit only by accident. As such, consumers may use this data for informational analysis, but presenting it to the user as canonical or relying on it as such is invariably the height of folly. =head2 Indexing distributions a la PAUSE While no_index tells you what must be ignored when indexing, this spec holds no opinion on how you should get your initial candidate list of things to possibly index. For "normal" distributions you might consider simply indexing the contents of lib/, but there are many fascinating oddities on CPAN and many dists from the days when it was normal to put the main .pm file in the root of the distribution archive - so PAUSE currently indexes all .pm and .PL files that are not either (a) specifically excluded by no_index (b) in C<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as C<perl5>. Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and C<t> as well as anything marked as no_index. Also remember: If the META file contains a provides field, you shouldn't be indexing anything in the first place - just use that. =head1 SEE ALSO =over 4 =item * CPAN, L<http://www.cpan.org/> =item * JSON, L<http://json.org/> =item * YAML, L<http://www.yaml.org/> =item * L<CPAN> =item * L<CPANPLUS> =item * L<ExtUtils::MakeMaker> =item * L<Module::Build> =item * L<Module::Install> =back =head1 HISTORY Ken Williams wrote the original CPAN Meta Spec (also known as the "META.yml spec") in 2003 and maintained it through several revisions with input from various members of the community. In 2005, Randy Sims redrafted it from HTML to POD for the version 1.2 release. Ken continued to maintain the spec through version 1.4. In late 2009, David Golden organized the version 2 proposal review process. David and Ricardo Signes drafted the final version 2 spec in April 2010 based on the version 1.4 spec and patches contributed during the proposal process. =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/CPAN/Meta/Validator.pm 0000444 00000102156 14711217535 0011476 0 ustar 00 use 5.006; use strict; use warnings; package CPAN::Meta::Validator; # VERSION $CPAN::Meta::Validator::VERSION = '2.143240'; #pod =head1 SYNOPSIS #pod #pod my $struct = decode_json_file('META.json'); #pod #pod my $cmv = CPAN::Meta::Validator->new( $struct ); #pod #pod unless ( $cmv->is_valid ) { #pod my $msg = "Invalid META structure. Errors found:\n"; #pod $msg .= join( "\n", $cmv->errors ); #pod die $msg; #pod } #pod #pod =head1 DESCRIPTION #pod #pod This module validates a CPAN Meta structure against the version of the #pod the specification claimed in the C<meta-spec> field of the structure. #pod #pod =cut #--------------------------------------------------------------------------# # This code copied and adapted from Test::CPAN::Meta # by Barbie, <barbie@cpan.org> for Miss Barbell Productions, # L<http://www.missbarbell.co.uk> #--------------------------------------------------------------------------# #--------------------------------------------------------------------------# # Specification Definitions #--------------------------------------------------------------------------# my %known_specs = ( '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' ); my %known_urls = map {$known_specs{$_} => $_} keys %known_specs; my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } }; my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } }; my $no_index_2 = { 'map' => { file => { list => { value => \&string } }, directory => { list => { value => \&string } }, 'package' => { list => { value => \&string } }, namespace => { list => { value => \&string } }, ':key' => { name => \&custom_2, value => \&anything }, } }; my $no_index_1_3 = { 'map' => { file => { list => { value => \&string } }, directory => { list => { value => \&string } }, 'package' => { list => { value => \&string } }, namespace => { list => { value => \&string } }, ':key' => { name => \&string, value => \&anything }, } }; my $no_index_1_2 = { 'map' => { file => { list => { value => \&string } }, dir => { list => { value => \&string } }, 'package' => { list => { value => \&string } }, namespace => { list => { value => \&string } }, ':key' => { name => \&string, value => \&anything }, } }; my $no_index_1_1 = { 'map' => { ':key' => { name => \&string, list => { value => \&string } }, } }; my $prereq_map = { map => { ':key' => { name => \&phase, 'map' => { ':key' => { name => \&relation, %$module_map1, }, }, } }, }; my %definitions = ( '2' => { # REQUIRED 'abstract' => { mandatory => 1, value => \&string }, 'author' => { mandatory => 1, list => { value => \&string } }, 'dynamic_config' => { mandatory => 1, value => \&boolean }, 'generated_by' => { mandatory => 1, value => \&string }, 'license' => { mandatory => 1, list => { value => \&license } }, 'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version}, url => { value => \&url }, ':key' => { name => \&custom_2, value => \&anything }, } }, 'name' => { mandatory => 1, value => \&string }, 'release_status' => { mandatory => 1, value => \&release_status }, 'version' => { mandatory => 1, value => \&version }, # OPTIONAL 'description' => { value => \&string }, 'keywords' => { list => { value => \&string } }, 'no_index' => $no_index_2, 'optional_features' => { 'map' => { ':key' => { name => \&string, 'map' => { description => { value => \&string }, prereqs => $prereq_map, ':key' => { name => \&custom_2, value => \&anything }, } } } }, 'prereqs' => $prereq_map, 'provides' => { 'map' => { ':key' => { name => \&module, 'map' => { file => { mandatory => 1, value => \&file }, version => { value => \&version }, ':key' => { name => \&custom_2, value => \&anything }, } } } }, 'resources' => { 'map' => { license => { list => { value => \&url } }, homepage => { value => \&url }, bugtracker => { 'map' => { web => { value => \&url }, mailto => { value => \&string}, ':key' => { name => \&custom_2, value => \&anything }, } }, repository => { 'map' => { web => { value => \&url }, url => { value => \&url }, type => { value => \&string }, ':key' => { name => \&custom_2, value => \&anything }, } }, ':key' => { value => \&string, name => \&custom_2 }, } }, # CUSTOM -- additional user defined key/value pairs # note we can only validate the key name, as the structure is user defined ':key' => { name => \&custom_2, value => \&anything }, }, '1.4' => { 'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version}, url => { mandatory => 1, value => \&urlspec }, ':key' => { name => \&string, value => \&anything }, }, }, 'name' => { mandatory => 1, value => \&string }, 'version' => { mandatory => 1, value => \&version }, 'abstract' => { mandatory => 1, value => \&string }, 'author' => { mandatory => 1, list => { value => \&string } }, 'license' => { mandatory => 1, value => \&license }, 'generated_by' => { mandatory => 1, value => \&string }, 'distribution_type' => { value => \&string }, 'dynamic_config' => { value => \&boolean }, 'requires' => $module_map1, 'recommends' => $module_map1, 'build_requires' => $module_map1, 'configure_requires' => $module_map1, 'conflicts' => $module_map2, 'optional_features' => { 'map' => { ':key' => { name => \&string, 'map' => { description => { value => \&string }, requires => $module_map1, recommends => $module_map1, build_requires => $module_map1, conflicts => $module_map2, ':key' => { name => \&string, value => \&anything }, } } } }, 'provides' => { 'map' => { ':key' => { name => \&module, 'map' => { file => { mandatory => 1, value => \&file }, version => { value => \&version }, ':key' => { name => \&string, value => \&anything }, } } } }, 'no_index' => $no_index_1_3, 'private' => $no_index_1_3, 'keywords' => { list => { value => \&string } }, 'resources' => { 'map' => { license => { value => \&url }, homepage => { value => \&url }, bugtracker => { value => \&url }, repository => { value => \&url }, ':key' => { value => \&string, name => \&custom_1 }, } }, # additional user defined key/value pairs # note we can only validate the key name, as the structure is user defined ':key' => { name => \&string, value => \&anything }, }, '1.3' => { 'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version}, url => { mandatory => 1, value => \&urlspec }, ':key' => { name => \&string, value => \&anything }, }, }, 'name' => { mandatory => 1, value => \&string }, 'version' => { mandatory => 1, value => \&version }, 'abstract' => { mandatory => 1, value => \&string }, 'author' => { mandatory => 1, list => { value => \&string } }, 'license' => { mandatory => 1, value => \&license }, 'generated_by' => { mandatory => 1, value => \&string }, 'distribution_type' => { value => \&string }, 'dynamic_config' => { value => \&boolean }, 'requires' => $module_map1, 'recommends' => $module_map1, 'build_requires' => $module_map1, 'conflicts' => $module_map2, 'optional_features' => { 'map' => { ':key' => { name => \&string, 'map' => { description => { value => \&string }, requires => $module_map1, recommends => $module_map1, build_requires => $module_map1, conflicts => $module_map2, ':key' => { name => \&string, value => \&anything }, } } } }, 'provides' => { 'map' => { ':key' => { name => \&module, 'map' => { file => { mandatory => 1, value => \&file }, version => { value => \&version }, ':key' => { name => \&string, value => \&anything }, } } } }, 'no_index' => $no_index_1_3, 'private' => $no_index_1_3, 'keywords' => { list => { value => \&string } }, 'resources' => { 'map' => { license => { value => \&url }, homepage => { value => \&url }, bugtracker => { value => \&url }, repository => { value => \&url }, ':key' => { value => \&string, name => \&custom_1 }, } }, # additional user defined key/value pairs # note we can only validate the key name, as the structure is user defined ':key' => { name => \&string, value => \&anything }, }, # v1.2 is misleading, it seems to assume that a number of fields where created # within v1.1, when they were created within v1.2. This may have been an # original mistake, and that a v1.1 was retro fitted into the timeline, when # v1.2 was originally slated as v1.1. But I could be wrong ;) '1.2' => { 'meta-spec' => { mandatory => 1, 'map' => { version => { mandatory => 1, value => \&version}, url => { mandatory => 1, value => \&urlspec }, ':key' => { name => \&string, value => \&anything }, }, }, 'name' => { mandatory => 1, value => \&string }, 'version' => { mandatory => 1, value => \&version }, 'license' => { mandatory => 1, value => \&license }, 'generated_by' => { mandatory => 1, value => \&string }, 'author' => { mandatory => 1, list => { value => \&string } }, 'abstract' => { mandatory => 1, value => \&string }, 'distribution_type' => { value => \&string }, 'dynamic_config' => { value => \&boolean }, 'keywords' => { list => { value => \&string } }, 'private' => $no_index_1_2, '$no_index' => $no_index_1_2, 'requires' => $module_map1, 'recommends' => $module_map1, 'build_requires' => $module_map1, 'conflicts' => $module_map2, 'optional_features' => { 'map' => { ':key' => { name => \&string, 'map' => { description => { value => \&string }, requires => $module_map1, recommends => $module_map1, build_requires => $module_map1, conflicts => $module_map2, ':key' => { name => \&string, value => \&anything }, } } } }, 'provides' => { 'map' => { ':key' => { name => \&module, 'map' => { file => { mandatory => 1, value => \&file }, version => { value => \&version }, ':key' => { name => \&string, value => \&anything }, } } } }, 'resources' => { 'map' => { license => { value => \&url }, homepage => { value => \&url }, bugtracker => { value => \&url }, repository => { value => \&url }, ':key' => { value => \&string, name => \&custom_1 }, } }, # additional user defined key/value pairs # note we can only validate the key name, as the structure is user defined ':key' => { name => \&string, value => \&anything }, }, # note that the 1.1 spec only specifies 'version' as mandatory '1.1' => { 'name' => { value => \&string }, 'version' => { mandatory => 1, value => \&version }, 'license' => { value => \&license }, 'generated_by' => { value => \&string }, 'license_uri' => { value => \&url }, 'distribution_type' => { value => \&string }, 'dynamic_config' => { value => \&boolean }, 'private' => $no_index_1_1, 'requires' => $module_map1, 'recommends' => $module_map1, 'build_requires' => $module_map1, 'conflicts' => $module_map2, # additional user defined key/value pairs # note we can only validate the key name, as the structure is user defined ':key' => { name => \&string, value => \&anything }, }, # note that the 1.0 spec doesn't specify optional or mandatory fields # but we will treat version as mandatory since otherwise META 1.0 is # completely arbitrary and pointless '1.0' => { 'name' => { value => \&string }, 'version' => { mandatory => 1, value => \&version }, 'license' => { value => \&license }, 'generated_by' => { value => \&string }, 'license_uri' => { value => \&url }, 'distribution_type' => { value => \&string }, 'dynamic_config' => { value => \&boolean }, 'requires' => $module_map1, 'recommends' => $module_map1, 'build_requires' => $module_map1, 'conflicts' => $module_map2, # additional user defined key/value pairs # note we can only validate the key name, as the structure is user defined ':key' => { name => \&string, value => \&anything }, }, ); #--------------------------------------------------------------------------# # Code #--------------------------------------------------------------------------# #pod =method new #pod #pod my $cmv = CPAN::Meta::Validator->new( $struct ) #pod #pod The constructor must be passed a metadata structure. #pod #pod =cut sub new { my ($class,$data) = @_; # create an attributes hash my $self = { 'data' => $data, 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0", 'errors' => undef, }; # create the object return bless $self, $class; } #pod =method is_valid #pod #pod if ( $cmv->is_valid ) { #pod ... #pod } #pod #pod Returns a boolean value indicating whether the metadata provided #pod is valid. #pod #pod =cut sub is_valid { my $self = shift; my $data = $self->{data}; my $spec_version = $self->{spec}; $self->check_map($definitions{$spec_version},$data); return ! $self->errors; } #pod =method errors #pod #pod warn( join "\n", $cmv->errors ); #pod #pod Returns a list of errors seen during validation. #pod #pod =cut sub errors { my $self = shift; return () unless(defined $self->{errors}); return @{$self->{errors}}; } #pod =begin :internals #pod #pod =head2 Check Methods #pod #pod =over #pod #pod =item * #pod #pod check_map($spec,$data) #pod #pod Checks whether a map (or hash) part of the data structure conforms to the #pod appropriate specification definition. #pod #pod =item * #pod #pod check_list($spec,$data) #pod #pod Checks whether a list (or array) part of the data structure conforms to #pod the appropriate specification definition. #pod #pod =item * #pod #pod =back #pod #pod =cut my $spec_error = "Missing validation action in specification. " . "Must be one of 'map', 'list', or 'value'"; sub check_map { my ($self,$spec,$data) = @_; if(ref($spec) ne 'HASH') { $self->_error( "Unknown META specification, cannot validate." ); return; } if(ref($data) ne 'HASH') { $self->_error( "Expected a map structure from string or file." ); return; } for my $key (keys %$spec) { next unless($spec->{$key}->{mandatory}); next if(defined $data->{$key}); push @{$self->{stack}}, $key; $self->_error( "Missing mandatory field, '$key'" ); pop @{$self->{stack}}; } for my $key (keys %$data) { push @{$self->{stack}}, $key; if($spec->{$key}) { if($spec->{$key}{value}) { $spec->{$key}{value}->($self,$key,$data->{$key}); } elsif($spec->{$key}{'map'}) { $self->check_map($spec->{$key}{'map'},$data->{$key}); } elsif($spec->{$key}{'list'}) { $self->check_list($spec->{$key}{'list'},$data->{$key}); } else { $self->_error( "$spec_error for '$key'" ); } } elsif ($spec->{':key'}) { $spec->{':key'}{name}->($self,$key,$key); if($spec->{':key'}{value}) { $spec->{':key'}{value}->($self,$key,$data->{$key}); } elsif($spec->{':key'}{'map'}) { $self->check_map($spec->{':key'}{'map'},$data->{$key}); } elsif($spec->{':key'}{'list'}) { $self->check_list($spec->{':key'}{'list'},$data->{$key}); } else { $self->_error( "$spec_error for ':key'" ); } } else { $self->_error( "Unknown key, '$key', found in map structure" ); } pop @{$self->{stack}}; } } sub check_list { my ($self,$spec,$data) = @_; if(ref($data) ne 'ARRAY') { $self->_error( "Expected a list structure" ); return; } if(defined $spec->{mandatory}) { if(!defined $data->[0]) { $self->_error( "Missing entries from mandatory list" ); } } for my $value (@$data) { push @{$self->{stack}}, $value || "<undef>"; if(defined $spec->{value}) { $spec->{value}->($self,'list',$value); } elsif(defined $spec->{'map'}) { $self->check_map($spec->{'map'},$value); } elsif(defined $spec->{'list'}) { $self->check_list($spec->{'list'},$value); } elsif ($spec->{':key'}) { $self->check_map($spec,$value); } else { $self->_error( "$spec_error associated with '$self->{stack}[-2]'" ); } pop @{$self->{stack}}; } } #pod =head2 Validator Methods #pod #pod =over #pod #pod =item * #pod #pod header($self,$key,$value) #pod #pod Validates that the header is valid. #pod #pod Note: No longer used as we now read the data structure, not the file. #pod #pod =item * #pod #pod url($self,$key,$value) #pod #pod Validates that a given value is in an acceptable URL format #pod #pod =item * #pod #pod urlspec($self,$key,$value) #pod #pod Validates that the URL to a META specification is a known one. #pod #pod =item * #pod #pod string_or_undef($self,$key,$value) #pod #pod Validates that the value is either a string or an undef value. Bit of a #pod catchall function for parts of the data structure that are completely user #pod defined. #pod #pod =item * #pod #pod string($self,$key,$value) #pod #pod Validates that a string exists for the given key. #pod #pod =item * #pod #pod file($self,$key,$value) #pod #pod Validate that a file is passed for the given key. This may be made more #pod thorough in the future. For now it acts like \&string. #pod #pod =item * #pod #pod exversion($self,$key,$value) #pod #pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. #pod #pod =item * #pod #pod version($self,$key,$value) #pod #pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00' #pod are both valid. A leading 'v' like 'v1.2.3' is also valid. #pod #pod =item * #pod #pod boolean($self,$key,$value) #pod #pod Validates for a boolean value. Currently these values are '1', '0', 'true', #pod 'false', however the latter 2 may be removed. #pod #pod =item * #pod #pod license($self,$key,$value) #pod #pod Validates that a value is given for the license. Returns 1 if an known license #pod type, or 2 if a value is given but the license type is not a recommended one. #pod #pod =item * #pod #pod custom_1($self,$key,$value) #pod #pod Validates that the given key is in CamelCase, to indicate a user defined #pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X #pod of the spec, this was only explicitly stated for 'resources'. #pod #pod =item * #pod #pod custom_2($self,$key,$value) #pod #pod Validates that the given key begins with 'x_' or 'X_', to indicate a user #pod defined keyword and only has characters in the class [-_a-zA-Z] #pod #pod =item * #pod #pod identifier($self,$key,$value) #pod #pod Validates that key is in an acceptable format for the META specification, #pod for an identifier, i.e. any that matches the regular expression #pod qr/[a-z][a-z_]/i. #pod #pod =item * #pod #pod module($self,$key,$value) #pod #pod Validates that a given key is in an acceptable module name format, e.g. #pod 'Test::CPAN::Meta::Version'. #pod #pod =back #pod #pod =end :internals #pod #pod =cut sub header { my ($self,$key,$value) = @_; if(defined $value) { return 1 if($value && $value =~ /^--- #YAML:1.0/); } $self->_error( "file does not have a valid YAML header." ); return 0; } sub release_status { my ($self,$key,$value) = @_; if(defined $value) { my $version = $self->{data}{version} || ''; if ( $version =~ /_/ ) { return 1 if ( $value =~ /\A(?:testing|unstable)\z/ ); $self->_error( "'$value' for '$key' is invalid for version '$version'" ); } else { return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ ); $self->_error( "'$value' for '$key' is invalid" ); } } else { $self->_error( "'$key' is not defined" ); } return 0; } # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003 sub _uri_split { return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; } sub url { my ($self,$key,$value) = @_; if(defined $value) { my ($scheme, $auth, $path, $query, $frag) = _uri_split($value); unless ( defined $scheme && length $scheme ) { $self->_error( "'$value' for '$key' does not have a URL scheme" ); return 0; } unless ( defined $auth && length $auth ) { $self->_error( "'$value' for '$key' does not have a URL authority" ); return 0; } return 1; } $value ||= ''; $self->_error( "'$value' for '$key' is not a valid URL." ); return 0; } sub urlspec { my ($self,$key,$value) = @_; if(defined $value) { return 1 if($value && $known_specs{$self->{spec}} eq $value); if($value && $known_urls{$value}) { $self->_error( 'META specification URL does not match version' ); return 0; } } $self->_error( 'Unknown META specification' ); return 0; } sub anything { return 1 } sub string { my ($self,$key,$value) = @_; if(defined $value) { return 1 if($value || $value =~ /^0$/); } $self->_error( "value is an undefined string" ); return 0; } sub string_or_undef { my ($self,$key,$value) = @_; return 1 unless(defined $value); return 1 if($value || $value =~ /^0$/); $self->_error( "No string defined for '$key'" ); return 0; } sub file { my ($self,$key,$value) = @_; return 1 if(defined $value); $self->_error( "No file defined for '$key'" ); return 0; } sub exversion { my ($self,$key,$value) = @_; if(defined $value && ($value || $value =~ /0/)) { my $pass = 1; for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); } return $pass; } $value = '<undef>' unless(defined $value); $self->_error( "'$value' for '$key' is not a valid version." ); return 0; } sub version { my ($self,$key,$value) = @_; if(defined $value) { return 0 unless($value || $value =~ /0/); return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/); } else { $value = '<undef>'; } $self->_error( "'$value' for '$key' is not a valid version." ); return 0; } sub boolean { my ($self,$key,$value) = @_; if(defined $value) { return 1 if($value =~ /^(0|1|true|false)$/); } else { $value = '<undef>'; } $self->_error( "'$value' for '$key' is not a boolean value." ); return 0; } my %v1_licenses = ( 'perl' => 'http://dev.perl.org/licenses/', 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', 'apache' => 'http://apache.org/licenses/LICENSE-2.0', 'artistic' => 'http://opensource.org/licenses/artistic-license.php', 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php', 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', 'mit' => 'http://opensource.org/licenses/mit-license.php', 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php', 'open_source' => undef, 'unrestricted' => undef, 'restrictive' => undef, 'unknown' => undef, ); my %v2_licenses = map { $_ => 1 } qw( agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown ); sub license { my ($self,$key,$value) = @_; my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses; if(defined $value) { return 1 if($value && exists $licenses->{$value}); } else { $value = '<undef>'; } $self->_error( "License '$value' is invalid" ); return 0; } sub custom_1 { my ($self,$key) = @_; if(defined $key) { # a valid user defined key should be alphabetic # and contain at least one capital case letter. return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/); } else { $key = '<undef>'; } $self->_error( "Custom resource '$key' must be in CamelCase." ); return 0; } sub custom_2 { my ($self,$key) = @_; if(defined $key) { return 1 if($key && $key =~ /^x_/i); # user defined } else { $key = '<undef>'; } $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." ); return 0; } sub identifier { my ($self,$key) = @_; if(defined $key) { return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined } else { $key = '<undef>'; } $self->_error( "Key '$key' is not a legal identifier." ); return 0; } sub module { my ($self,$key) = @_; if(defined $key) { return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/); } else { $key = '<undef>'; } $self->_error( "Key '$key' is not a legal module name." ); return 0; } my @valid_phases = qw/ configure build test runtime develop /; sub phase { my ($self,$key) = @_; if(defined $key) { return 1 if( length $key && grep { $key eq $_ } @valid_phases ); return 1 if $key =~ /x_/i; } else { $key = '<undef>'; } $self->_error( "Key '$key' is not a legal phase." ); return 0; } my @valid_relations = qw/ requires recommends suggests conflicts /; sub relation { my ($self,$key) = @_; if(defined $key) { return 1 if( length $key && grep { $key eq $_ } @valid_relations ); return 1 if $key =~ /x_/i; } else { $key = '<undef>'; } $self->_error( "Key '$key' is not a legal prereq relationship." ); return 0; } sub _error { my $self = shift; my $mess = shift; $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack}); $mess .= " [Validation: $self->{spec}]"; push @{$self->{errors}}, $mess; } 1; # ABSTRACT: validate CPAN distribution metadata structures __END__ =pod =encoding UTF-8 =head1 NAME CPAN::Meta::Validator - validate CPAN distribution metadata structures =head1 VERSION version 2.143240 =head1 SYNOPSIS my $struct = decode_json_file('META.json'); my $cmv = CPAN::Meta::Validator->new( $struct ); unless ( $cmv->is_valid ) { my $msg = "Invalid META structure. Errors found:\n"; $msg .= join( "\n", $cmv->errors ); die $msg; } =head1 DESCRIPTION This module validates a CPAN Meta structure against the version of the the specification claimed in the C<meta-spec> field of the structure. =head1 METHODS =head2 new my $cmv = CPAN::Meta::Validator->new( $struct ) The constructor must be passed a metadata structure. =head2 is_valid if ( $cmv->is_valid ) { ... } Returns a boolean value indicating whether the metadata provided is valid. =head2 errors warn( join "\n", $cmv->errors ); Returns a list of errors seen during validation. =begin :internals =head2 Check Methods =over =item * check_map($spec,$data) Checks whether a map (or hash) part of the data structure conforms to the appropriate specification definition. =item * check_list($spec,$data) Checks whether a list (or array) part of the data structure conforms to the appropriate specification definition. =item * =back =head2 Validator Methods =over =item * header($self,$key,$value) Validates that the header is valid. Note: No longer used as we now read the data structure, not the file. =item * url($self,$key,$value) Validates that a given value is in an acceptable URL format =item * urlspec($self,$key,$value) Validates that the URL to a META specification is a known one. =item * string_or_undef($self,$key,$value) Validates that the value is either a string or an undef value. Bit of a catchall function for parts of the data structure that are completely user defined. =item * string($self,$key,$value) Validates that a string exists for the given key. =item * file($self,$key,$value) Validate that a file is passed for the given key. This may be made more thorough in the future. For now it acts like \&string. =item * exversion($self,$key,$value) Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. =item * version($self,$key,$value) Validates a single version string. Versions of the type '5.8.8' and '0.00_00' are both valid. A leading 'v' like 'v1.2.3' is also valid. =item * boolean($self,$key,$value) Validates for a boolean value. Currently these values are '1', '0', 'true', 'false', however the latter 2 may be removed. =item * license($self,$key,$value) Validates that a value is given for the license. Returns 1 if an known license type, or 2 if a value is given but the license type is not a recommended one. =item * custom_1($self,$key,$value) Validates that the given key is in CamelCase, to indicate a user defined keyword and only has characters in the class [-_a-zA-Z]. In version 1.X of the spec, this was only explicitly stated for 'resources'. =item * custom_2($self,$key,$value) Validates that the given key begins with 'x_' or 'X_', to indicate a user defined keyword and only has characters in the class [-_a-zA-Z] =item * identifier($self,$key,$value) Validates that key is in an acceptable format for the META specification, for an identifier, i.e. any that matches the regular expression qr/[a-z][a-z_]/i. =item * module($self,$key,$value) Validates that a given key is in an acceptable module name format, e.g. 'Test::CPAN::Meta::Version'. =back =end :internals =for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file identifier license module phase relation release_status string string_or_undef url urlspec version header check_map =head1 BUGS Please report any bugs or feature using the CPAN Request Tracker. Bugs can be submitted through the web interface at L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta> When submitting a bug or request, please include a test-file or a patch to an existing test-file that illustrates the bug or desired feature. =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2010 by David Golden and Ricardo Signes. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/HTTP/Tiny.pm 0000444 00000230656 14711217536 0007654 0 ustar 00 # vim: ts=4 sts=4 sw=4 et: package HTTP::Tiny; use strict; use warnings; # ABSTRACT: A small, simple, correct HTTP/1.1 client our $VERSION = '0.076'; sub _croak { require Carp; Carp::croak(@_) } #pod =method new #pod #pod $http = HTTP::Tiny->new( %attributes ); #pod #pod This constructor returns a new HTTP::Tiny object. Valid attributes include: #pod #pod =for :list #pod * C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If #pod C<agent> — ends in a space character, the default user-agent string is #pod appended. #pod * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class #pod that supports the C<add> and C<cookie_header> methods #pod * C<default_headers> — A hashref of default headers to apply to requests #pod * C<local_address> — The local IP address to bind to #pod * C<keep_alive> — Whether to reuse the last connection (if for the same #pod scheme, host and port) (defaults to 1) #pod * C<max_redirect> — Maximum number of redirects allowed (defaults to 5) #pod * C<max_size> — Maximum response size in bytes (only when not using a data #pod callback). If defined, responses larger than this will return an #pod exception. #pod * C<http_proxy> — URL of a proxy server to use for HTTP connections #pod (default is C<$ENV{http_proxy}> — if set) #pod * C<https_proxy> — URL of a proxy server to use for HTTPS connections #pod (default is C<$ENV{https_proxy}> — if set) #pod * C<proxy> — URL of a generic proxy server for both HTTP and HTTPS #pod connections (default is C<$ENV{all_proxy}> — if set) #pod * C<no_proxy> — List of domain suffixes that should not be proxied. Must #pod be a comma-separated string or an array reference. (default is #pod C<$ENV{no_proxy}> —) #pod * C<timeout> — Request timeout in seconds (default is 60) If a socket open, #pod read or write takes longer than the timeout, an exception is thrown. #pod * C<verify_SSL> — A boolean that indicates whether to validate the SSL #pod certificate of an C<https> — connection (default is false) #pod * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to #pod L<IO::Socket::SSL> #pod #pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will #pod prevent getting the corresponding proxies from the environment. #pod #pod Exceptions from C<max_size>, C<timeout> or other errors will result in a #pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The #pod content field in the response will contain the text of the exception. #pod #pod The C<keep_alive> parameter enables a persistent connection, but only to a #pod single destination scheme, host and port. Also, if any connection-relevant #pod attributes are modified, or if the process ID or thread ID change, the #pod persistent connection will be dropped. If you want persistent connections #pod across multiple destinations, use multiple HTTP::Tiny objects. #pod #pod See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes. #pod #pod =cut my @attributes; BEGIN { @attributes = qw( cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy SSL_options verify_SSL ); my %persist_ok = map {; $_ => 1 } qw( cookie_jar default_headers max_redirect max_size ); no strict 'refs'; no warnings 'uninitialized'; for my $accessor ( @attributes ) { *{$accessor} = sub { @_ > 1 ? do { delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor}; $_[0]->{$accessor} = $_[1] } : $_[0]->{$accessor}; }; } } sub agent { my($self, $agent) = @_; if( @_ > 1 ){ $self->{agent} = (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent; } return $self->{agent}; } sub timeout { my ($self, $timeout) = @_; if ( @_ > 1 ) { $self->{timeout} = $timeout; if ($self->{handle}) { $self->{handle}->timeout($timeout); } } return $self->{timeout}; } sub new { my($class, %args) = @_; my $self = { max_redirect => 5, timeout => defined $args{timeout} ? $args{timeout} : 60, keep_alive => 1, verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default no_proxy => $ENV{no_proxy}, }; bless $self, $class; $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar}; for my $key ( @attributes ) { $self->{$key} = $args{$key} if exists $args{$key} } $self->agent( exists $args{agent} ? $args{agent} : $class->_agent ); $self->_set_proxies; return $self; } sub _set_proxies { my ($self) = @_; # get proxies from %ENV only if not provided; explicit undef will disable # getting proxies from the environment # generic proxy if (! exists $self->{proxy} ) { $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY}; } if ( defined $self->{proxy} ) { $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate } else { delete $self->{proxy}; } # http proxy if (! exists $self->{http_proxy} ) { # under CGI, bypass HTTP_PROXY as request sets it from Proxy header local $ENV{HTTP_PROXY} if $ENV{REQUEST_METHOD}; $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy}; } if ( defined $self->{http_proxy} ) { $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate $self->{_has_proxy}{http} = 1; } else { delete $self->{http_proxy}; } # https proxy if (! exists $self->{https_proxy} ) { $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy}; } if ( $self->{https_proxy} ) { $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate $self->{_has_proxy}{https} = 1; } else { delete $self->{https_proxy}; } # Split no_proxy to array reference if not provided as such unless ( ref $self->{no_proxy} eq 'ARRAY' ) { $self->{no_proxy} = (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : []; } return; } #pod =method get|head|put|post|delete #pod #pod $response = $http->get($url); #pod $response = $http->get($url, \%options); #pod $response = $http->head($url); #pod #pod These methods are shorthand for calling C<request()> for the given method. The #pod URL must have unsafe characters escaped and international domain names encoded. #pod See C<request()> for valid options and a description of the response. #pod #pod The C<success> field of the response will be true if the status code is 2XX. #pod #pod =cut for my $sub_name ( qw/get head put post delete/ ) { my $req_method = uc $sub_name; no strict 'refs'; eval <<"HERE"; ## no critic sub $sub_name { my (\$self, \$url, \$args) = \@_; \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') or _croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); return \$self->request('$req_method', \$url, \$args || {}); } HERE } #pod =method post_form #pod #pod $response = $http->post_form($url, $form_data); #pod $response = $http->post_form($url, $form_data, \%options); #pod #pod This method executes a C<POST> request and sends the key/value pairs from a #pod form data hash or array reference to the given URL with a C<content-type> of #pod C<application/x-www-form-urlencoded>. If data is provided as an array #pod reference, the order is preserved; if provided as a hash reference, the terms #pod are sorted on key and value for consistency. See documentation for the #pod C<www_form_urlencode> method for details on the encoding. #pod #pod The URL must have unsafe characters escaped and international domain names #pod encoded. See C<request()> for valid options and a description of the response. #pod Any C<content-type> header or content in the options hashref will be ignored. #pod #pod The C<success> field of the response will be true if the status code is 2XX. #pod #pod =cut sub post_form { my ($self, $url, $data, $args) = @_; (@_ == 3 || @_ == 4 && ref $args eq 'HASH') or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n"); my $headers = {}; while ( my ($key, $value) = each %{$args->{headers} || {}} ) { $headers->{lc $key} = $value; } delete $args->{headers}; return $self->request('POST', $url, { %$args, content => $self->www_form_urlencode($data), headers => { %$headers, 'content-type' => 'application/x-www-form-urlencoded' }, } ); } #pod =method mirror #pod #pod $response = $http->mirror($url, $file, \%options) #pod if ( $response->{success} ) { #pod print "$file is up to date\n"; #pod } #pod #pod Executes a C<GET> request for the URL and saves the response body to the file #pod name provided. The URL must have unsafe characters escaped and international #pod domain names encoded. If the file already exists, the request will include an #pod C<If-Modified-Since> header with the modification timestamp of the file. You #pod may specify a different C<If-Modified-Since> header yourself in the C<< #pod $options->{headers} >> hash. #pod #pod The C<success> field of the response will be true if the status code is 2XX #pod or if the status code is 304 (unmodified). #pod #pod If the file was modified and the server response includes a properly #pod formatted C<Last-Modified> header, the file modification time will #pod be updated accordingly. #pod #pod =cut sub mirror { my ($self, $url, $file, $args) = @_; @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n"); if ( exists $args->{headers} ) { my $headers = {}; while ( my ($key, $value) = each %{$args->{headers} || {}} ) { $headers->{lc $key} = $value; } $args->{headers} = $headers; } if ( -e $file and my $mtime = (stat($file))[9] ) { $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); } my $tempfile = $file . int(rand(2**31)); require Fcntl; sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY() or _croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/); binmode $fh; $args->{data_callback} = sub { print {$fh} $_[0] }; my $response = $self->request('GET', $url, $args); close $fh or _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/); if ( $response->{success} ) { rename $tempfile, $file or _croak(qq/Error replacing $file with $tempfile: $!\n/); my $lm = $response->{headers}{'last-modified'}; if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { utime $mtime, $mtime, $file; } } $response->{success} ||= $response->{status} eq '304'; unlink $tempfile; return $response; } #pod =method request #pod #pod $response = $http->request($method, $url); #pod $response = $http->request($method, $url, \%options); #pod #pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', #pod 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and #pod international domain names encoded. #pod #pod B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification. #pod Don't use C<get> when you really want C<GET>. See L<LIMITATIONS> for #pod how this applies to redirection. #pod #pod If the URL includes a "user:password" stanza, they will be used for Basic-style #pod authorization headers. (Authorization headers will not be included in a #pod redirected request.) For example: #pod #pod $http->request('GET', 'http://Aladdin:open sesame@example.com/'); #pod #pod If the "user:password" stanza contains reserved characters, they must #pod be percent-escaped: #pod #pod $http->request('GET', 'http://john%40example.com:password@example.com/'); #pod #pod A hashref of options may be appended to modify the request. #pod #pod Valid options are: #pod #pod =for :list #pod * C<headers> — #pod A hashref containing headers to include with the request. If the value for #pod a header is an array reference, the header will be output multiple times with #pod each value in the array. These headers over-write any default headers. #pod * C<content> — #pod A scalar to include as the body of the request OR a code reference #pod that will be called iteratively to produce the body of the request #pod * C<trailer_callback> — #pod A code reference that will be called if it exists to provide a hashref #pod of trailing headers (only used with chunked transfer-encoding) #pod * C<data_callback> — #pod A code reference that will be called for each chunks of the response #pod body received. #pod * C<peer> — #pod Override host resolution and force all connections to go only to a #pod specific peer address, regardless of the URL of the request. This will #pod include any redirections! This options should be used with extreme #pod caution (e.g. debugging or very special circumstances). It can be given as #pod either a scalar or a code reference that will receive the hostname and #pod whose response will be taken as the address. #pod #pod The C<Host> header is generated from the URL in accordance with RFC 2616. It #pod is a fatal error to specify C<Host> in the C<headers> option. Other headers #pod may be ignored or overwritten if necessary for transport compliance. #pod #pod If the C<content> option is a code reference, it will be called iteratively #pod to provide the content body of the request. It should return the empty #pod string or undef when the iterator is exhausted. #pod #pod If the C<content> option is the empty string, no C<content-type> or #pod C<content-length> headers will be generated. #pod #pod If the C<data_callback> option is provided, it will be called iteratively until #pod the entire response body is received. The first argument will be a string #pod containing a chunk of the response body, the second argument will be the #pod in-progress response hash reference, as described below. (This allows #pod customizing the action of the callback based on the C<status> or C<headers> #pod received prior to the content body.) #pod #pod The C<request> method returns a hashref containing the response. The hashref #pod will have the following keys: #pod #pod =for :list #pod * C<success> — #pod Boolean indicating whether the operation returned a 2XX status code #pod * C<url> — #pod URL that provided the response. This is the URL of the request unless #pod there were redirections, in which case it is the last URL queried #pod in a redirection chain #pod * C<status> — #pod The HTTP status code of the response #pod * C<reason> — #pod The response phrase returned by the server #pod * C<content> — #pod The body of the response. If the response does not have any content #pod or if a data callback is provided to consume the response body, #pod this will be the empty string #pod * C<headers> — #pod A hashref of header fields. All header field names will be normalized #pod to be lower case. If a header is repeated, the value will be an arrayref; #pod it will otherwise be a scalar string containing the value #pod * C<protocol> - #pod If this field exists, it is the protocol of the response #pod such as HTTP/1.0 or HTTP/1.1 #pod * C<redirects> #pod If this field exists, it is an arrayref of response hash references from #pod redirects in the same order that redirections occurred. If it does #pod not exist, then no redirections occurred. #pod #pod On an exception during the execution of the request, the C<status> field will #pod contain 599, and the C<content> field will contain the text of the exception. #pod #pod =cut my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; sub request { my ($self, $method, $url, $args) = @_; @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or _croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n"); $args ||= {}; # we keep some state in this during _request # RFC 2616 Section 8.1.4 mandates a single retry on broken socket my $response; for ( 0 .. 1 ) { $response = eval { $self->_request($method, $url, $args) }; last unless $@ && $idempotent{$method} && $@ =~ m{^(?:Socket closed|Unexpected end)}; } if (my $e = $@) { # maybe we got a response hash thrown from somewhere deep if ( ref $e eq 'HASH' && exists $e->{status} ) { $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []}; return $e; } # otherwise, stringify it $e = "$e"; $response = { url => $url, success => q{}, status => 599, reason => 'Internal Exception', content => $e, headers => { 'content-type' => 'text/plain', 'content-length' => length $e, }, ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ), }; } return $response; } #pod =method www_form_urlencode #pod #pod $params = $http->www_form_urlencode( $data ); #pod $response = $http->get("http://example.com/query?$params"); #pod #pod This method converts the key/value pairs from a data hash or array reference #pod into a C<x-www-form-urlencoded> string. The keys and values from the data #pod reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an #pod array reference, the key will be repeated with each of the values of the array #pod reference. If data is provided as a hash reference, the key/value pairs in the #pod resulting string will be sorted by key and value for consistent ordering. #pod #pod =cut sub www_form_urlencode { my ($self, $data) = @_; (@_ == 2 && ref $data) or _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n"); (ref $data eq 'HASH' || ref $data eq 'ARRAY') or _croak("form data must be a hash or array reference\n"); my @params = ref $data eq 'HASH' ? %$data : @$data; @params % 2 == 0 or _croak("form data reference must have an even number of terms\n"); my @terms; while( @params ) { my ($key, $value) = splice(@params, 0, 2); if ( ref $value eq 'ARRAY' ) { unshift @params, map { $key => $_ } @$value; } else { push @terms, join("=", map { $self->_uri_escape($_) } $key, $value); } } return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) ); } #pod =method can_ssl #pod #pod $ok = HTTP::Tiny->can_ssl; #pod ($ok, $why) = HTTP::Tiny->can_ssl; #pod ($ok, $why) = $http->can_ssl; #pod #pod Indicates if SSL support is available. When called as a class object, it #pod checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>. #pod When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode> #pod is set in C<SSL_options>, it checks that a CA file is available. #pod #pod In scalar context, returns a boolean indicating if SSL is available. #pod In list context, returns the boolean and a (possibly multi-line) string of #pod errors indicating why SSL isn't available. #pod #pod =cut sub can_ssl { my ($self) = @_; my($ok, $reason) = (1, ''); # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback local @INC = @INC; pop @INC if $INC[-1] eq '.'; unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) { $ok = 0; $reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/; } # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) { $ok = 0; $reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/; } # If an object, check that SSL config lets us get a CA if necessary if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) { my $handle = HTTP::Tiny::Handle->new( SSL_options => $self->{SSL_options}, verify_SSL => $self->{verify_SSL}, ); unless ( eval { $handle->_find_CA_file; 1 } ) { $ok = 0; $reason .= "$@"; } } wantarray ? ($ok, $reason) : $ok; } #pod =method connected #pod #pod $host = $http->connected; #pod ($host, $port) = $http->connected; #pod #pod Indicates if a connection to a peer is being kept alive, per the C<keep_alive> #pod option. #pod #pod In scalar context, returns the peer host and port, joined with a colon, or #pod C<undef> (if no peer is connected). #pod In list context, returns the peer host and port or an empty list (if no peer #pod is connected). #pod #pod B<Note>: This method cannot reliably be used to discover whether the remote #pod host has closed its end of the socket. #pod #pod =cut sub connected { my ($self) = @_; # If a socket exists... if ($self->{handle} && $self->{handle}{fh}) { my $socket = $self->{handle}{fh}; # ...and is connected, return the peer host and port. if ($socket->connected) { return wantarray ? ($socket->peerhost, $socket->peerport) : join(':', $socket->peerhost, $socket->peerport); } } return; } #--------------------------------------------------------------------------# # private methods #--------------------------------------------------------------------------# my %DefaultPort = ( http => 80, https => 443, ); sub _agent { my $class = ref($_[0]) || $_[0]; (my $default_agent = $class) =~ s{::}{-}g; return $default_agent . "/" . $class->VERSION; } sub _request { my ($self, $method, $url, $args) = @_; my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url); my $request = { method => $method, scheme => $scheme, host => $host, port => $port, host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), uri => $path_query, headers => {}, }; my $peer = $args->{peer} || $host; # Allow 'peer' to be a coderef. if ('CODE' eq ref $peer) { $peer = $peer->($host); } # We remove the cached handle so it is not reused in the case of redirect. # If all is well, it will be recached at the end of _request. We only # reuse for the same scheme, host and port my $handle = delete $self->{handle}; if ( $handle ) { unless ( $handle->can_reuse( $scheme, $host, $port, $peer ) ) { $handle->close; undef $handle; } } $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer ); $self->_prepare_headers_and_cb($request, $args, $url, $auth); $handle->write_request($request); my $response; do { $response = $handle->read_response_header } until (substr($response->{status},0,1) ne '1'); $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar}; my @redir_args = $self->_maybe_redirect($request, $response, $args); my $known_message_length; if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { # response has no message body $known_message_length = 1; } else { # Ignore any data callbacks during redirection. my $cb_args = @redir_args ? +{} : $args; my $data_cb = $self->_prepare_data_cb($response, $cb_args); $known_message_length = $handle->read_body($data_cb, $response); } if ( $self->{keep_alive} && $known_message_length && $response->{protocol} eq 'HTTP/1.1' && ($response->{headers}{connection} || '') ne 'close' ) { $self->{handle} = $handle; } else { $handle->close; } $response->{success} = substr( $response->{status}, 0, 1 ) eq '2'; $response->{url} = $url; # Push the current response onto the stack of redirects if redirecting. if (@redir_args) { push @{$args->{_redirects}}, $response; return $self->_request(@redir_args, $args); } # Copy the stack of redirects into the response before returning. $response->{redirects} = delete $args->{_redirects} if @{$args->{_redirects}}; return $response; } sub _open_handle { my ($self, $request, $scheme, $host, $port, $peer) = @_; my $handle = HTTP::Tiny::Handle->new( timeout => $self->{timeout}, SSL_options => $self->{SSL_options}, verify_SSL => $self->{verify_SSL}, local_address => $self->{local_address}, keep_alive => $self->{keep_alive} ); if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) { return $self->_proxy_connect( $request, $handle ); } else { return $handle->connect($scheme, $host, $port, $peer); } } sub _proxy_connect { my ($self, $request, $handle) = @_; my @proxy_vars; if ( $request->{scheme} eq 'https' ) { _croak(qq{No https_proxy defined}) unless $self->{https_proxy}; @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} ); if ( $proxy_vars[0] eq 'https' ) { _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}}); } } else { _croak(qq{No http_proxy defined}) unless $self->{http_proxy}; @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} ); } my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars; if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) { $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth ); } $handle->connect($p_scheme, $p_host, $p_port, $p_host); if ($request->{scheme} eq 'https') { $self->_create_proxy_tunnel( $request, $handle ); } else { # non-tunneled proxy requires absolute URI $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}"; } return $handle; } sub _split_proxy { my ($self, $type, $proxy) = @_; my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) }; unless( defined($scheme) && length($scheme) && length($host) && length($port) && $path_query eq '/' ) { _croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n}); } return ($scheme, $host, $port, $auth); } sub _create_proxy_tunnel { my ($self, $request, $handle) = @_; $handle->_assert_ssl; my $agent = exists($request->{headers}{'user-agent'}) ? $request->{headers}{'user-agent'} : $self->{agent}; my $connect_request = { method => 'CONNECT', uri => "$request->{host}:$request->{port}", headers => { host => "$request->{host}:$request->{port}", 'user-agent' => $agent, } }; if ( $request->{headers}{'proxy-authorization'} ) { $connect_request->{headers}{'proxy-authorization'} = delete $request->{headers}{'proxy-authorization'}; } $handle->write_request($connect_request); my $response; do { $response = $handle->read_response_header } until (substr($response->{status},0,1) ne '1'); # if CONNECT failed, throw the response so it will be # returned from the original request() method; unless (substr($response->{status},0,1) eq '2') { die $response; } # tunnel established, so start SSL handshake $handle->start_ssl( $request->{host} ); return; } sub _prepare_headers_and_cb { my ($self, $request, $args, $url, $auth) = @_; for ($self->{default_headers}, $args->{headers}) { next unless defined; while (my ($k, $v) = each %$_) { $request->{headers}{lc $k} = $v; $request->{header_case}{lc $k} = $k; } } if (exists $request->{headers}{'host'}) { die(qq/The 'Host' header must not be provided as header option\n/); } $request->{headers}{'host'} = $request->{host_port}; $request->{headers}{'user-agent'} ||= $self->{agent}; $request->{headers}{'connection'} = "close" unless $self->{keep_alive}; if ( defined $args->{content} ) { if (ref $args->{content} eq 'CODE') { $request->{headers}{'content-type'} ||= "application/octet-stream"; $request->{headers}{'transfer-encoding'} = 'chunked' unless $request->{headers}{'content-length'} || $request->{headers}{'transfer-encoding'}; $request->{cb} = $args->{content}; } elsif ( length $args->{content} ) { my $content = $args->{content}; if ( $] ge '5.008' ) { utf8::downgrade($content, 1) or die(qq/Wide character in request message body\n/); } $request->{headers}{'content-type'} ||= "application/octet-stream"; $request->{headers}{'content-length'} = length $content unless $request->{headers}{'content-length'} || $request->{headers}{'transfer-encoding'}; $request->{cb} = sub { substr $content, 0, length $content, '' }; } $request->{trailer_cb} = $args->{trailer_callback} if ref $args->{trailer_callback} eq 'CODE'; } ### If we have a cookie jar, then maybe add relevant cookies if ( $self->{cookie_jar} ) { my $cookies = $self->cookie_jar->cookie_header( $url ); $request->{headers}{cookie} = $cookies if length $cookies; } # if we have Basic auth parameters, add them if ( length $auth && ! defined $request->{headers}{authorization} ) { $self->_add_basic_auth_header( $request, 'authorization' => $auth ); } return; } sub _add_basic_auth_header { my ($self, $request, $header, $auth) = @_; require MIME::Base64; $request->{headers}{$header} = "Basic " . MIME::Base64::encode_base64($auth, ""); return; } sub _prepare_data_cb { my ($self, $response, $args) = @_; my $data_cb = $args->{data_callback}; $response->{content} = ''; if (!$data_cb || $response->{status} !~ /^2/) { if (defined $self->{max_size}) { $data_cb = sub { $_[1]->{content} .= $_[0]; die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) if length $_[1]->{content} > $self->{max_size}; }; } else { $data_cb = sub { $_[1]->{content} .= $_[0] }; } } return $data_cb; } sub _update_cookie_jar { my ($self, $url, $response) = @_; my $cookies = $response->{headers}->{'set-cookie'}; return unless defined $cookies; my @cookies = ref $cookies ? @$cookies : $cookies; $self->cookie_jar->add( $url, $_ ) for @cookies; return; } sub _validate_cookie_jar { my ($class, $jar) = @_; # duck typing for my $method ( qw/add cookie_header/ ) { _croak(qq/Cookie jar must provide the '$method' method\n/) unless ref($jar) && ref($jar)->can($method); } return; } sub _maybe_redirect { my ($self, $request, $response, $args) = @_; my $headers = $response->{headers}; my ($status, $method) = ($response->{status}, $request->{method}); $args->{_redirects} ||= []; if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/)) and $headers->{location} and @{$args->{_redirects}} < $self->{max_redirect} ) { my $location = ($headers->{location} =~ /^\//) ? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location} ; return (($status eq '303' ? 'GET' : $method), $location); } return; } sub _split_url { my $url = pop; # URI regex adapted from the URI module my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/); $scheme = lc $scheme; $path_query = "/$path_query" unless $path_query =~ m<\A/>; my $auth = ''; if ( (my $i = index $host, '@') != -1 ) { # user:pass@host $auth = substr $host, 0, $i, ''; # take up to the @ for auth substr $host, 0, 1, ''; # knock the @ off the host # userinfo might be percent escaped, so recover real auth info $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; } my $port = $host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef; return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth); } # Date conversions adapted from HTTP::Date my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; sub _http_date { my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", substr($DoW,$wday*4,3), $mday, substr($MoY,$mon*4,3), $year+1900, $hour, $min, $sec ); } sub _parse_http_date { my ($self, $str) = @_; require Time::Local; my @tl_parts; if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); } elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); } elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); } return eval { my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; $t < 0 ? undef : $t; }; } # URI escaping adapted from URI::Escape # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 # perl 5.6 ready UTF-8 encoding adapted from JSON::PP my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; $escapes{' '}="+"; my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; sub _uri_escape { my ($self, $str) = @_; if ( $] ge '5.008' ) { utf8::encode($str); } else { $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string if ( length $str == do { use bytes; length $str } ); $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag } $str =~ s/($unsafe_char)/$escapes{$1}/g; return $str; } package HTTP::Tiny::Handle; # hide from PAUSE/indexers use strict; use warnings; use Errno qw[EINTR EPIPE]; use IO::Socket qw[SOCK_STREAM]; use Socket qw[SOL_SOCKET SO_KEEPALIVE]; # PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old # behavior if someone is unable to boostrap CPAN from a new perl install; it is # not intended for general, per-client use and may be removed in the future my $SOCKET_CLASS = $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' : eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' : 'IO::Socket::INET'; sub BUFSIZE () { 32768 } ## no critic my $Printable = sub { local $_ = shift; s/\r/\\r/g; s/\n/\\n/g; s/\t/\\t/g; s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; $_; }; my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x; sub new { my ($class, %args) = @_; return bless { rbuf => '', timeout => 60, max_line_size => 16384, max_header_lines => 64, verify_SSL => 0, SSL_options => {}, %args }, $class; } sub timeout { my ($self, $timeout) = @_; if ( @_ > 1 ) { $self->{timeout} = $timeout; if ( $self->{fh} && $self->{fh}->can('timeout') ) { $self->{fh}->timeout($timeout); } } return $self->{timeout}; } sub connect { @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n"); my ($self, $scheme, $host, $port, $peer) = @_; if ( $scheme eq 'https' ) { $self->_assert_ssl; } elsif ( $scheme ne 'http' ) { die(qq/Unsupported URL scheme '$scheme'\n/); } $self->{fh} = $SOCKET_CLASS->new( PeerHost => $peer, PeerPort => $port, $self->{local_address} ? ( LocalAddr => $self->{local_address} ) : (), Proto => 'tcp', Type => SOCK_STREAM, Timeout => $self->{timeout}, ) or die(qq/Could not connect to '$host:$port': $@\n/); binmode($self->{fh}) or die(qq/Could not binmode() socket: '$!'\n/); if ( $self->{keep_alive} ) { unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) { CORE::close($self->{fh}); die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/); } } $self->start_ssl($host) if $scheme eq 'https'; $self->{scheme} = $scheme; $self->{host} = $host; $self->{peer} = $peer; $self->{port} = $port; $self->{pid} = $$; $self->{tid} = _get_tid(); return $self; } sub start_ssl { my ($self, $host) = @_; # As this might be used via CONNECT after an SSL session # to a proxy, we shut down any existing SSL before attempting # the handshake if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { unless ( $self->{fh}->stop_SSL ) { my $ssl_err = IO::Socket::SSL->errstr; die(qq/Error halting prior SSL connection: $ssl_err/); } } my $ssl_args = $self->_ssl_args($host); IO::Socket::SSL->start_SSL( $self->{fh}, %$ssl_args, SSL_create_ctx_callback => sub { my $ctx = shift; Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY()); }, ); unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { my $ssl_err = IO::Socket::SSL->errstr; die(qq/SSL connection failed for $host: $ssl_err\n/); } } sub close { @_ == 1 || die(q/Usage: $handle->close()/ . "\n"); my ($self) = @_; CORE::close($self->{fh}) or die(qq/Could not close socket: '$!'\n/); } sub write { @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n"); my ($self, $buf) = @_; if ( $] ge '5.008' ) { utf8::downgrade($buf, 1) or die(qq/Wide character in write()\n/); } my $len = length $buf; my $off = 0; local $SIG{PIPE} = 'IGNORE'; while () { $self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/); my $r = syswrite($self->{fh}, $buf, $len, $off); if (defined $r) { $len -= $r; $off += $r; last unless $len > 0; } elsif ($! == EPIPE) { die(qq/Socket closed by remote server: $!\n/); } elsif ($! != EINTR) { if ($self->{fh}->can('errstr')){ my $err = $self->{fh}->errstr(); die (qq/Could not write to SSL socket: '$err'\n /); } else { die(qq/Could not write to socket: '$!'\n/); } } } return $off; } sub read { @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n"); my ($self, $len, $allow_partial) = @_; my $buf = ''; my $got = length $self->{rbuf}; if ($got) { my $take = ($got < $len) ? $got : $len; $buf = substr($self->{rbuf}, 0, $take, ''); $len -= $take; } while ($len > 0) { $self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ . "\n"); my $r = sysread($self->{fh}, $buf, $len, length $buf); if (defined $r) { last unless $r; $len -= $r; } elsif ($! != EINTR) { if ($self->{fh}->can('errstr')){ my $err = $self->{fh}->errstr(); die (qq/Could not read from SSL socket: '$err'\n /); } else { die(qq/Could not read from socket: '$!'\n/); } } } if ($len && !$allow_partial) { die(qq/Unexpected end of stream\n/); } return $buf; } sub readline { @_ == 1 || die(q/Usage: $handle->readline()/ . "\n"); my ($self) = @_; while () { if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { return $1; } if (length $self->{rbuf} >= $self->{max_line_size}) { die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/); } $self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/); my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); if (defined $r) { last unless $r; } elsif ($! != EINTR) { if ($self->{fh}->can('errstr')){ my $err = $self->{fh}->errstr(); die (qq/Could not read from SSL socket: '$err'\n /); } else { die(qq/Could not read from socket: '$!'\n/); } } } die(qq/Unexpected end of stream while looking for line\n/); } sub read_header_lines { @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n"); my ($self, $headers) = @_; $headers ||= {}; my $lines = 0; my $val; while () { my $line = $self->readline; if (++$lines >= $self->{max_header_lines}) { die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/); } elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { my ($field_name) = lc $1; if (exists $headers->{$field_name}) { for ($headers->{$field_name}) { $_ = [$_] unless ref $_ eq "ARRAY"; push @$_, $2; $val = \$_->[-1]; } } else { $val = \($headers->{$field_name} = $2); } } elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { $val or die(qq/Unexpected header continuation line\n/); next unless length $1; $$val .= ' ' if length $$val; $$val .= $1; } elsif ($line =~ /\A \x0D?\x0A \z/x) { last; } else { die(q/Malformed header line: / . $Printable->($line) . "\n"); } } return $headers; } sub write_request { @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n"); my($self, $request) = @_; $self->write_request_header(@{$request}{qw/method uri headers header_case/}); $self->write_body($request) if $request->{cb}; return; } # Standard request header names/case from HTTP/1.1 RFCs my @rfc_request_headers = qw( Accept Accept-Charset Accept-Encoding Accept-Language Authorization Cache-Control Connection Content-Length Expect From Host If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer Transfer-Encoding Upgrade User-Agent Via ); my @other_request_headers = qw( Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin X-XSS-Protection ); my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers; # to avoid multiple small writes and hence nagle, you can pass the method line or anything else to # combine writes. sub write_header_lines { (@_ >= 2 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n"); my($self, $headers, $header_case, $prefix_data) = @_; $header_case ||= {}; my $buf = (defined $prefix_data ? $prefix_data : ''); # Per RFC, control fields should be listed first my %seen; for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) { next unless exists $headers->{$k}; $seen{$k}++; my $field_name = $HeaderCase{$k}; my $v = $headers->{$k}; for (ref $v eq 'ARRAY' ? @$v : $v) { $_ = '' unless defined $_; $buf .= "$field_name: $_\x0D\x0A"; } } # Other headers sent in arbitrary order while (my ($k, $v) = each %$headers) { my $field_name = lc $k; next if $seen{$field_name}; if (exists $HeaderCase{$field_name}) { $field_name = $HeaderCase{$field_name}; } else { if (exists $header_case->{$field_name}) { $field_name = $header_case->{$field_name}; } else { $field_name =~ s/\b(\w)/\u$1/g; } $field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n"); $HeaderCase{lc $field_name} = $field_name; } for (ref $v eq 'ARRAY' ? @$v : $v) { # unwrap a field value if pre-wrapped by user s/\x0D?\x0A\s+/ /g; die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n") unless $_ eq '' || /\A $Field_Content \z/xo; $_ = '' unless defined $_; $buf .= "$field_name: $_\x0D\x0A"; } } $buf .= "\x0D\x0A"; return $self->write($buf); } # return value indicates whether message length was defined; this is generally # true unless there was no content-length header and we just read until EOF. # Other message length errors are thrown as exceptions sub read_body { @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n"); my ($self, $cb, $response) = @_; my $te = $response->{headers}{'transfer-encoding'} || ''; my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ; return $chunked ? $self->read_chunked_body($cb, $response) : $self->read_content_body($cb, $response); } sub write_body { @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n"); my ($self, $request) = @_; if ($request->{headers}{'content-length'}) { return $self->write_content_body($request); } else { return $self->write_chunked_body($request); } } sub read_content_body { @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n"); my ($self, $cb, $response, $content_length) = @_; $content_length ||= $response->{headers}{'content-length'}; if ( defined $content_length ) { my $len = $content_length; while ($len > 0) { my $read = ($len > BUFSIZE) ? BUFSIZE : $len; $cb->($self->read($read, 0), $response); $len -= $read; } return length($self->{rbuf}) == 0; } my $chunk; $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); return; } sub write_content_body { @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n"); my ($self, $request) = @_; my ($len, $content_length) = (0, $request->{headers}{'content-length'}); while () { my $data = $request->{cb}->(); defined $data && length $data or last; if ( $] ge '5.008' ) { utf8::downgrade($data, 1) or die(qq/Wide character in write_content()\n/); } $len += $self->write($data); } $len == $content_length or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/); return $len; } sub read_chunked_body { @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n"); my ($self, $cb, $response) = @_; while () { my $head = $self->readline; $head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / . $Printable->($head) . "\n"); my $len = hex($1) or last; $self->read_content_body($cb, $response, $len); $self->read(2) eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/); } $self->read_header_lines($response->{headers}); return 1; } sub write_chunked_body { @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n"); my ($self, $request) = @_; my $len = 0; while () { my $data = $request->{cb}->(); defined $data && length $data or last; if ( $] ge '5.008' ) { utf8::downgrade($data, 1) or die(qq/Wide character in write_chunked_body()\n/); } $len += length $data; my $chunk = sprintf '%X', length $data; $chunk .= "\x0D\x0A"; $chunk .= $data; $chunk .= "\x0D\x0A"; $self->write($chunk); } $self->write("0\x0D\x0A"); if ( ref $request->{trailer_cb} eq 'CODE' ) { $self->write_header_lines($request->{trailer_cb}->()) } else { $self->write("\x0D\x0A"); } return $len; } sub read_response_header { @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n"); my ($self) = @_; my $line = $self->readline; $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / . $Printable->($line). "\n"); my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); die (qq/Unsupported HTTP protocol: $protocol\n/) unless $version =~ /0*1\.0*[01]/; return { status => $status, reason => $reason, headers => $self->read_header_lines, protocol => $protocol, }; } sub write_request_header { @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n"); my ($self, $method, $request_uri, $headers, $header_case) = @_; return $self->write_header_lines($headers, $header_case, "$method $request_uri HTTP/1.1\x0D\x0A"); } sub _do_timeout { my ($self, $type, $timeout) = @_; $timeout = $self->{timeout} unless defined $timeout && $timeout >= 0; my $fd = fileno $self->{fh}; defined $fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/); my $initial = time; my $pending = $timeout; my $nfound; vec(my $fdset = '', $fd, 1) = 1; while () { $nfound = ($type eq 'read') ? select($fdset, undef, undef, $pending) : select(undef, $fdset, undef, $pending) ; if ($nfound == -1) { $! == EINTR or die(qq/select(2): '$!'\n/); redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; $nfound = 0; } last; } $! = 0; return $nfound; } sub can_read { @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n"); my $self = shift; if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { return 1 if $self->{fh}->pending; } return $self->_do_timeout('read', @_) } sub can_write { @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n"); my $self = shift; return $self->_do_timeout('write', @_) } sub _assert_ssl { my($ok, $reason) = HTTP::Tiny->can_ssl(); die $reason unless $ok; } sub can_reuse { my ($self,$scheme,$host,$port,$peer) = @_; return 0 if $self->{pid} != $$ || $self->{tid} != _get_tid() || length($self->{rbuf}) || $scheme ne $self->{scheme} || $host ne $self->{host} || $port ne $self->{port} || $peer ne $self->{peer} || eval { $self->can_read(0) } || $@ ; return 1; } # Try to find a CA bundle to validate the SSL cert, # prefer Mozilla::CA or fallback to a system file sub _find_CA_file { my $self = shift(); my $ca_file = defined( $self->{SSL_options}->{SSL_ca_file} ) ? $self->{SSL_options}->{SSL_ca_file} : $ENV{SSL_CERT_FILE}; if ( defined $ca_file ) { unless ( -r $ca_file ) { die qq/SSL_ca_file '$ca_file' not found or not readable\n/; } return $ca_file; } local @INC = @INC; pop @INC if $INC[-1] eq '.'; return Mozilla::CA::SSL_ca_file() if eval { require Mozilla::CA; 1 }; # cert list copied from golang src/crypto/x509/root_unix.go foreach my $ca_bundle ( "/etc/ssl/certs/ca-certificates.crt", # Debian/Ubuntu/Gentoo etc. "/etc/pki/tls/certs/ca-bundle.crt", # Fedora/RHEL "/etc/ssl/ca-bundle.pem", # OpenSUSE "/etc/openssl/certs/ca-certificates.crt", # NetBSD "/etc/ssl/cert.pem", # OpenBSD "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly "/etc/pki/tls/cacert.pem", # OpenELEC "/etc/certs/ca-certificates.crt", # Solaris 11.2+ ) { return $ca_bundle if -e $ca_bundle; } die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ . qq/Try installing Mozilla::CA from CPAN\n/; } # for thread safety, we need to know thread id if threads are loaded sub _get_tid { no warnings 'reserved'; # for 'threads' return threads->can("tid") ? threads->tid : 0; } sub _ssl_args { my ($self, $host) = @_; my %ssl_args; # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't # added until IO::Socket::SSL 1.84 if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) { $ssl_args{SSL_hostname} = $host, # Sane SNI support } if ($self->{verify_SSL}) { $ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation $ssl_args{SSL_verifycn_name} = $host; # set validation hostname $ssl_args{SSL_verify_mode} = 0x01; # enable cert validation $ssl_args{SSL_ca_file} = $self->_find_CA_file; } else { $ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation $ssl_args{SSL_verify_mode} = 0x00; # disable cert validation } # user options override settings from verify_SSL for my $k ( keys %{$self->{SSL_options}} ) { $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/; } return \%ssl_args; } 1; __END__ =pod =encoding UTF-8 =head1 NAME HTTP::Tiny - A small, simple, correct HTTP/1.1 client =head1 VERSION version 0.076 =head1 SYNOPSIS use HTTP::Tiny; my $response = HTTP::Tiny->new->get('http://example.com/'); die "Failed!\n" unless $response->{success}; print "$response->{status} $response->{reason}\n"; while (my ($k, $v) = each %{$response->{headers}}) { for (ref $v eq 'ARRAY' ? @$v : $v) { print "$k: $_\n"; } } print $response->{content} if length $response->{content}; =head1 DESCRIPTION This is a very simple HTTP/1.1 client, designed for doing simple requests without the overhead of a large framework like L<LWP::UserAgent>. It is more correct and more complete than L<HTTP::Lite>. It supports proxies and redirection. It also correctly resumes after EINTR. If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6. Cookie support requires L<HTTP::CookieJar> or an equivalent class. =head1 METHODS =head2 new $http = HTTP::Tiny->new( %attributes ); This constructor returns a new HTTP::Tiny object. Valid attributes include: =over 4 =item * C<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended. =item * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods =item * C<default_headers> — A hashref of default headers to apply to requests =item * C<local_address> — The local IP address to bind to =item * C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1) =item * C<max_redirect> — Maximum number of redirects allowed (defaults to 5) =item * C<max_size> — Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception. =item * C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set) =item * C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set) =item * C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set) =item * C<no_proxy> — List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —) =item * C<timeout> — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, an exception is thrown. =item * C<verify_SSL> — A boolean that indicates whether to validate the SSL certificate of an C<https> — connection (default is false) =item * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL> =back Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will prevent getting the corresponding proxies from the environment. Exceptions from C<max_size>, C<timeout> or other errors will result in a pseudo-HTTP status code of 599 and a reason of "Internal Exception". The content field in the response will contain the text of the exception. The C<keep_alive> parameter enables a persistent connection, but only to a single destination scheme, host and port. Also, if any connection-relevant attributes are modified, or if the process ID or thread ID change, the persistent connection will be dropped. If you want persistent connections across multiple destinations, use multiple HTTP::Tiny objects. See L</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes. =head2 get|head|put|post|delete $response = $http->get($url); $response = $http->get($url, \%options); $response = $http->head($url); These methods are shorthand for calling C<request()> for the given method. The URL must have unsafe characters escaped and international domain names encoded. See C<request()> for valid options and a description of the response. The C<success> field of the response will be true if the status code is 2XX. =head2 post_form $response = $http->post_form($url, $form_data); $response = $http->post_form($url, $form_data, \%options); This method executes a C<POST> request and sends the key/value pairs from a form data hash or array reference to the given URL with a C<content-type> of C<application/x-www-form-urlencoded>. If data is provided as an array reference, the order is preserved; if provided as a hash reference, the terms are sorted on key and value for consistency. See documentation for the C<www_form_urlencode> method for details on the encoding. The URL must have unsafe characters escaped and international domain names encoded. See C<request()> for valid options and a description of the response. Any C<content-type> header or content in the options hashref will be ignored. The C<success> field of the response will be true if the status code is 2XX. =head2 mirror $response = $http->mirror($url, $file, \%options) if ( $response->{success} ) { print "$file is up to date\n"; } Executes a C<GET> request for the URL and saves the response body to the file name provided. The URL must have unsafe characters escaped and international domain names encoded. If the file already exists, the request will include an C<If-Modified-Since> header with the modification timestamp of the file. You may specify a different C<If-Modified-Since> header yourself in the C<< $options->{headers} >> hash. The C<success> field of the response will be true if the status code is 2XX or if the status code is 304 (unmodified). If the file was modified and the server response includes a properly formatted C<Last-Modified> header, the file modification time will be updated accordingly. =head2 request $response = $http->request($method, $url); $response = $http->request($method, $url, \%options); Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and international domain names encoded. B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification. Don't use C<get> when you really want C<GET>. See L<LIMITATIONS> for how this applies to redirection. If the URL includes a "user:password" stanza, they will be used for Basic-style authorization headers. (Authorization headers will not be included in a redirected request.) For example: $http->request('GET', 'http://Aladdin:open sesame@example.com/'); If the "user:password" stanza contains reserved characters, they must be percent-escaped: $http->request('GET', 'http://john%40example.com:password@example.com/'); A hashref of options may be appended to modify the request. Valid options are: =over 4 =item * C<headers> — A hashref containing headers to include with the request. If the value for a header is an array reference, the header will be output multiple times with each value in the array. These headers over-write any default headers. =item * C<content> — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request =item * C<trailer_callback> — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding) =item * C<data_callback> — A code reference that will be called for each chunks of the response body received. =item * C<peer> — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request. This will include any redirections! This options should be used with extreme caution (e.g. debugging or very special circumstances). It can be given as either a scalar or a code reference that will receive the hostname and whose response will be taken as the address. =back The C<Host> header is generated from the URL in accordance with RFC 2616. It is a fatal error to specify C<Host> in the C<headers> option. Other headers may be ignored or overwritten if necessary for transport compliance. If the C<content> option is a code reference, it will be called iteratively to provide the content body of the request. It should return the empty string or undef when the iterator is exhausted. If the C<content> option is the empty string, no C<content-type> or C<content-length> headers will be generated. If the C<data_callback> option is provided, it will be called iteratively until the entire response body is received. The first argument will be a string containing a chunk of the response body, the second argument will be the in-progress response hash reference, as described below. (This allows customizing the action of the callback based on the C<status> or C<headers> received prior to the content body.) The C<request> method returns a hashref containing the response. The hashref will have the following keys: =over 4 =item * C<success> — Boolean indicating whether the operation returned a 2XX status code =item * C<url> — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain =item * C<status> — The HTTP status code of the response =item * C<reason> — The response phrase returned by the server =item * C<content> — The body of the response. If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string =item * C<headers> — A hashref of header fields. All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value =item * C<protocol> - If this field exists, it is the protocol of the response such as HTTP/1.0 or HTTP/1.1 =item * C<redirects> If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred. If it does not exist, then no redirections occurred. =back On an exception during the execution of the request, the C<status> field will contain 599, and the C<content> field will contain the text of the exception. =head2 www_form_urlencode $params = $http->www_form_urlencode( $data ); $response = $http->get("http://example.com/query?$params"); This method converts the key/value pairs from a data hash or array reference into a C<x-www-form-urlencoded> string. The keys and values from the data reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an array reference, the key will be repeated with each of the values of the array reference. If data is provided as a hash reference, the key/value pairs in the resulting string will be sorted by key and value for consistent ordering. =head2 can_ssl $ok = HTTP::Tiny->can_ssl; ($ok, $why) = HTTP::Tiny->can_ssl; ($ok, $why) = $http->can_ssl; Indicates if SSL support is available. When called as a class object, it checks for the correct version of L<Net::SSLeay> and L<IO::Socket::SSL>. When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode> is set in C<SSL_options>, it checks that a CA file is available. In scalar context, returns a boolean indicating if SSL is available. In list context, returns the boolean and a (possibly multi-line) string of errors indicating why SSL isn't available. =head2 connected $host = $http->connected; ($host, $port) = $http->connected; Indicates if a connection to a peer is being kept alive, per the C<keep_alive> option. In scalar context, returns the peer host and port, joined with a colon, or C<undef> (if no peer is connected). In list context, returns the peer host and port or an empty list (if no peer is connected). B<Note>: This method cannot reliably be used to discover whether the remote host has closed its end of the socket. =for Pod::Coverage SSL_options agent cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size no_proxy proxy timeout verify_SSL =head1 SSL SUPPORT Direct C<https> connections are supported only if L<IO::Socket::SSL> 1.56 or greater and L<Net::SSLeay> 1.49 or greater are installed. An exception will be thrown if new enough versions of these modules are not installed or if the SSL encryption fails. You can also use C<HTTP::Tiny::can_ssl()> utility function that returns boolean to see if the required modules are installed. An C<https> connection may be made via an C<http> proxy that supports the CONNECT command (i.e. RFC 2817). You may not proxy C<https> via a proxy that itself requires C<https> to communicate. SSL provides two distinct capabilities: =over 4 =item * Encrypted communication channel =item * Verification of server identity =back B<By default, HTTP::Tiny does not verify server identity>. Server identity verification is controversial and potentially tricky because it depends on a (usually paid) third-party Certificate Authority (CA) trust model to validate a certificate as legitimate. This discriminates against servers with self-signed certificates or certificates signed by free, community-driven CA's such as L<CAcert.org|http://cacert.org>. By default, HTTP::Tiny does not make any assumptions about your trust model, threat level or risk tolerance. It just aims to give you an encrypted channel when you need one. Setting the C<verify_SSL> attribute to a true value will make HTTP::Tiny verify that an SSL connection has a valid SSL certificate corresponding to the host name of the connection and that the SSL certificate has been verified by a CA. Assuming you trust the CA, this will protect against a L<man-in-the-middle attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>. If you are concerned about security, you should enable this option. Certificate verification requires a file containing trusted CA certificates. If the environment variable C<SSL_CERT_FILE> is present, HTTP::Tiny will try to find a CA certificate file in that location. If the L<Mozilla::CA> module is installed, HTTP::Tiny will use the CA file included with it as a source of trusted CA's. (This means you trust Mozilla, the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the toolchain used to install it, and your operating system security, right?) If that module is not available, then HTTP::Tiny will search several system-specific default locations for a CA certificate file: =over 4 =item * /etc/ssl/certs/ca-certificates.crt =item * /etc/pki/tls/certs/ca-bundle.crt =item * /etc/ssl/ca-bundle.pem =back An exception will be raised if C<verify_SSL> is true and no CA certificate file is available. If you desire complete control over SSL connections, the C<SSL_options> attribute lets you provide a hash reference that will be passed through to C<IO::Socket::SSL::start_SSL()>, overriding any options set by HTTP::Tiny. For example, to provide your own trusted CA file: SSL_options => { SSL_ca_file => $file_path, } The C<SSL_options> attribute could also be used for such things as providing a client certificate for authentication to a server or controlling the choice of cipher used for the SSL connection. See L<IO::Socket::SSL> documentation for details. =head1 PROXY SUPPORT HTTP::Tiny can proxy both C<http> and C<https> requests. Only Basic proxy authorization is supported and it must be provided as part of the proxy URL: C<http://user:pass@proxy.example.com/>. HTTP::Tiny supports the following proxy environment variables: =over 4 =item * http_proxy or HTTP_PROXY =item * https_proxy or HTTPS_PROXY =item * all_proxy or ALL_PROXY =back If the C<REQUEST_METHOD> environment variable is set, then this might be a CGI process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a security risk. If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case variant only) is ignored. Tunnelling C<https> over an C<http> proxy using the CONNECT method is supported. If your proxy uses C<https> itself, you can not tunnel C<https> over it. Be warned that proxying an C<https> connection opens you to the risk of a man-in-the-middle attack by the proxy server. The C<no_proxy> environment variable is supported in the format of a comma-separated list of domain extensions proxy should not be used for. Proxy arguments passed to C<new> will override their corresponding environment variables. =head1 LIMITATIONS HTTP::Tiny is I<conditionally compliant> with the L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>: =over 4 =item * "Message Syntax and Routing" [RFC7230] =item * "Semantics and Content" [RFC7231] =item * "Conditional Requests" [RFC7232] =item * "Range Requests" [RFC7233] =item * "Caching" [RFC7234] =item * "Authentication" [RFC7235] =back It attempts to meet all "MUST" requirements of the specification, but does not implement all "SHOULD" requirements. (Note: it was developed against the earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235 spec.) Some particular limitations of note include: =over =item * HTTP::Tiny focuses on correct transport. Users are responsible for ensuring that user-defined headers and content are compliant with the HTTP/1.1 specification. =item * Users must ensure that URLs are properly escaped for unsafe characters and that international domain names are properly encoded to ASCII. See L<URI::Escape>, L<URI::_punycode> and L<Net::IDN::Encode>. =item * Redirection is very strict against the specification. Redirection is only automatic for response codes 301, 302, 307 and 308 if the request method is 'GET' or 'HEAD'. Response code 303 is always converted into a 'GET' redirection, as mandated by the specification. There is no automatic support for status 305 ("Use proxy") redirections. =item * There is no provision for delaying a request body using an C<Expect> header. Unexpected C<1XX> responses are silently ignored as per the specification. =item * Only 'chunked' C<Transfer-Encoding> is supported. =item * There is no support for a Request-URI of '*' for the 'OPTIONS' request. =item * Headers mentioned in the RFCs and some other, well-known headers are generated with their canonical case. Other headers are sent in the case provided by the user. Except for control headers (which are sent first), headers are sent in arbitrary order. =back Despite the limitations listed above, HTTP::Tiny is considered feature-complete. New feature requests should be directed to L<HTTP::Tiny::UA>. =head1 SEE ALSO =over 4 =item * L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny =item * L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility =item * L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface =item * L<IO::Socket::IP> - Required for IPv6 support =item * L<IO::Socket::SSL> - Required for SSL support =item * L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things =item * L<Mozilla::CA> - Required if you want to validate SSL certificates =item * L<Net::SSLeay> - Required for SSL support =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/chansen/p5-http-tiny/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/chansen/p5-http-tiny> git clone https://github.com/chansen/p5-http-tiny.git =head1 AUTHORS =over 4 =item * Christian Hansen <chansen@cpan.org> =item * David Golden <dagolden@cpan.org> =back =head1 CONTRIBUTORS =for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Golden Mitchell Dean Pearce Edward Zborowski Felipe Gasper James Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Nicolas Rochelemagne Olaf Alders Olivier Mengué Petr Písař Serguei Trouchelle Shoichi Kaji SkyMarshal Sören Kornetzki Steve Grazzini Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook =over 4 =item * Alan Gardner <gardner@pythian.com> =item * Alessandro Ghedini <al3xbio@gmail.com> =item * A. Sinan Unur <nanis@cpan.org> =item * Brad Gilbert <bgills@cpan.org> =item * brian m. carlson <sandals@crustytoothpaste.net> =item * Chris Nehren <apeiron@cpan.org> =item * Chris Weyl <cweyl@alumni.drew.edu> =item * Claes Jakobsson <claes@surfar.nu> =item * Clinton Gormley <clint@traveljury.com> =item * Craig A. Berry <craigberry@mac.com> =item * Craig Berry <cberry@cpan.org> =item * David Golden <xdg@xdg.me> =item * David Mitchell <davem@iabyn.com> =item * Dean Pearce <pearce@pythian.com> =item * Edward Zborowski <ed@rubensteintech.com> =item * Felipe Gasper <felipe@felipegasper.com> =item * James Raspass <jraspass@gmail.com> =item * Jeremy Mates <jmates@cpan.org> =item * Jess Robinson <castaway@desert-island.me.uk> =item * Karen Etheridge <ether@cpan.org> =item * Lukas Eklund <leklund@gmail.com> =item * Martin J. Evans <mjegh@ntlworld.com> =item * Martin-Louis Bright <mlbright@gmail.com> =item * Mike Doherty <doherty@cpan.org> =item * Nicolas Rochelemagne <rochelemagne@cpanel.net> =item * Olaf Alders <olaf@wundersolutions.com> =item * Olivier Mengué <dolmen@cpan.org> =item * Petr Písař <ppisar@redhat.com> =item * Serguei Trouchelle <stro@cpan.org> =item * Shoichi Kaji <skaji@cpan.org> =item * SkyMarshal <skymarshal1729@gmail.com> =item * Sören Kornetzki <soeren.kornetzki@delti.com> =item * Steve Grazzini <steve.grazzini@grantstreet.com> =item * Syohei YOSHIDA <syohex@gmail.com> =item * Tatsuhiko Miyagawa <miyagawa@bulknews.net> =item * Tom Hukins <tom@eborcom.com> =item * Tony Cook <tony@develop-help.com> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2018 by Christian Hansen. 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 perl5/Parse/CPAN/Meta.pm 0000444 00000021040 14711217541 0010610 0 ustar 00 use 5.008001; use strict; package Parse::CPAN::Meta; # ABSTRACT: Parse META.yml and META.json CPAN metadata files our $VERSION = '1.4414'; # VERSION use Exporter; use Carp 'croak'; our @ISA = qw/Exporter/; our @EXPORT_OK = qw/Load LoadFile/; sub load_file { my ($class, $filename) = @_; my $meta = _slurp($filename); if ($filename =~ /\.ya?ml$/) { return $class->load_yaml_string($meta); } elsif ($filename =~ /\.json$/) { return $class->load_json_string($meta); } else { $class->load_string($meta); # try to detect yaml/json } } sub load_string { my ($class, $string) = @_; if ( $string =~ /^---/ ) { # looks like YAML return $class->load_yaml_string($string); } elsif ( $string =~ /^\s*\{/ ) { # looks like JSON return $class->load_json_string($string); } else { # maybe doc-marker-free YAML return $class->load_yaml_string($string); } } sub load_yaml_string { my ($class, $string) = @_; my $backend = $class->yaml_backend(); my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) }; croak $@ if $@; return $data || {}; # in case document was valid but empty } sub load_json_string { my ($class, $string) = @_; my $data = eval { $class->json_backend()->new->decode($string) }; croak $@ if $@; return $data || {}; } sub yaml_backend { if (! defined $ENV{PERL_YAML_BACKEND} ) { _can_load( 'CPAN::Meta::YAML', 0.011 ) or croak "CPAN::Meta::YAML 0.011 is not available\n"; return "CPAN::Meta::YAML"; } else { my $backend = $ENV{PERL_YAML_BACKEND}; _can_load( $backend ) or croak "Could not load PERL_YAML_BACKEND '$backend'\n"; $backend->can("Load") or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n"; return $backend; } } sub json_backend { if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') { _can_load( 'JSON::PP' => 2.27103 ) or croak "JSON::PP 2.27103 is not available\n"; return 'JSON::PP'; } else { _can_load( 'JSON' => 2.5 ) or croak "JSON 2.5 is required for " . "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n"; return "JSON"; } } sub _slurp { require Encode; open my $fh, "<:raw", "$_[0]" ## no critic or die "can't open $_[0] for reading: $!"; my $content = do { local $/; <$fh> }; $content = Encode::decode('UTF-8', $content, Encode::PERLQQ()); return $content; } sub _can_load { my ($module, $version) = @_; (my $file = $module) =~ s{::}{/}g; $file .= ".pm"; return 1 if $INC{$file}; return 0 if exists $INC{$file}; # prior load failed eval { require $file; 1 } or return 0; if ( defined $version ) { eval { $module->VERSION($version); 1 } or return 0; } return 1; } # Kept for backwards compatibility only # Create an object from a file sub LoadFile ($) { return Load(_slurp(shift)); } # Parse a document from a string. sub Load ($) { require CPAN::Meta::YAML; my $object = eval { CPAN::Meta::YAML::Load(shift) }; croak $@ if $@; return $object; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files =head1 VERSION version 1.4414 =head1 SYNOPSIS ############################################# # In your file --- name: My-Distribution version: 1.23 resources: homepage: "http://example.com/dist/My-Distribution" ############################################# # In your program use Parse::CPAN::Meta; my $distmeta = Parse::CPAN::Meta->load_file('META.yml'); # Reading properties my $name = $distmeta->{name}; my $version = $distmeta->{version}; my $homepage = $distmeta->{resources}{homepage}; =head1 DESCRIPTION B<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using L<JSON::PP> and/or L<CPAN::Meta::YAML>. B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>, and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and are described below in detail. B<Parse::CPAN::Meta> provides a legacy API of only two functions, based on the YAML functions of the same name. Wherever possible, identical calling semantics are used. These may only be used with YAML sources. All error reporting is done with exceptions (die'ing). Note that META files are expected to be in UTF-8 encoding, only. When converted string data, it must first be decoded from UTF-8. =begin Pod::Coverage =end Pod::Coverage =head1 METHODS =head2 load_file my $metadata_structure = Parse::CPAN::Meta->load_file('META.json'); my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml'); This method will read the named file and deserialize it to a data structure, determining whether it should be JSON or YAML based on the filename. The file will be read using the ":utf8" IO layer. =head2 load_yaml_string my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string); This method deserializes the given string of YAML and returns the first document in it. (CPAN metadata files should always have only one document.) If the source was UTF-8 encoded, the string must be decoded before calling C<load_yaml_string>. =head2 load_json_string my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string); This method deserializes the given string of JSON and the result. If the source was UTF-8 encoded, the string must be decoded before calling C<load_json_string>. =head2 load_string my $metadata_structure = Parse::CPAN::Meta->load_string($some_string); If you don't know whether a string contains YAML or JSON data, this method will use some heuristics and guess. If it can't tell, it assumes YAML. =head2 yaml_backend my $backend = Parse::CPAN::Meta->yaml_backend; Returns the module name of the YAML serializer. See L</ENVIRONMENT> for details. =head2 json_backend my $backend = Parse::CPAN::Meta->json_backend; Returns the module name of the JSON serializer. This will either be L<JSON::PP> or L<JSON>. Even if C<PERL_JSON_BACKEND> is set, this will return L<JSON> as further delegation is handled by the L<JSON> module. See L</ENVIRONMENT> for details. =head1 FUNCTIONS For maintenance clarity, no functions are exported by default. These functions are available for backwards compatibility only and are best avoided in favor of C<load_file>. =head2 Load my @yaml = Parse::CPAN::Meta::Load( $string ); Parses a string containing a valid YAML stream into a list of Perl data structures. =head2 LoadFile my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' ); Reads the YAML stream from a file instead of a string. =head1 ENVIRONMENT =head2 PERL_JSON_BACKEND By default, L<JSON::PP> will be used for deserializing JSON data. If the C<PERL_JSON_BACKEND> environment variable exists, is true and is not "JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too old, an exception will be thrown. =head2 PERL_YAML_BACKEND By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If the C<PERL_YAML_BACKEND> environment variable is defined, then it is interpreted as a module to use for deserialization. The given module must be installed, must load correctly and must implement the C<Load()> function or an exception will be thrown. =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta> git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git =head1 AUTHORS =over 4 =item * Adam Kennedy <adamk@cpan.org> =item * David Golden <dagolden@cpan.org> =back =head1 CONTRIBUTORS =over 4 =item * Graham Knop <haarg@haarg.org> =item * Joshua ben Jore <jjore@cpan.org> =item * Neil Bowers <neil@bowers.com> =item * Ricardo Signes <rjbs@cpan.org> =item * Steffen Mueller <smueller@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Adam Kennedy and Contributors. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut perl5/Devel/CheckLib.pm 0000444 00000046277 14711217542 0010656 0 ustar 00 # $Id: CheckLib.pm,v 1.25 2008/10/27 12:16:23 drhyde Exp $ package Devel::CheckLib; use 5.00405; #postfix foreach use strict; use vars qw($VERSION @ISA @EXPORT); $VERSION = '1.14'; use Config qw(%Config); use Text::ParseWords 'quotewords'; use File::Spec; use File::Temp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(assert_lib check_lib_or_exit check_lib); # localising prevents the warningness leaking out of this module local $^W = 1; # use warnings is a 5.6-ism _findcc(); # bomb out early if there's no compiler =head1 NAME Devel::CheckLib - check that a library is available =head1 DESCRIPTION Devel::CheckLib is a perl module that checks whether a particular C library and its headers are available. =head1 SYNOPSIS use Devel::CheckLib; check_lib_or_exit( lib => 'jpeg', header => 'jpeglib.h' ); check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] ); # or prompt for path to library and then do this: check_lib_or_exit( lib => 'jpeg', libpath => $additional_path ); =head1 USING IT IN Makefile.PL or Build.PL If you want to use this from Makefile.PL or Build.PL, do not simply copy the module into your distribution as this may cause problems when PAUSE and search.cpan.org index the distro. Instead, use the use-devel-checklib script. =head1 HOW IT WORKS You pass named parameters to a function, describing to it how to build and link to the libraries. It works by trying to compile some code - which defaults to this: int main(int argc, char *argv[]) { return 0; } and linking it to the specified libraries. If something pops out the end which looks executable, it gets executed, and if main() returns 0 we know that it worked. That tiny program is built once for each library that you specify, and (without linking) once for each header file. If you want to check for the presence of particular functions in a library, or even that those functions return particular results, then you can pass your own function body for main() thus: check_lib_or_exit( function => 'foo();if(libversion() > 5) return 0; else return 1;' incpath => ... libpath => ... lib => ... header => ... ); In that case, it will fail to build if either foo() or libversion() don't exist, and main() will return the wrong value if libversion()'s return value isn't what you want. =head1 FUNCTIONS All of these take the same named parameters and are exported by default. To avoid exporting them, C<use Devel::CheckLib ()>. =head2 assert_lib This takes several named parameters, all of which are optional, and dies with an error message if any of the libraries listed can not be found. B<Note>: dying in a Makefile.PL or Build.PL may provoke a 'FAIL' report from CPAN Testers' automated smoke testers. Use C<check_lib_or_exit> instead. The named parameters are: =over =item lib Must be either a string with the name of a single library or a reference to an array of strings of library names. Depending on the compiler found, library names will be fed to the compiler either as C<-l> arguments or as C<.lib> file names. (E.g. C<-ljpeg> or C<jpeg.lib>) =item libpath a string or an array of strings representing additional paths to search for libraries. =item LIBS a C<ExtUtils::MakeMaker>-style space-separated list of libraries (each preceded by '-l') and directories (preceded by '-L'). This can also be supplied on the command-line. =item debug If true - emit information during processing that can be used for debugging. =back And libraries are no use without header files, so ... =over =item header Must be either a string with the name of a single header file or a reference to an array of strings of header file names. =item incpath a string or an array of strings representing additional paths to search for headers. =item INC a C<ExtUtils::MakeMaker>-style space-separated list of incpaths, each preceded by '-I'. This can also be supplied on the command-line. =item ccflags Extra flags to pass to the compiler. =item ldflags Extra flags to pass to the linker. =item analyze_binary a callback function that will be invoked in order to perform custom analysis of the generated binary. The callback arguments are the library name and the path to the binary just compiled. It is possible to use this callback, for instance, to inspect the binary for further dependencies. =item not_execute Do not try to execute generated binary. Only check that compilation has not failed. =back =head2 check_lib_or_exit This behaves exactly the same as C<assert_lib()> except that instead of dieing, it warns (with exactly the same error message) and exits. This is intended for use in Makefile.PL / Build.PL when you might want to prompt the user for various paths and things before checking that what they've told you is sane. If any library or header is missing, it exits with an exit value of 0 to avoid causing a CPAN Testers 'FAIL' report. CPAN Testers should ignore this result -- which is what you want if an external library dependency is not available. =head2 check_lib This behaves exactly the same as C<assert_lib()> except that it is silent, returning false instead of dieing, or true otherwise. =cut sub check_lib_or_exit { eval 'assert_lib(@_)'; if($@) { warn $@; exit; } } sub check_lib { eval 'assert_lib(@_)'; return $@ ? 0 : 1; } # borrowed from Text::ParseWords sub _parse_line { my($delimiter, $keep, $line) = @_; my($word, @pieces); no warnings 'uninitialized'; # we will be testing undef strings while (length($line)) { # This pattern is optimised to be stack conservative on older perls. # Do not refactor without being careful and testing it on very long strings. # See Perl bug #42980 for an example of a stack busting input. $line =~ s/^ (?: # double quoted string (") # $quote ((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted | # --OR-- # singe quoted string (') # $quote ((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted | # --OR-- # unquoted string ( # $unquoted (?:\\.|[^\\"'])*? ) # followed by ( # $delim \Z(?!\n) # EOL | # --OR-- (?-x:$delimiter) # delimiter | # --OR-- (?!^)(?=["']) # a quote ) )//xs or return; # extended layout my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6); return() unless( defined($quote) || length($unquoted) || length($delim)); if ($keep) { $quoted = "$quote$quoted$quote"; } else { $unquoted =~ s/\\(.)/$1/sg; if (defined $quote) { $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); } } $word .= substr($line, 0, 0); # leave results tainted $word .= defined $quote ? $quoted : $unquoted; if (length($delim)) { push(@pieces, $word); push(@pieces, $delim) if ($keep eq 'delimiters'); undef $word; } if (!length($line)) { push(@pieces, $word); } } return(@pieces); } sub assert_lib { my %args = @_; my (@libs, @libpaths, @headers, @incpaths); # FIXME: these four just SCREAM "refactor" at me @libs = (ref($args{lib}) ? @{$args{lib}} : $args{lib}) if $args{lib}; @libpaths = (ref($args{libpath}) ? @{$args{libpath}} : $args{libpath}) if $args{libpath}; @headers = (ref($args{header}) ? @{$args{header}} : $args{header}) if $args{header}; @incpaths = (ref($args{incpath}) ? @{$args{incpath}} : $args{incpath}) if $args{incpath}; my $analyze_binary = $args{analyze_binary}; my $not_execute = $args{not_execute}; my @argv = @ARGV; push @argv, _parse_line('\s+', 0, $ENV{PERL_MM_OPT}||''); # work-a-like for Makefile.PL's LIBS and INC arguments # if given as command-line argument, append to %args for my $arg (@argv) { for my $mm_attr_key (qw(LIBS INC)) { if (my ($mm_attr_value) = $arg =~ /\A $mm_attr_key = (.*)/x) { # it is tempting to put some \s* into the expression, but the # MM command-line parser only accepts LIBS etc. followed by =, # so we should not be any more lenient with whitespace than that $args{$mm_attr_key} .= " $mm_attr_value"; } } } # using special form of split to trim whitespace if(defined($args{LIBS})) { foreach my $arg (split(' ', $args{LIBS})) { die("LIBS argument badly-formed: $arg\n") unless($arg =~ /^-[lLR]/); push @{$arg =~ /^-l/ ? \@libs : \@libpaths}, substr($arg, 2); } } if(defined($args{INC})) { foreach my $arg (split(' ', $args{INC})) { die("INC argument badly-formed: $arg\n") unless($arg =~ /^-I/); push @incpaths, substr($arg, 2); } } my ($cc, $ld) = _findcc($args{debug}, $args{ccflags}, $args{ldflags}); my @missing; my @wrongresult; my @wronganalysis; my @use_headers; # first figure out which headers we can't find ... for my $header (@headers) { push @use_headers, $header; my($ch, $cfile) = File::Temp::tempfile( 'assertlibXXXXXXXX', SUFFIX => '.c' ); my $ofile = $cfile; $ofile =~ s/\.c$/$Config{_o}/; print $ch qq{#include <$_>\n} for @use_headers; print $ch qq{int main(void) { return 0; }\n}; close($ch); my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe}; my @sys_cmd; # FIXME: re-factor - almost identical code later when linking if ( $Config{cc} eq 'cl' ) { # Microsoft compiler require Win32; @sys_cmd = ( @$cc, $cfile, "/Fe$exefile", (map { '/I'.Win32::GetShortPathName($_) } @incpaths), "/link", @$ld, split(' ', $Config{libs}), ); } elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland @sys_cmd = ( @$cc, @$ld, (map { "-I$_" } @incpaths), "-o$exefile", $cfile ); } else { # Unix-ish: gcc, Sun, AIX (gcc, cc), ... @sys_cmd = ( @$cc, (map { "-I$_" } @incpaths), $cfile, @$ld, "-o", "$exefile" ); } warn "# @sys_cmd\n" if $args{debug}; my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd); push @missing, $header if $rv != 0 || ! -f $exefile; _cleanup_exe($exefile); unlink $cfile; } # now do each library in turn with headers my($ch, $cfile) = File::Temp::tempfile( 'assertlibXXXXXXXX', SUFFIX => '.c' ); my $ofile = $cfile; $ofile =~ s/\.c$/$Config{_o}/; print $ch qq{#include <$_>\n} foreach (@headers); print $ch "int main(int argc, char *argv[]) { ".($args{function} || 'return 0;')." }\n"; close($ch); for my $lib ( @libs ) { my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe}; my @sys_cmd; if ( $Config{cc} eq 'cl' ) { # Microsoft compiler require Win32; my @libpath = map { q{/libpath:} . Win32::GetShortPathName($_) } @libpaths; # this is horribly sensitive to the order of arguments @sys_cmd = ( @$cc, $cfile, "${lib}.lib", "/Fe$exefile", (map { '/I'.Win32::GetShortPathName($_) } @incpaths), "/link", @$ld, split(' ', $Config{libs}), (map {'/libpath:'.Win32::GetShortPathName($_)} @libpaths), ); } elsif($Config{cc} eq 'CC/DECC') { # VMS } elsif($Config{cc} =~ /bcc32(\.exe)?/) { # Borland @sys_cmd = ( @$cc, @$ld, "-o$exefile", (map { "-I$_" } @incpaths), (map { "-L$_" } @libpaths), "-l$lib", $cfile); } else { # Unix-ish # gcc, Sun, AIX (gcc, cc) @sys_cmd = ( @$cc, (map { "-I$_" } @incpaths), $cfile, (map { "-L$_" } @libpaths), "-l$lib", @$ld, "-o", "$exefile", ); } warn "# @sys_cmd\n" if $args{debug}; local $ENV{LD_RUN_PATH} = join(":", grep $_, @libpaths, $ENV{LD_RUN_PATH}) unless $^O eq 'MSWin32'; local $ENV{PATH} = join(";", @libpaths).";".$ENV{PATH} if $^O eq 'MSWin32'; my $rv = $args{debug} ? system(@sys_cmd) : _quiet_system(@sys_cmd); if ($rv != 0 || ! -f $exefile) { push @missing, $lib; } else { chmod 0755, $exefile; my $absexefile = File::Spec->rel2abs($exefile); $absexefile = '"'.$absexefile.'"' if $absexefile =~ m/\s/; if (!$not_execute && system($absexefile) != 0) { push @wrongresult, $lib; } else { if ($analyze_binary) { push @wronganalysis, $lib if !$analyze_binary->($lib, $exefile) } } } _cleanup_exe($exefile); } unlink $cfile; my $miss_string = join( q{, }, map { qq{'$_'} } @missing ); die("Can't link/include C library $miss_string, aborting.\n") if @missing; my $wrong_string = join( q{, }, map { qq{'$_'} } @wrongresult); die("wrong result: $wrong_string\n") if @wrongresult; my $analysis_string = join(q{, }, map { qq{'$_'} } @wronganalysis ); die("wrong analysis: $analysis_string") if @wronganalysis; } sub _cleanup_exe { my ($exefile) = @_; my $ofile = $exefile; $ofile =~ s/$Config{_exe}$/$Config{_o}/; # List of files to remove my @rmfiles; push @rmfiles, $exefile, $ofile, "$exefile\.manifest"; if ( $Config{cc} eq 'cl' ) { # MSVC also creates foo.ilk and foo.pdb my $ilkfile = $exefile; $ilkfile =~ s/$Config{_exe}$/.ilk/; my $pdbfile = $exefile; $pdbfile =~ s/$Config{_exe}$/.pdb/; push @rmfiles, $ilkfile, $pdbfile; } foreach (@rmfiles) { if ( -f $_ ) { unlink $_ or warn "Could not remove $_: $!"; } } return } # return ($cc, $ld) # where $cc is an array ref of compiler name, compiler flags # where $ld is an array ref of linker flags sub _findcc { my ($debug, $user_ccflags, $user_ldflags) = @_; # Need to use $keep=1 to work with MSWin32 backslashes and quotes my $Config_ccflags = $Config{ccflags}; # use copy so ASPerl will compile my @Config_ldflags = (); for my $config_val ( @Config{qw(ldflags)} ){ push @Config_ldflags, $config_val if ( $config_val =~ /\S/ ); } my @ccflags = grep { length } quotewords('\s+', 1, $Config_ccflags||'', $user_ccflags||''); my @ldflags = grep { length && $_ !~ m/^-Wl/ } quotewords('\s+', 1, @Config_ldflags, $user_ldflags||''); my @paths = split(/$Config{path_sep}/, $ENV{PATH}); my @cc = split(/\s+/, $Config{cc}); if (check_compiler ($cc[0], $debug)) { return ( [ @cc, @ccflags ], \@ldflags ); } # Find the extension for executables. my $exe = $Config{_exe}; if ($^O eq 'cygwin') { $exe = ''; } foreach my $path (@paths) { # Look for "$path/$cc[0].exe" my $compiler = File::Spec->catfile($path, $cc[0]) . $exe; if (check_compiler ($compiler, $debug)) { return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags) } next if ! $exe; # Look for "$path/$cc[0]" without the .exe, if necessary. $compiler = File::Spec->catfile($path, $cc[0]); if (check_compiler ($compiler, $debug)) { return ([ $compiler, @cc[1 .. $#cc], @ccflags ], \@ldflags) } } die("Couldn't find your C compiler.\n"); } sub check_compiler { my ($compiler, $debug) = @_; if (-f $compiler && -x $compiler) { if ($debug) { warn("# Compiler seems to be $compiler\n"); } return 1; } return ''; } # code substantially borrowed from IPC::Run3 sub _quiet_system { my (@cmd) = @_; # save handles local *STDOUT_SAVE; local *STDERR_SAVE; open STDOUT_SAVE, ">&STDOUT" or die "CheckLib: $! saving STDOUT"; open STDERR_SAVE, ">&STDERR" or die "CheckLib: $! saving STDERR"; # redirect to nowhere local *DEV_NULL; open DEV_NULL, ">" . File::Spec->devnull or die "CheckLib: $! opening handle to null device"; open STDOUT, ">&" . fileno DEV_NULL or die "CheckLib: $! redirecting STDOUT to null handle"; open STDERR, ">&" . fileno DEV_NULL or die "CheckLib: $! redirecting STDERR to null handle"; # run system command my $rv = system(@cmd); # restore handles open STDOUT, ">&" . fileno STDOUT_SAVE or die "CheckLib: $! restoring STDOUT handle"; open STDERR, ">&" . fileno STDERR_SAVE or die "CheckLib: $! restoring STDERR handle"; return $rv; } =head1 PLATFORMS SUPPORTED You must have a C compiler installed. We check for C<$Config{cc}>, both literally as it is in Config.pm and also in the $PATH. It has been tested with varying degrees of rigorousness on: =over =item gcc (on Linux, *BSD, Mac OS X, Solaris, Cygwin) =item Sun's compiler tools on Solaris =item IBM's tools on AIX =item SGI's tools on Irix 6.5 =item Microsoft's tools on Windows =item MinGW on Windows (with Strawberry Perl) =item Borland's tools on Windows =item QNX =back =head1 WARNINGS, BUGS and FEEDBACK This is a very early release intended primarily for feedback from people who have discussed it. The interface may change and it has not been adequately tested. Feedback is most welcome, including constructive criticism. Bug reports should be made using L<http://rt.cpan.org/> or by email. When submitting a bug report, please include the output from running: perl -V perl -MDevel::CheckLib -e0 =head1 SEE ALSO L<Devel::CheckOS> L<Probe::Perl> =head1 AUTHORS David Cantrell E<lt>david@cantrell.org.ukE<gt> David Golden E<lt>dagolden@cpan.orgE<gt> Yasuhiro Matsumoto E<lt>mattn@cpan.orgE<gt> Thanks to the cpan-testers-discuss mailing list for prompting us to write it in the first place; to Chris Williams for help with Borland support; to Tony Cook for help with Microsoft compiler command-line options =head1 COPYRIGHT and LICENCE Copyright 2007 David Cantrell. Portions copyright 2007 David Golden. This module is free-as-in-speech software, and may be used, distributed, and modified under the same conditions as perl itself. =head1 CONSPIRACY This module is also free-as-in-mason software. =cut 1; perl5/POD2/DE/local/lib.pod 0000444 00000040462 14711217542 0011143 0 ustar 00 =encoding utf8 =head1 NAME local::lib~[de] - Erschaffen und benutzen von Perl Modulen in einem lokalen lib/ Verzeichnis mit PERL5LIB =head1 SYNOPSIS Im Code - use local::lib; # Benutzt das Verzeichnis ~/perl5 zum anlegen des lokalen lib/ Verzeichnisses use local::lib '~/foo'; # das selbe, aber mit ~/foo # Oder... use FindBin; use local::lib "$FindBin::Bin/../support"; # Applikationsspezifische Sammlung von Modulen Von der Shell - # Installiert LWP und alle notwendigen Abhängigkeiten in das '~/perl5' Verzeichnis perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' # Gibt die Shell Kommandos aus um die Umgebung vorzubereiten $ perl -Mlocal::lib export PERL_MB_OPT='--install_base /home/username/perl5' export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5' export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5' export PATH="/home/username/perl5/bin:$PATH" =head2 Die Bootstrapping Methode Ein typischer Weg um local::lib zu benutzen ist die sogenannte "Bootstrapping" Methode. Diese Methode wird benutzt wenn noch kein local::lib auf dem System installiert ist. In diesem Fall kannst du einfach local::lib direkt in deinem Home-Verzeichnis installieren. Selbst wenn du administrative Rechte hast, ist es wichtig das die Umgebungsvariablen von Schritt 4 in deinem Shell Startup Skript gesetzt werden. Ohne diesen Schritt werden die Module von CPAN weiterhin im System installiert und auch Perl Skripte die du startest würden das von local::lib erstellte lib/ Verzeichnis nicht nutzen. Standardmäßig installiert sich local::lib in ~/perl5. Windows Benutzern müssen ausserdem dies hier lesen: L</Unterschiede bei Benutzung dieses Module mit Win32>. 1. Lade das Tar-Archiv von CPAN runter (Suche nach "Download" auf der CPAN Seite von local::lib) und entpacke es in einem beliebigem Verzeichnis. Um das obige Problem zu vermeiden, sollte man dies als normaler User tun und nicht als root oder Administrator. 2. Starte in dem entstandenen Verzeichnis folgenden Befehl: perl Makefile.PL --bootstrap Wenn das System dir vorschlägt gewisse Dinge eigenständig zu konfigurieren ist es in fast allen Fällen vollkommen in Ordnung einfach "yes" zu antworten. Falls du local::lib nicht in das Standard Verzeichnis installieren willst, musst du dieses Verzeichnis als Parameter angeben: perl Makefile.PL --bootstrap=~/foo 3. Danach folgenden Befehl starten: (local::lib erwartet make auf dem System) make test && make install 4. Nun müssen wir die benötigten Umgebungsvariablen, damit Perl unser neu generiertes lib/ Verzeichnis benutzt. Wenn du bash oder eine andere Bourne Shell benutzt, kannst du es über diesen Weg zu deinem Shell Startup Skript hinzufügen: echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc Wenn du C Shell benutzt, du kannst das gleiche hiermit erreichen: /bin/csh echo $SHELL /bin/csh perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc Wenn du beim bootstrappen ein anderes Verzeichnis benutzt als das Standardverzeichnis, dann musst du dieses Verzeichnis als Parameter beim Laden des Modules local::lib angeben: echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc Nachdem diese Änderungen in deinem Shell Startup Skript gemacht wurden, ist es nun wichtig das diese Umgebungsvariablen auch gesetzt sind in deiner aktuellen Umgebung. In Bourne Shells macht man dies z.B. mit C<. ~/.bashrc>, und in C Shell würde man es mit: C<source ~/.cshrc> mit. Wenn du eine sehr langsames System hast, oder du unter drakonischen Regulierungen des Plattenplatz leben musst, kann man die automatische Generierung der manpages vom POD bei der Installation des Moduls deaktivieren beim bootstrapping mit dem C<--no-manpages> Parameter: perl Makefile.PL --bootstrap --no-manpages Um zu vermeiden das man mehrere bootstraps macht um z.B. für verschiedene Applikationen eigene local::lib Installationen zu nutzen, kann man eine dieser Umgebungen benutzen um einfach in beliebigen anderen Verzeichnis Module zu installieren und somit weitere eigenständige lib/ Umgebungen zu bekommen: cd ~/mydir1 perl -Mlocal::lib=./ eval $(perl -Mlocal::lib=./) ### Um die Umgebungsvariablen für die ### aktuelle Shell zusetzen printenv ### Hier kannst du sehen das ~/mydir1 ### in der PERL5LIB Umgebungsvariable ### steht perl -MCPAN -e install ... ### welche Module auch immer ... cd ../mydir2 ... WIEDERHOLEN ... Für mehrere Umgebungen in dieser Form brauch man eine Modifikation in der Benutzung von C<< use FindBin >> in dem "Im Code" Beispiel oben. Wenn du sowas machst, und du hast damit z.B. Perl Module nach C<< ~/mydir1/lib >> installiert und du hast ein Script in C<< ~/mydir1/scripts/myscript.pl >>, du musst dort angeben das die Module die es braucht im Verzeichnis C<< ~/mydir1/lib >> liegen. In C<< ~/mydir1/scripts/myscript.pl >> steht dann: use strict; use warnings; use local::lib "$FindBin::Bin/.."; ### zeigt auf ~/mydir1 und local::lib ### findet dort lib use lib "$FindBin::Bin/../lib"; ### zeigt auf ~/mydir1/lib Setze das vor jeden BEGIN { ... } Block der die Module braucht die du installiert hast. =head2 Unterschiede bei Benutzung dieses Module mit Win32 Um die nötigen Umgebungsvariablen für diese Variablen in der derzeitigen Sitzung mit C<CMD.EXE> zu setzen, kann man folgendes kommando nutzen: C:\>perl -Mlocal::lib set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% ### Um die Umgebungsvariablen für diese Shell alleine zu setzen C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat ### anstelle von $(perl -Mlocal::lib=./) in bash. Wenn du willst das die Umgebungsvariablen dauerhaft gesetzt sind, musst du diese in Systemsteuerung / System dauerhaft selber eintragen oder L<App::local::lib::Win32Helper> benutzen. Die "~" wird übersetzt zu dem Benutzer Profil Verzeichnis (das Verzeichnis was beim User als "Dokumente und Einstellungen" bekannt ist unter Windows XP und vorher oder das "Benutzer" Verzeichnis bei Windows Vista und später), solange $ENV{HOME} nicht gesetzt ist. Das Verzeichnis wird hierbei zu dem korrekten Kurznamen umgewandelt, und muss daher definitiv existieren, und wird um die nötigen Unterverzeichnise erweitert. =head1 GRUNDPRINZIP Die Version von den Perl Paketen die man benötigt für spezifische Aufgaben sind sehr häufig nicht die richtigen oder korrekten Versionen auf dem System vorinstalliert. Ein Updaten von diesen Modulen ist in vielen Fällen einfach nicht möglich weil die nötigen Rechte fehlen. Ausserdem ist es generell nicht gut eigenständig die Versionen der Module auf dem System auszutauschen, weil natürlich der Rest des Systems genau die Version erwartet die von der Systemverwaltung auch installiert wurde. local::lib löst dieses Problem, es erlaubt dir dein komplett eigenes Verzeichnis für deine CPAN Module zu haben und bist so nicht genötigt die Module vom System zu nutzen oder andersrum andere User nicht mit individuellen Modulwünschen zu Überarbeitung ihres Codes zu zwingen, weil bestimmte Module zentral für alle auf neuere Version upgedatet werden. Die Installation findet hierbei dann z.B. im Home Verzeichnis statt. Es werden nur Umgebungsvariablen gesetzt die das installierte Perl dazu bewegen die im Homeverzeichnis installierten Module zu benutzen, zusätzlich und vorgezogen zu denen auf dem System. Daher muss man sich wenn man ein Paket System benutzt, wie z.b. Debian, garnicht mehr Sorgen machen, irgendwas auf dem System zu verletzten nur durch die Installation von Perl Modulen. =head1 BESCHREIBUNG Dieses Modul bietet eine schnelle und legitime Art und Weise ein sogenanntes bootstrapping zu machen um in einem User Homeverzeichnis eine Sammlung von Modulen zu installieren. Es erstellt auch die nötigen Umgebungsvariablen die benötigt werden um diese Module zu nutzen, passend zu der Shell die der User in der Umgebungsvariable C<SHELL> angegeben hat, um dann direkt passend in die entsprechenden Konfigurationsdateien der Shell einfügt zu werden. Weitergehend ist local::lib in der Lage Module zu nutzen die nicht im standardmäßigen C<@INC> Pfad von Perl enthalten sind. Das macht es einfacher für bestimmte Applikationen ein bestimmtes Set von Modulen zu installieren ohne die anderen Module auf dem System in irgendeiner Art anzufassen. Damit es z.B. auch sicherer Module zu installieren die vom Maintainer noch nicht als Release verfügbar sind. Beim Import setzt local::lib die folgenden Umgebungsvariablen zu den nötigen Werten: =over 4 =item PERL_MB_OPT =item PERL_MM_OPT =item PERL5LIB =item PATH Am PATH wird natürlich angehangen, und nicht ersetzt. =back Diese Werte sind dann verfügbar für jeden Code der danach importiert wurde. =head1 ERSTELLEN EINES EIGENSTÄNDIGE SAMMLUNG VON MODULEN Mit L<lib::core::only> besteht eine Möglichkeit dieses zutun, aber beachte das hier eine Menge von Fallstricken und Problemen existieren, und man sollte immer darauf achten das man auf einem Perl aufbaut was sowenig wie möglich verändert wurde (d.h. site und vendor Verzeichnis so leer wie möglich). =head1 METHODEN =head2 ensure_dir_structure_for =over 4 =item Parameter: $path =item Rückgabewert: Keiner =back Versucht den angegebenen Pfad anzulegen, mit allen nötigen drüberliegenden Verzeichnissen. Im Fehlerfall wird eine Exception geworfen. =head2 print_environment_vars_for =over 4 =item Parameter: $pfad =item Rückgabewert: Keiner =back Gibt die Umgebungsvariablen aus, die benötigt werden um den angegebenen Pfad als Basis Verzeichnis zu nutzen. =head2 build_environment_vars_for =over 4 =item Parameter: $pfad, $interpolate =item Rückgabewert: \%umgebungs_variablen =back Gibt ein Hash zurück mit den Variablen die nötig sind in den Umgebungsvariablen um eine Installation in dem gegebenen Pfad zu benutzen. =head2 setup_env_hash_for =over 4 =item Parameter: $pfad =item Rückgabewert: Keiner =back Setzt die C<%ENV> Einträge basierend auf dem Aufruf von L</build_environment_vars_for>. =head2 install_base_perl_path =over 4 =item Parameter: $pfad =item Rückgabewert: $module_installations_pfad =back Gibt den Pfad zurück der benutzt wird um Perl Module zu installieren bei dem gegebenen Pfad als Basis. Prinzipiell wird nur C<lib> und C<perl5> als Pfadelemente angehangen. =head2 install_base_arch_path =over 4 =item Parameter: $pfad =item Rückgabewert: $architektur_module_installations_pfad =back Gibt den Pfad zurück der benutzt wird um die Architektur-abhängigen Perl Module zu installieren basirend auf dem angegebenen Pfad als Basis. Basierend auf dem was L</install_base_perl_path> zurückgibt, and appends the value of C<$Config{archname}>.asis. =head2 install_base_bin_path =over 4 =item Parameter: $pfad =item Rückgabewert: $ausfuehrbare_programme_installations_pfad =back Gibt den Pfad zurück, wo ausführbare Programme installiert werden, basierend auf der Basis des angegebenen Pfad. Basierend auf L</install_base_perl_path> Rückgabewert, hängt diese Methode noch C<bin> an. =head2 resolve_empty_path =over 4 =item Parameter: $pfad =item Rückgabewert: $basis_pfad =back Erstellt und gibt zurück den Pfad der benutzt wird als Basis zur Installation der Module. Standardmäßig dies ist C<~/perl5>. =head2 resolve_home_path( $path ) =over 4 =item Parameter: $pfad =item Rückgabewert: $home =back Versucht das Home Verzeichnis vom aktullen User zu finden. Wenn C<File::HomeDir> installiert ist, für dieses benutzt dafür. Es wird eine Exception geworfen, wenn kein Home Verzeichnis ermittelt werden konnte. =head2 resolve_relative_path =over 4 =item Parameter: $pfad =item Rückgabewert: $absoluter_pfad =back Macht aus dem angegebenen Pfad einen absoluten Pfad. =head2 resolve_path =over 4 =item Parameter: $pfad =item Rückgabewert: $absoluter_pfad =back Hierbei wird der Pfad durch die folgende Methoden gegeben, wobei der Rückgabewert der ersten an die nächste weitergeben wird, um die Umgebung zu konfigurieren für die lokale Bibliotheks Installation: L</resolve_empty_path>, L</resolve_home_path>, L</resolve_relative_path>. Der daraus resultierende Pfad wird zu L</resolve_empty_path> übergeben, dessen Resultat dann weitergegeben wird an L</resolve_home_path>, wessen Resultat dann weitergegeben wird an L</resolve_relative_path>. Dieses Resultat wird dann final an L</resolve_path> übergeben, welches dann den Rückgabewert stellt. =head1 EINE WARNUNG VOR UNINST=1 Wenn man local::lib in Kombination mit "make install UNINST=1" benutzt, muss man vorsichtig sein über die Tatsache das der Prozess über die Neuinstallation eine nicht ausreichende Sicherheit hat bezüglich wo er nun installieren muss. Hierdurch mann es passieren das beim deinstallieren eines Modul u.U. das globale Modul deinstalliert wird (wenn die Rechte vorhanden sind) aber die neue Version nur in der lokalen Version installiert ist. Es ist hier also sehr wichtig das man "make install UNINST=1" und local::lib nur gleichzeitig benutzt wenn man sehr sicher darüber ist welche Konsequenzen einem entgegenkommen. =head1 EINSCHRÄNKUNGEN Die Werkzeuge von perl, die benutzt werden um die Pakete zu installieren (die sogenannte toolchain), sind leider nicht in der Lage sauber mit Verzeichnissen umzugehen die Leerzeichen enthalten und können daher local::lib nicht direkt in ein solches Verzeichnis installieren. Was du machen kannst ist B<nach> der Installation von local::lib und der Module die du in deiner local::lib haben willst, das gesamte Verzeichnis dahin zu bewegen. local::lib kann mit dem Verzeichnis mit Leerzeichen umgehen. Bitte aufpassen das natürlich eine weitere Installation oder ein Erneuern von Paketen mit dem CPAN Programm nicht mehr möglich ist. Die Shell Erkennung ist sehr primitiv. Derzeit ist es so das alles was "csh" im Namen hat auch als C Shell eingeordnet wird, und alles andere wird als Bourne Shell betrachet, ausser auf Win32 Systemen. Wenn die C<SHELL> Variable nicht gesetzt ist, eine Bourne Shell wird angenommen. Bootstrap ist leider ein Hack, und wird auf jedenfall CPAN.pm benutzen für ExtUtils::MakeMaker, auch wenn CPANPLUS installiert ist. Es setzt definitiv PERL5LIB, PERL_MM_OPT und PERL_MB_OPT neu und vernichtet jeden Wert der vorher gesetzt war. Es sollte vielleicht eine automatische Korrektur der CPAN Config machen, wenn das nicht schon gemacht wurde. "Patches Welcome" - Patches sind immer willkommen beim Autor oder den anderen Mitwirkenden. Auf Win32 Systemen werden die Umgebungsvariablen nicht direkt in die Registrierung geschrieben damit sie auch nach dem Neustarten erhalten bleiben. =head1 FEHLERANALYSE Wenn du local::lib konfiguriert hast CPAN Module in deinem Home Verzeichnis zu installieren, und du danach versuchst mit C<cpan -i Foo::Bar> ein Modul zu installieren, und dabei einen Fehler bekommst, wie: C<Warning: You do not have permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at /usr/lib64/perl5/5.8.8/Foo/Bar.pm> und in der installationsausgabe steht irgendwo ein Fehler der sagt C<'INSTALL_BASE' is not a known MakeMaker parameter name>, dann hast du aus irgendeinem Grund dein neue Version von ExtUtils::MakeMaker verloren. Um dies zu korrigieren, einfach nochmal die bootstrapping Methode laufen lassen, wie oben beschrieben. Dann starte C<rm -r ~/.cpan/build/Foo-Bar*> Abschliessend dann nochmal mit C<cpan -i Foo::Bar> installieren und die Probleme sollten verschwunden sein. =head1 UMGEBUNGSVARIABLEN =over 4 =item SHELL =item COMSPEC local::lib schaut in die C<SHELL> Umgebungsvariable um die korrekten Kommandos zu der Shell Konfiguration hinzuzufügen. Auf Win32 Systemen, C<COMSPEC> wird auch analysiert. =back =head1 SUPPORT IRC: Wir sind im Channel #local-lib auf dem Server irc.perl.org. =head1 AUTOR DER ÜBERSETZUNG Torsten Raudssus <torsten@raudssus.de> http://www.raudssus.de/ =head1 URHEBERRECHT Copyright (c) 2007 - 2010 von den local::lib L<local::lib/"AUTHOR"> und L<local::lib/"CONTRIBUTORS"> aufgelistet in L<local::lib|local::lib>. =head1 LIZENZ Diese Sammlung ist freie Software und kann unter der selben Lizenz verbreitet werden wie Perl selber. =cut 1; perl5/POD2/PT_BR/local/lib.pod 0000444 00000037336 14711217542 0011567 0 ustar 00 =encoding utf8 =head1 NAME local::lib~[pt_br] - crie e use um diretório lib/ local para módulos perl com PERL5LIB =head1 SINOPSE No código - use local::lib; # configura um lib local em ~/perl5 use local::lib '~/foo'; # idem, mas ~/foo # Ou... use FindBin; use local::lib "$FindBin::Bin/../suporte"; # bibliotecas de suporte locais à aplicação Pela linha de comando (shell) - # Instala o LWP e suas dependências não encontradas no diretório '~/perl5' perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' # Apenas exibe alguns comandos úteis para a shell $ perl -Mlocal::lib export PERL_MB_OPT='--install_base /home/username/perl5' export PERL_MM_OPT='INSTALL_BASE=/home/username/perl5' export PERL5LIB='/home/username/perl5/lib/perl5/i386-linux:/home/username/perl5/lib/perl5' export PATH="/home/username/perl5/bin:$PATH" =head2 A técnica de 'bootstrapping' Uma forma comum de instalar o local::lib é usando o que é conhecido como técnica de "bootstrapping". É uma boa abordagem caso seu administrador de sistemas não tenha instalado o local::lib. Nesse caso, você precisará instalar o local::lib em seu diretório de usuário. Caso você tenha privilégios de administrador, ainda assim deverá configurar suas variáveis de ambiente, como discutido no passo 4, abaixo. Sem elas, você ainda instalará módulos no CPAN do sistema e seus scripts Perl não utilizarão o caminho para o lib/ que você definiu com o local::lib. Por padrão, o local::lib instala os módulos do CPAN e a si próprio em ~/perl5. Usuários do Windows devem ler L</Diferenças ao usar esse módulo em Win32>. 1. Baixe e descompacte o local::lib do CPAN (procure por "Download" na página do CPAN sobre o local::lib). Faça isso como um usuário comum, não como root ou administrador. Descompacte o arquivo em seu diretório de usuário ou em qualquer outro local conveniente. 2. Execute isso: perl Makefile.PL --bootstrap Caso o sistema pergunte se deve configurar tudo que puder automaticamente, você provavelmente deve responder que sim (yes). Para instalar o local::lib em um diretório que não o padrão, você precisará especificá-lo ao chamar o bootstrap, da seguinte forma: perl Makefile.PL --bootstrap=~/foo 3. Execute isso: (local::lib assume que você possui o comando 'make' instalado em seu sistema) make test && make install 4. Agora precisamos configurar as variáveis de ambiente apropriadas para que o Perl use nosso recém-criado diretório lib/. Caso esteja usando bash ou outra shell Bourne, você pode fazer isso adicionando a seguinte linha em seu script de inicialização da shell: echo 'eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)' >>~/.bashrc Caso esteja usando a shell C, pode fazer da seguinte forma: /bin/csh echo $SHELL /bin/csh perl -I$HOME/perl5/lib/perl5 -Mlocal::lib >> ~/.cshrc Caso tenha passado para o bootstrap um diretório que não o padrão, você precisará indicá-lo na chamada ao local::lib, dessa forma: echo 'eval $(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)' >>~/.bashrc Após atualizar seu arquivo de configuração da shell, certifique-se de processá-lo novamente para obter as modificações em sua shell atual. Shells Bourne usam C<. ~/.bashrc> para isso, enquanto shells C usam C<source ~/.cshrc>. Se estiver em uma máquina lenta ou operando com grandes limitações de espaço em disco, você pode desativar a geração automática de manpages a partir do POD ao instalar módulos. Para isso, basta passar o argumento C<--no-manpages> durante o bootstrap: perl Makefile.PL --bootstrap --no-manpages Para evitar ter que fazer vários bootstraps para vários ambientes de módulos Perl na mesma conta de usuário - por exemplo se você usa o local::lib para desenvolver diferentes aplicativos independentes - você pode utilizar uma única instalação bootstrap do local::lib para instalar módulos em diretórios diferentes da seguinte forma: cd ~/meudir1 perl -Mlocal::lib=./ eval $(perl -Mlocal::lib=./) ### Para configurar o ambiente apenas nessa shell printenv ### Veja que o ~/meudir1 está na PERL5LIB perl -MCPAN -e install ... ### Os módulos que quiser cd ../meudir2 ... REPITA ... Para múltiplos ambientes destinados a múltiplos aplicativos, você pode precisar incluir uma versão modificada das instruções de C<< use FindBin >> no exemplo "No código" acima. Caso tenha feito algo como o que foi descrito acima, terá um conjunto de módulos Perl em C<< ~/meudir1/lib >>. Caso tenha um script em C<< ~/meudir1/scripts/meuscript.pl >>, você precisará indicar a ele onde encontrar os módulos que instalou para ele em C<< ~/meudir1/lib >>. Em C<< ~/meudir1/scripts/meuscript.pl >>: use strict; use warnings; use local::lib "$FindBin::Bin/.."; ### aponta para ~/meudir1 e o local::lib acha o lib/ use lib "$FindBin::Bin/../lib"; ### aponta para ~/meudir1/lib Coloque isso antes de qualquer bloco BEGIN { ... } que precise dos módulos instalados. =head2 Diferenças ao usar esse módulo em Win32 Para configurar as variáveis de ambiente apropriadas para sua sessão atual do C<CMD.exe>, você pode fazer assim: C:\>perl -Mlocal::lib set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5;C:\DOCUME~1\ADMINI~1\perl5\lib\perl5\MSWin32-x86-multi-thread set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% ### Para configurar o ambiente apenas dessa shell C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\temp.bat ### em vez de $(perl -Mlocal::lib=./) Caso queira que as configurações do ambiente persistam, você precisará adicioná-las em Painel de Controle -> Sistema, ou usar o L<App::local::lib::Win32Helper>. O "~" é transformado no diretório do perfil do usuário (o diretório com o nome do usuário dentro de "Documents and Settings" (Windows XP ou anterior) ou "Usuários" (Windows Vista e mais recentes)) a menos que $ENV{HOME} exista. Após isso, o nome do diretório é encurtado e os subdiretórios são criados (o que significa que o diretório deve existir). =head1 MOTIVAÇÃO A versão de um pacote Perl na sua máquina nem sempre é a que você precisa. Obviamente, a melhor coisa a fazer seria atualizá-la para a versão desejada. No entanto, você pode estar em uma situação que o impede de fazer isso. Talvez você não tenha privilégios de administrador do sistema; ou talvez esteja usando um sistema de gerenciamento de pacotes como o do Debian, e ainda não exista um pacote disponível na versão desejada. local::lib resolve esse problema possibilitando a criação de seu próprio diretório de pacotes Perl obtidos do CPAN (em sistemas multi-usuário, isso normalmente fica dentro do diretório de seu usuário). A instalação do Perl no sistema permanece inalterada; você simplesmente chama o Perl com opções especiais para que ele use os pacotes em seu diretório local em vez dos pacotes do sistema. O local::lib organiza as coisas para que versões dos pacotes Perl instalados localmente tenham precedência sobre as do sistema. Caso esteja usando um sistema de gerenciamento de pacote (como em sistemas Debian), não precisará se preocupar com conflitos entre o Debian e o CPAN. Sua versão local dos pacotes será instalada em um diretório completamente diferente das versões instaladas pelo gerenciador de pacotes do sistema. =head1 DESCRIÇÃO Este módulo oferece uma forma rápida e conveniente para criar um repositório de módulos locais ao usuário, dentro do diretório do mesmo. Ele também monta e exibe para o usuário uma lista de variáveis de ambiente utilizando a sintaxe da shell atual do usuário (conforme especificado pela variável de ambiente C<SHELL>), pronta para ser adicionada diretamente no arquivo de configuração da shell. Generalizando, o local::lib permite a criação e uso de um diretório contendo módulos Perl fora do C<@INC> do Perl. Isso facilita a produção de aplicações com uma versão específica de determinado módulo, ou coleção de módulos. Também é útil quando o mantenedor de um módulo não aplicou determinado patch que você precisa para seu aplicativo. Durante o C<import>, o local::lib define valores apropriados para as seguintes variáveis de ambiente: =over 4 =item PERL_MB_OPT =item PERL_MM_OPT =item PERL5LIB =item PATH valores serão anexados ao PATH, em vez de substituí-lo. =back Esses valores são então disponibilizados para referência por qualquer outro código após o C<import>. =head1 CRIANDO UM CONJUNTO AUTO-CONTIDO DE MÓDULOS Veja L<lib::core::only|lib::core::only> para uma maneira de fazer isso - mas note que há uma série de ressalvas na abordagem, e a melhor forma é sempre fazer o 'build' contra uma versão limpa do perl (i.e. com 'site' e 'vendor' o mais vazios possível). =head1 MÉTODOS =head2 ensure_dir_structure_for =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: Nenhum =back Tenta criar o caminho fornecido, e todos os diretórios superiores necessários. Gera uma exceção em caso de falha. =head2 print_environment_vars_for =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: Nenhum =back Exibe na saída padrão as variáveis listadas acima, devidamente ajustadas para utilizar o caminho fornecido como diretório base. =head2 build_environment_vars_for =over 4 =item Argumentos: $caminho_do_diretorio, $interpolar =item Valor de Retorno: %variaveis_de_ambiente =back Retorna hash contendo as variáveis de ambiente listadas acima, devidamente ajustadas para utilizar o caminho fornecido como diretório base. =head2 setup_env_hash_for =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: Nenhum =back Constrói as chaves no C<%ENV> para o caminho fornecido, chamando C<build_environment_vars_for>. =head2 install_base_perl_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_base_de_instalacao =back Retorna um caminho de diretório indicando onde instalar os módulos Perl para essa instalação local de bibliotecas. Adiciona os diretórios C<lib> e C<perl5> ao final do caminho fornecido. =head2 install_base_arch_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_base_de_instalacao_arch =back Retorna um caminho de diretório indicando onde instalar os módulos Perl de arquiteturas específicas para essa instalação local de bibliotecas. Baseia-se no valor de retorno do método L</install_base_perl_path>, adicionando o valor de C<$Config{archname}>. =head2 install_base_bin_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_base_de_instalacao_bin =back Retorna um caminho de diretório indicando onde instalar programas executáveis para essa instalação local de bibliotecas. Baseia-se no valor de retorno do método L</install_base_perl_path>, adicionando o diretório C<bin>. =head2 resolve_empty_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_base_de_instalacao =back Cria e retorna o caminho de diretório raiz em que a instalação local de módulos deve ser feita. O padrão é C<~/perl5>. =head2 resolve_home_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_para_home =back Procura pelo diretório padrão (home) do usuário. Caso esteja instalado, utiliza o C<File::HomeDir> para isso. Gera uma exceção caso não encontre resultado definitivo. =head2 resolve_relative_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_absoluto =back Transforma o caminho fornecido em um caminho absoluto. =head2 resolve_path =over 4 =item Argumentos: $caminho_do_diretorio =item Valor de Retorno: $caminho_absoluto =back Invoca os seguintes métodos em sequência, passando o resultado do método anterior para o seguinte, na tentativa de descobrir onde configurar o ambiente para a instalação local de bibliotecas: L</resolve_empty_path>, L</resolve_home_path>, L</resolve_relative_path>. Passa o caminho de diretório fornecido para L</resolve_empty_path> que retorna um resultado que é passado para L</resolve_home_path>, que então tem seu resultado passado para L</resolve_relative_path>. O resultado dessa chamada final é então retornado pelo L</resolve_path>. =head1 UM AVISO SOBRE UNINST=1 Tenha cuidado ao usar o local::lib em conjunto com "make install UNINST=1". A idéia dessa opção é desinstalar a versão anterior de um módulo antes de instalar a mais recente. No entanto ela não possui uma verificação de segurança de que a versão antiga e a nova referem-se ao mesmo diretório. Usada em combinação com o local::lib, você pode potencialmente apagar uma versão globalmente acessível de um módulo e instalar a versão mais nova no diretório local. Apenas utilize "make install UNINST=1" junto com o local::lib se você entende essas possíveis consequências. =head1 LIMITAÇÕES As ferramentas auxiliares do perl não conseguem lidar com nomes de diretórios contendo espaços, então não é possível fazer seu bootstrap do local::lib em um diretório com espaços. O que você pode fazer é mover seu local::lib para um diretório com espaços B<após> ter instalado todos os módulos dentro dele. Mas esteja ciente que você não poderá atualizar ou instalar outros módulos do CPAN nesse diretório local após a mudança. A detecção da shell é relativamente básica. Neste momento, qualquer coisa com csh no nome será tratada como a C shell ou compatível, e todo o resto será tratado como Bourne, exceto em sistemas Win32. Caso a variável de ambiente C<SHELL> não esteja disponível, assumiremos tratar-se de uma shell compatível com a Bourne. A técnica de bootstrap é um hack e usará o CPAN.pm para o ExtUtils::MakeMaker mesmo que você tenha o CPANPLUS instalado. Destrói qualquer valor pré-existente nas variáveis de ambiente PERL5LIB, PERL_MM_OPT e PERL_MB_OPT. Provavelmente deveria auto-configurar o CPAN caso isso ainda não tenha sido feito. Correções (patches) são muito bem-vindos para quaisquer dos itens acima. Em sistemas Win32, não há uma forma de escrever no registro as variáveis de ambiente criadas, para que elas persistam a uma reinicialização. =head1 SOLUÇÃO DE PROBLEMAS Se você configurou o local::lib para instalar módulos do CPAN em algum lugar do seu 'home', e mais tarde tentou instalar um módulo fazendo C<cpan -i Foo::Bar>, mas ele falhou com um erro como: C<Warning: You do not have permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at /usr/lib64/perl5/5.8.8/Foo/Bar.pm> e em algum lugar no seu log de instalação houver um erro dizendo C<'INSTALL_BASE' is not a known MakeMaker parameter name>, então você de alguma forma perdeu seu ExtUtils::MakeMaker atualizado. Para remediar a situação, execute novamente o procedimento de bootstrap descrito acima. Então, execute C<rm -r ~/.cpan/build/Foo-Bar*> Finalmente, execute novamente o C<cpan -i Foo::Bar> e ele deve instalar sem problemas. =head1 AMBIENTE =over 4 =item SHELL =item COMSPEC O local::lib procura pela variável de ambiente C<SHELL> do usuário ao processar e exibir os comandos a serem adicionados no arquivo de configuração da shell. Em sistemas Win32, C<COMSPEC> também será examinado. =back =head1 SUPORTE IRC: Acesse #local-lib em irc.perl.org. =head1 AUTOR DA TRADUÇÃO Breno G. de Oliveira, C<< <garu at cpan.org> >>, após ter perdido uma aposta para o L<Getty|http://search.cpan.org/~getty/> durante a Copa de 2010. =head1 COPYRIGHT Copyright (c) 2007 - 2010 L<local::lib/"AUTHOR"> e L<local::lib/"CONTRIBUTORS"> do local::lib como listados em L<local::lib>. =head1 LICENÇA Esta biblioteca é software livre e pode ser distribuída sob os mesmo termos do perl. perl5/Canary/Stability.pm 0000444 00000015452 14711217542 0011323 0 ustar 00 =head1 NAME Canary::Stability - canary to check perl compatibility for schmorp's modules =head1 SYNOPSIS # in Makefile.PL use Canary::Stability DISTNAME => 2001, MINIMUM_PERL_VERSION; =head1 DESCRIPTION This module is used by Schmorp's modules during configuration stage to test the installed perl for compatibility with his modules. It's not, at this stage, meant as a tool for other module authors, although in principle nothing prevents them from subscribing to the same ideas. See the F<Makefile.PL> in L<Coro> or L<AnyEvent> for usage examples. =cut package Canary::Stability; BEGIN { $VERSION = 2013; } sub sgr { # we just assume ANSI almost everywhere # red 31, yellow 33, green 32 local $| = 1; $ENV{PERL_CANARY_STABILITY_COLOUR} ne 0 and ((-t STDOUT and length $ENV{TERM}) or $ENV{PERL_CANARY_STABILITY_COLOUR}) and print "\e[$_[0]m"; } sub import { my (undef, $distname, $minvers, $minperl) = @_; $ENV{PERL_CANARY_STABILITY_DISABLE} and return; $minperl ||= 5.008002; print <<EOF; *** *** Canary::Stability COMPATIBILITY AND SUPPORT CHECK *** ================================================= *** *** Hi! *** *** I do my best to provide predictable and reliable software. *** *** However, in recent releases, P5P (who maintain perl) have been *** introducing regressions that are sometimes subtle and at other times *** catastrophic, often for personal preferences with little or no concern *** for existing code, most notably CPAN. *** *** For this reason, it has become very hard for me to maintain the level *** of reliability and support I have committed myself to in the past, at *** least with some perl versions: I simply can't keep up working around new *** bugs or gratituous incompatibilities, and in turn you might suffer from *** unanticipated problems. *** *** Therefore I have introduced a support and compatibility check, the results *** of which follow below, together with a FAQ and some recommendations. *** *** This check is just to let you know that there might be a risk, so you can *** make judgement calls on how to proceed - it will not keep the module from *** installing or working. *** EOF if ($minvers > $VERSION) { sgr 33; print <<EOF; *** The stability canary says: (nothing, it died of old age). *** *** Your Canary::Stability module (used by $distname) is too old. *** This is not a fatal problem - while you might want to upgrade to version *** $minvers (currently installed version: $VERSION) to get better support *** status testing, you might also not want to care at all, and all will *** be well as long $distname works well enough for you, as the stability *** canary is only used when installing the distribution. *** EOF } elsif ($] < $minperl) { sgr 33; print <<EOF; *** The stability canary says: chirp (it seems concerned about something). *** *** Your perl version ($]) is older than the $distname distribution *** likes ($minperl). This is not a fatal problem - the module might work *** well with your version of perl, but it does mean the author likely *** won't do anything to make it work if it breaks. *** EOF if ($ENV{AUTOMATED_TESTING}) { print <<EOF; *** Since this is an AUTOMATED_TESTING environment, the stability canary *** decided to fail cleanly here, rather than to generate a false test *** result. *** EOF exit 0; } } elsif (defined $Internals::StabilityBranchVersion) { # note to people studying this modules sources: # the above test is not considered a clean or stable way to # test for the stability branch. sgr 32; print <<EOF; *** The stability canary says: chirp! chirp! (it seems to be quite excited) *** *** It seems you are running schmorp's stability branch of perl. *** All should be well, and if it isn't, you should report this as a bug *** to the $distname author. *** EOF } elsif ($] < 5.021) { #sgr 32; print <<EOF; *** The stability canary says: chirp! chirp! (it seems to be quite happy) *** *** Your version of perl ($]) is quite supported by $distname, nothing *** else to be said, hope it comes in handy. *** EOF } else { sgr 31; print <<EOF; *** The stability canary says: (nothing, it was driven away by harsh weather) *** *** It seems you are running perl version $], likely the "official" or *** "standard" version. While there is nothing wrong with doing that, *** standard perl versions 5.022 and up are not supported by $distname. *** While this might be fatal, it might also be all right - if you run into *** problems, you might want to downgrade your perl or switch to the *** stability branch. *** *** If everything works fine, you can ignore this message. *** EOF sgr 0; print <<EOF; *** *** Stability canary mini-FAQ: *** *** Do I need to do anything? *** With luck, no. While some distributions are known to fail *** already, most should probably work. This message is here *** to alert you that your perl is not supported by $distname, *** and if things go wrong, you either need to downgrade, or *** sidegrade to the stability variant of your perl version, *** or simply live with the consequences. *** *** What is this canary thing? *** It's purpose is to check support status of $distname with *** respect to your perl version. *** *** What is this "stability branch"? *** It's a branch or fork of the official perl, by schmorp, to *** improve stability and compatibility with existing modules. *** *** How can I skip this prompt on automated installs? *** Set PERL_CANARY_STABILITY_NOPROMPT=1 in your environment. *** More info is in the Canary::Stability manpage. *** *** Long version of this FAQ: http://stableperl.schmorp.de/faq.html *** Stability Branch homepage: http://stableperl.schmorp.de/ *** EOF unless ($ENV{PERL_CANARY_STABILITY_NOPROMPT}) { require ExtUtils::MakeMaker; ExtUtils::MakeMaker::prompt ("Continue anyways? ", "y") =~ /^y/i or die "FATAL: User aborted configuration of $distname.\n"; } } sgr 0; } =head1 ENVIRONMENT VARIABLES =over 4 =item C<PERL_CANARY_STABILITY_NOPROMPT=1> Do not prompt the user on alert messages. =item C<PERL_CANARY_STABILITY_COLOUR=0> Disable use of colour. =item C<PERL_CANARY_STABILITY_COLOUR=1> Force use of colour. =item C<PERL_CANARY_STABILITY_DISABLE=1> Disable this modules functionality completely. =item C<AUTOMATED_TESTING=1> When this variable is set to a true value and the perl minimum version requirement is not met, the module will exit, which should skip testing under automated testing environments. This is done to avoid false failure or success reports when the chances of success are already quite low and the failures are not supported by the author. =back =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://software.schmorp.de/pkg/Canary-Stability.html =cut 1 perl5/local/lib.pm 0000444 00000120342 14711217542 0007775 0 ustar 00 package local::lib; use 5.006; BEGIN { if ($ENV{RELEASE_TESTING}) { require strict; strict->import; require warnings; warnings->import; } } use Config (); our $VERSION = '2.000024'; $VERSION = eval $VERSION; BEGIN { *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian') ? sub(){1} : sub(){0}; # punt on these systems *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'}) ? sub(){1} : sub(){0}; } my $_archname = $Config::Config{archname}; my $_version = $Config::Config{version}; my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list}; my $_path_sep = $Config::Config{path_sep}; our $_DIR_JOIN = _WIN32 ? '\\' : '/'; our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]} : qr{/}; our $_ROOT = _WIN32 ? do { my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+}; qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}; } : qr{^/}; our $_PERL; sub _perl { if (!$_PERL) { # untaint and validate ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/; $_PERL = 'perl' if $exe !~ /perl/; if (_is_abs($_PERL)) { } elsif (-x $Config::Config{perlpath}) { $_PERL = $Config::Config{perlpath}; } elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) { $_PERL = _rel2abs($_PERL); } else { ($_PERL) = map { /(.*)/ } grep { -x $_ } map { ($_, _WIN32 ? ("$_.exe") : ()) } map { join($_DIR_JOIN, $_, $_PERL) } split /\Q$_path_sep\E/, $ENV{PATH}; } } $_PERL; } sub _cwd { if (my $cwd = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd : defined &Cwd::cwd ? \&Cwd::cwd : undef ) { no warnings 'redefine'; *_cwd = $cwd; goto &$cwd; } my $drive = shift; return Win32::Cwd() if _WIN32 && defined &Win32::Cwd && !$drive; local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd'; my $perl = _perl; my $cwd = `"$perl" -MCwd -le "print $cmd"`; chomp $cwd; if (!length $cwd && $drive) { $cwd = $drive; } $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/; $cwd; } sub _catdir { if (_USE_FSPEC) { require File::Spec; File::Spec->catdir(@_); } else { my $dir = join($_DIR_JOIN, @_); $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g; $dir; } } sub _is_abs { if (_USE_FSPEC) { require File::Spec; File::Spec->file_name_is_absolute($_[0]); } else { $_[0] =~ $_ROOT; } } sub _rel2abs { my ($dir, $base) = @_; return $dir if _is_abs($dir); $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1") : $base ? _rel2abs($base) : _cwd; return _catdir($base, $dir); } our $_DEVNULL; sub _devnull { return $_DEVNULL ||= _USE_FSPEC ? (require File::Spec, File::Spec->devnull) : _WIN32 ? 'nul' : $^O eq 'os2' ? '/dev/nul' : '/dev/null'; } sub import { my ($class, @args) = @_; if ($0 eq '-') { push @args, @ARGV; require Cwd; } my @steps; my %opts; my %attr; my $shelltype; while (@args) { my $arg = shift @args; # check for lethal dash first to stop processing before causing problems # the fancy dash is U+2212 or \xE2\x88\x92 if ($arg =~ /\xE2\x88\x92/) { die <<'DEATH'; WHOA THERE! It looks like you've got some fancy dashes in your commandline! These are *not* the traditional -- dashes that software recognizes. You probably got these by copy-pasting from the perldoc for this module as rendered by a UTF8-capable formatter. This most typically happens on an OS X terminal, but can happen elsewhere too. Please try again after replacing the dashes with normal minus signs. DEATH } elsif ($arg eq '--self-contained') { die <<'DEATH'; FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise). DEATH } elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) { my $path = defined $1 ? $1 : shift @args; push @steps, ['deactivate', $path]; } elsif ( $arg eq '--deactivate-all' ) { push @steps, ['deactivate_all']; } elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) { $shelltype = defined $1 ? $1 : shift @args; } elsif ( $arg eq '--no-create' ) { $opts{no_create} = 1; } elsif ( $arg eq '--quiet' ) { $attr{quiet} = 1; } elsif ( $arg =~ /^--/ ) { die "Unknown import argument: $arg"; } else { push @steps, ['activate', $arg, \%opts]; } } if (!@steps) { push @steps, ['activate', undef, \%opts]; } my $self = $class->new(%attr); for (@steps) { my ($method, @args) = @$_; $self = $self->$method(@args); } if ($0 eq '-') { print $self->environment_vars_string($shelltype); exit 0; } else { $self->setup_local_lib; } } sub new { my $class = shift; bless {@_}, $class; } sub clone { my $self = shift; bless {%$self, @_}, ref $self; } sub inc { $_[0]->{inc} ||= \@INC } sub libs { $_[0]->{libs} ||= [ \'PERL5LIB' ] } sub bins { $_[0]->{bins} ||= [ \'PATH' ] } sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] } sub extra { $_[0]->{extra} ||= {} } sub quiet { $_[0]->{quiet} } sub _as_list { my $list = shift; grep length, map { !(ref $_ && ref $_ eq 'SCALAR') ? $_ : ( defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_}) : () ) } ref $list ? @$list : $list; } sub _remove_from { my ($list, @remove) = @_; return @$list if !@remove; my %remove = map { $_ => 1 } @remove; grep !$remove{$_}, _as_list($list); } my @_lib_subdirs = ( [$_version, $_archname], [$_version], [$_archname], (map [$_], @_inc_version_list), [], ); sub install_base_bin_path { my ($class, $path) = @_; return _catdir($path, 'bin'); } sub install_base_perl_path { my ($class, $path) = @_; return _catdir($path, 'lib', 'perl5'); } sub install_base_arch_path { my ($class, $path) = @_; _catdir($class->install_base_perl_path($path), $_archname); } sub lib_paths_for { my ($class, $path) = @_; my $base = $class->install_base_perl_path($path); return map { _catdir($base, @$_) } @_lib_subdirs; } sub _mm_escape_path { my $path = shift; $path =~ s/\\/\\\\/g; if ($path =~ s/ /\\ /g) { $path = qq{"$path"}; } return $path; } sub _mb_escape_path { my $path = shift; $path =~ s/\\/\\\\/g; return qq{"$path"}; } sub installer_options_for { my ($class, $path) = @_; return ( PERL_MM_OPT => defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef, PERL_MB_OPT => defined $path ? "--install_base "._mb_escape_path($path) : undef, ); } sub active_paths { my ($self) = @_; $self = ref $self ? $self : $self->new; return grep { # screen out entries that aren't actually reflected in @INC my $active_ll = $self->install_base_perl_path($_); grep { $_ eq $active_ll } @{$self->inc}; } _as_list($self->roots); } sub deactivate { my ($self, $path) = @_; $self = $self->new unless ref $self; $path = $self->resolve_path($path); $path = $self->normalize_path($path); my @active_lls = $self->active_paths; if (!grep { $_ eq $path } @active_lls) { warn "Tried to deactivate inactive local::lib '$path'\n"; return $self; } my %args = ( bins => [ _remove_from($self->bins, $self->install_base_bin_path($path)) ], libs => [ _remove_from($self->libs, $self->install_base_perl_path($path)) ], inc => [ _remove_from($self->inc, $self->lib_paths_for($path)) ], roots => [ _remove_from($self->roots, $path) ], ); $args{extra} = { $self->installer_options_for($args{roots}[0]) }; $self->clone(%args); } sub deactivate_all { my ($self) = @_; $self = $self->new unless ref $self; my @active_lls = $self->active_paths; my %args; if (@active_lls) { %args = ( bins => [ _remove_from($self->bins, map $self->install_base_bin_path($_), @active_lls) ], libs => [ _remove_from($self->libs, map $self->install_base_perl_path($_), @active_lls) ], inc => [ _remove_from($self->inc, map $self->lib_paths_for($_), @active_lls) ], roots => [ _remove_from($self->roots, @active_lls) ], ); } $args{extra} = { $self->installer_options_for(undef) }; $self->clone(%args); } sub activate { my ($self, $path, $opts) = @_; $opts ||= {}; $self = $self->new unless ref $self; $path = $self->resolve_path($path); $self->ensure_dir_structure_for($path, { quiet => $self->quiet }) unless $opts->{no_create}; $path = $self->normalize_path($path); my @active_lls = $self->active_paths; if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) { $self = $self->deactivate($path); } my %args; if ($opts->{always} || !@active_lls || $active_lls[0] ne $path) { %args = ( bins => [ $self->install_base_bin_path($path), @{$self->bins} ], libs => [ $self->install_base_perl_path($path), @{$self->libs} ], inc => [ $self->lib_paths_for($path), @{$self->inc} ], roots => [ $path, @{$self->roots} ], ); } $args{extra} = { $self->installer_options_for($path) }; $self->clone(%args); } sub normalize_path { my ($self, $path) = @_; $path = ( Win32::GetShortPathName($path) || $path ) if $^O eq 'MSWin32'; return $path; } sub build_environment_vars_for { my $self = $_[0]->new->activate($_[1], { always => 1 }); $self->build_environment_vars; } sub build_activate_environment_vars_for { my $self = $_[0]->new->activate($_[1], { always => 1 }); $self->build_environment_vars; } sub build_deactivate_environment_vars_for { my $self = $_[0]->new->deactivate($_[1]); $self->build_environment_vars; } sub build_deact_all_environment_vars_for { my $self = $_[0]->new->deactivate_all; $self->build_environment_vars; } sub build_environment_vars { my $self = shift; ( PATH => join($_path_sep, _as_list($self->bins)), PERL5LIB => join($_path_sep, _as_list($self->libs)), PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)), %{$self->extra}, ); } sub setup_local_lib_for { my $self = $_[0]->new->activate($_[1]); $self->setup_local_lib; } sub setup_local_lib { my $self = shift; # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to # check in the other direction) require Carp::Heavy if $INC{'Carp.pm'}; $self->setup_env_hash; @INC = @{$self->inc}; } sub setup_env_hash_for { my $self = $_[0]->new->activate($_[1]); $self->setup_env_hash; } sub setup_env_hash { my $self = shift; my %env = $self->build_environment_vars; for my $key (keys %env) { if (defined $env{$key}) { $ENV{$key} = $env{$key}; } else { delete $ENV{$key}; } } } sub print_environment_vars_for { print $_[0]->environment_vars_string_for(@_[1..$#_]); } sub environment_vars_string_for { my $self = $_[0]->new->activate($_[1], { always => 1}); $self->environment_vars_string; } sub environment_vars_string { my ($self, $shelltype) = @_; $shelltype ||= $self->guess_shelltype; my $extra = $self->extra; my @envs = ( PATH => $self->bins, PERL5LIB => $self->libs, PERL_LOCAL_LIB_ROOT => $self->roots, map { $_ => $extra->{$_} } sort keys %$extra, ); $self->_build_env_string($shelltype, \@envs); } sub _build_env_string { my ($self, $shelltype, $envs) = @_; my @envs = @$envs; my $build_method = "build_${shelltype}_env_declaration"; my $out = ''; while (@envs) { my ($name, $value) = (shift(@envs), shift(@envs)); if ( ref $value && @$value == 1 && ref $value->[0] && ref $value->[0] eq 'SCALAR' && ${$value->[0]} eq $name) { next; } $out .= $self->$build_method($name, $value); } my $wrap_method = "wrap_${shelltype}_output"; if ($self->can($wrap_method)) { return $self->$wrap_method($out); } return $out; } sub build_bourne_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '${%s:-}', qr/["\\\$!`]/, '\\%s'); if (!defined $value) { return qq{unset $name;\n}; } $value =~ s/(^|\G|$_path_sep)\$\{$name:-\}$_path_sep/$1\${$name}\${$name:+$_path_sep}/g; $value =~ s/$_path_sep\$\{$name:-\}$/\${$name:+$_path_sep\${$name}}/; qq{${name}="$value"; export ${name};\n} } sub build_csh_env_declaration { my ($class, $name, $args) = @_; my ($value, @vars) = $class->_interpolate($args, '${%s}', qr/["\$]/, '"\\%s"'); if (!defined $value) { return qq{unsetenv $name;\n}; } my $out = ''; for my $var (@vars) { $out .= qq{if ! \$?$name setenv $name '';\n}; } my $value_without = $value; if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) { $out .= qq{if "\${$name}" != '' setenv $name "$value";\n}; $out .= qq{if "\${$name}" == '' }; } $out .= qq{setenv $name "$value_without";\n}; return $out; } sub build_cmd_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s'); if (!$value) { return qq{\@set $name=\n}; } my $out = ''; my $value_without = $value; if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) { $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n}; $out .= qq{\@if "%$name%"=="" }; } $out .= qq{\@set "$name=$value_without"\n}; return $out; } sub build_powershell_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '$env:%s', qr/["\$]/, '`%s'); if (!$value) { return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}; } my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})}; $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g; $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/; qq{\$env:$name = \$("$value");\n}; } sub wrap_powershell_output { my ($class, $out) = @_; return $out || " \n"; } sub build_fish_env_declaration { my ($class, $name, $args) = @_; my $value = $class->_interpolate($args, '$%s', qr/[\\"'$ ]/, '\\%s'); if (!defined $value) { return qq{set -e $name;\n}; } # fish has special handling for PATH, CDPATH, and MANPATH. They are always # treated as arrays, and joined with ; when storing the environment. Other # env vars can be arrays, but will be joined without a separator. We only # really care about PATH, but might as well make this routine more general. if ($name =~ /^(?:CD|MAN)?PATH$/) { $value =~ s/$_path_sep/ /g; my $silent = $name =~ /^(?:CD)?PATH$/ ? " ^"._devnull : ''; return qq{set -x $name $value$silent;\n}; } my $out = ''; my $value_without = $value; if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) { $out .= qq{set -q $name; and set -x $name $value;\n}; $out .= qq{set -q $name; or }; } $out .= qq{set -x $name $value_without;\n}; $out; } sub _interpolate { my ($class, $args, $var_pat, $escape, $escape_pat) = @_; return unless defined $args; my @args = ref $args ? @$args : $args; return unless @args; my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args; my $string = join $_path_sep, map { ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do { s/($escape)/sprintf($escape_pat, $1)/ge; $_; }; } @args; return wantarray ? ($string, \@vars) : $string; } sub pipeline; sub pipeline { my @methods = @_; my $last = pop(@methods); if (@methods) { \sub { my ($obj, @args) = @_; $obj->${pipeline @methods}( $obj->$last(@args) ); }; } else { \sub { shift->$last(@_); }; } } sub resolve_path { my ($class, $path) = @_; $path = $class->${pipeline qw( resolve_relative_path resolve_home_path resolve_empty_path )}($path); $path; } sub resolve_empty_path { my ($class, $path) = @_; if (defined $path) { $path; } else { '~/perl5'; } } sub resolve_home_path { my ($class, $path) = @_; $path =~ /^~([^\/]*)/ or return $path; my $user = $1; my $homedir = do { if (! length($user) && defined $ENV{HOME}) { $ENV{HOME}; } else { require File::Glob; File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE()); } }; unless (defined $homedir) { require Carp; require Carp::Heavy; Carp::croak( "Couldn't resolve homedir for " .(defined $user ? $user : 'current user') ); } $path =~ s/^~[^\/]*/$homedir/; $path; } sub resolve_relative_path { my ($class, $path) = @_; _rel2abs($path); } sub ensure_dir_structure_for { my ($class, $path, $opts) = @_; $opts ||= {}; my @dirs; foreach my $dir ( $class->lib_paths_for($path), $class->install_base_bin_path($path), ) { my $d = $dir; while (!-d $d) { push @dirs, $d; require File::Basename; $d = File::Basename::dirname($d); } } warn "Attempting to create directory ${path}\n" if !$opts->{quiet} && @dirs; my %seen; foreach my $dir (reverse @dirs) { next if $seen{$dir}++; mkdir $dir or -d $dir or die "Unable to create $dir: $!" } return; } sub guess_shelltype { my $shellbin = defined $ENV{SHELL} && length $ENV{SHELL} ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1] : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} ) ? 'bash' : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} ) ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1] : ( $^O eq 'MSWin32' && !$ENV{PROMPT} ) ? 'powershell.exe' : 'sh'; for ($shellbin) { return /csh$/ ? 'csh' : /fish$/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'; } } 1; __END__ =encoding utf8 =head1 NAME local::lib - create and use a local lib/ for perl modules with PERL5LIB =head1 SYNOPSIS In code - use local::lib; # sets up a local lib at ~/perl5 use local::lib '~/foo'; # same, but ~/foo # Or... use FindBin; use local::lib "$FindBin::Bin/../support"; # app-local support library From the shell - # Install LWP and its missing dependencies to the '~/perl5' directory perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' # Just print out useful shell commands $ perl -Mlocal::lib PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT; PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT; PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB; PATH="/home/username/perl5/bin:$PATH"; export PATH; PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT; From a F<.bash_profile> or F<.bashrc> file - eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)" =head2 The bootstrapping technique A typical way to install local::lib is using what is known as the "bootstrapping" technique. You would do this if your system administrator hasn't already installed local::lib. In this case, you'll need to install local::lib in your home directory. Even if you do have administrative privileges, you will still want to set up your environment variables, as discussed in step 4. Without this, you would still install the modules into the system CPAN installation and also your Perl scripts will not use the lib/ path you bootstrapped with local::lib. By default local::lib installs itself and the CPAN modules into ~/perl5. Windows users must also see L</Differences when using this module under Win32>. =over 4 =item 1. Download and unpack the local::lib tarball from CPAN (search for "Download" on the CPAN page about local::lib). Do this as an ordinary user, not as root or administrator. Unpack the file in your home directory or in any other convenient location. =item 2. Run this: perl Makefile.PL --bootstrap If the system asks you whether it should automatically configure as much as possible, you would typically answer yes. In order to install local::lib into a directory other than the default, you need to specify the name of the directory when you call bootstrap, as follows: perl Makefile.PL --bootstrap=~/foo =item 3. Run this: (local::lib assumes you have make installed on your system) make test && make install =item 4. Now we need to setup the appropriate environment variables, so that Perl starts using our newly generated lib/ directory. If you are using bash or any other Bourne shells, you can add this to your shell startup script this way: echo 'eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"' >>~/.bashrc If you are using C shell, you can do this as follows: /bin/csh echo $SHELL /bin/csh echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc If you passed to bootstrap a directory other than default, you also need to give that as import parameter to the call of the local::lib module like this way: echo 'eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc After writing your shell configuration file, be sure to re-read it to get the changed settings into your current shell's environment. Bourne shells use C<. ~/.bashrc> for this, whereas C shells use C<source ~/.cshrc>. =back If you're on a slower machine, or are operating under draconian disk space limitations, you can disable the automatic generation of manpages from POD when installing modules by using the C<--no-manpages> argument when bootstrapping: perl Makefile.PL --bootstrap --no-manpages To avoid doing several bootstrap for several Perl module environments on the same account, for example if you use it for several different deployed applications independently, you can use one bootstrapped local::lib installation to install modules in different directories directly this way: cd ~/mydir1 perl -Mlocal::lib=./ eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone printenv ### You will see that ~/mydir1 is in the PERL5LIB perl -MCPAN -e install ... ### whatever modules you want cd ../mydir2 ... REPEAT ... If you use F<.bashrc> to activate a local::lib automatically, the local::lib will be re-enabled in any sub-shells used, overriding adjustments you may have made in the parent shell. To avoid this, you can initialize the local::lib in F<.bash_profile> rather than F<.bashrc>, or protect the local::lib invocation with a C<$SHLVL> check: [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)" If you are working with several C<local::lib> environments, you may want to remove some of them from the current environment without disturbing the others. You can deactivate one environment like this (using bourne sh): eval $(perl -Mlocal::lib=--deactivate,~/path) which will generate and run the commands needed to remove C<~/path> from your various search paths. Whichever environment was B<activated most recently> will remain the target for module installations. That is, if you activate C<~/path_A> and then you activate C<~/path_B>, new modules you install will go in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be installed in C<~/pathB> because pathB was activated later. You can also ask C<local::lib> to clean itself completely out of the current shell's environment with the C<--deactivate-all> option. For multiple environments for multiple apps you may need to include a modified version of the C<< use FindBin >> instructions in the "In code" sample above. If you did something like the above, you have a set of Perl modules at C<< ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, you need to tell it where to find the modules you installed for it at C<< ~/mydir1/lib >>. In C<< ~/mydir1/scripts/myscript.pl >>: use strict; use warnings; use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib Put this before any BEGIN { ... } blocks that require the modules you installed. =head2 Differences when using this module under Win32 To set up the proper environment variables for your current session of C<CMD.exe>, you can use this: C:\>perl -Mlocal::lib set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5 set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% ### To set the environment for this shell alone C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat ### instead of $(perl -Mlocal::lib=./) If you want the environment entries to persist, you'll need to add them to the Control Panel's System applet yourself or use L<App::local::lib::Win32Helper>. The "~" is translated to the user's profile directory (the directory named for the user under "Documents and Settings" (Windows XP or earlier) or "Users" (Windows Vista or later)) unless $ENV{HOME} exists. After that, the home directory is translated to a short name (which means the directory must exist) and the subdirectories are created. =head3 PowerShell local::lib also supports PowerShell, and can be used with the C<Invoke-Expression> cmdlet. Invoke-Expression "$(perl -Mlocal::lib)" =head1 RATIONALE The version of a Perl package on your machine is not always the version you need. Obviously, the best thing to do would be to update to the version you need. However, you might be in a situation where you're prevented from doing this. Perhaps you don't have system administrator privileges; or perhaps you are using a package management system such as Debian, and nobody has yet gotten around to packaging up the version you need. local::lib solves this problem by allowing you to create your own directory of Perl packages downloaded from CPAN (in a multi-user system, this would typically be within your own home directory). The existing system Perl installation is not affected; you simply invoke Perl with special options so that Perl uses the packages in your own local package directory rather than the system packages. local::lib arranges things so that your locally installed version of the Perl packages takes precedence over the system installation. If you are using a package management system (such as Debian), you don't need to worry about Debian and CPAN stepping on each other's toes. Your local version of the packages will be written to an entirely separate directory from those installed by Debian. =head1 DESCRIPTION This module provides a quick, convenient way of bootstrapping a user-local Perl module library located within the user's home directory. It also constructs and prints out for the user the list of environment variables using the syntax appropriate for the user's current shell (as specified by the C<SHELL> environment variable), suitable for directly adding to one's shell configuration file. More generally, local::lib allows for the bootstrapping and usage of a directory containing Perl modules outside of Perl's C<@INC>. This makes it easier to ship an application with an app-specific copy of a Perl module, or collection of modules. Useful in cases like when an upstream maintainer hasn't applied a patch to a module of theirs that you need for your application. On import, local::lib sets the following environment variables to appropriate values: =over 4 =item PERL_MB_OPT =item PERL_MM_OPT =item PERL5LIB =item PATH =item PERL_LOCAL_LIB_ROOT =back When possible, these will be appended to instead of overwritten entirely. These values are then available for reference by any code after import. =head1 CREATING A SELF-CONTAINED SET OF MODULES See L<lib::core::only> for one way to do this - but note that there are a number of caveats, and the best approach is always to perform a build against a clean perl (i.e. site and vendor as close to empty as possible). =head1 IMPORT OPTIONS Options are values that can be passed to the C<local::lib> import besides the directory to use. They are specified as C<use local::lib '--option'[, path];> or C<perl -Mlocal::lib=--option[,path]>. =head2 --deactivate Remove the chosen path (or the default path) from the module search paths if it was added by C<local::lib>, instead of adding it. =head2 --deactivate-all Remove all directories that were added to search paths by C<local::lib> from the search paths. =head2 --shelltype Specify the shell type to use for output. By default, the shell will be detected based on the environment. Should be one of: C<bourne>, C<csh>, C<cmd>, or C<powershell>. =head2 --no-create Prevents C<local::lib> from creating directories when activating dirs. This is likely to cause issues on Win32 systems. =head1 CLASS METHODS =head2 ensure_dir_structure_for =over 4 =item Arguments: $path =item Return value: None =back Attempts to create a local::lib directory, including subdirectories and all required parent directories. Throws an exception on failure. =head2 print_environment_vars_for =over 4 =item Arguments: $path =item Return value: None =back Prints to standard output the variables listed above, properly set to use the given path as the base directory. =head2 build_environment_vars_for =over 4 =item Arguments: $path =item Return value: %environment_vars =back Returns a hash with the variables listed above, properly set to use the given path as the base directory. =head2 setup_env_hash_for =over 4 =item Arguments: $path =item Return value: None =back Constructs the C<%ENV> keys for the given path, by calling L</build_environment_vars_for>. =head2 active_paths =over 4 =item Arguments: None =item Return value: @paths =back Returns a list of active C<local::lib> paths, according to the C<PERL_LOCAL_LIB_ROOT> environment variable and verified against what is really in C<@INC>. =head2 install_base_perl_path =over 4 =item Arguments: $path =item Return value: $install_base_perl_path =back Returns a path describing where to install the Perl modules for this local library installation. Appends the directories C<lib> and C<perl5> to the given path. =head2 lib_paths_for =over 4 =item Arguments: $path =item Return value: @lib_paths =back Returns the list of paths perl will search for libraries, given a base path. This includes the base path itself, the architecture specific subdirectory, and perl version specific subdirectories. These paths may not all exist. =head2 install_base_bin_path =over 4 =item Arguments: $path =item Return value: $install_base_bin_path =back Returns a path describing where to install the executable programs for this local library installation. Appends the directory C<bin> to the given path. =head2 installer_options_for =over 4 =item Arguments: $path =item Return value: %installer_env_vars =back Returns a hash of environment variables that should be set to cause installation into the given path. =head2 resolve_empty_path =over 4 =item Arguments: $path =item Return value: $base_path =back Builds and returns the base path into which to set up the local module installation. Defaults to C<~/perl5>. =head2 resolve_home_path =over 4 =item Arguments: $path =item Return value: $home_path =back Attempts to find the user's home directory. If installed, uses C<File::HomeDir> for this purpose. If no definite answer is available, throws an exception. =head2 resolve_relative_path =over 4 =item Arguments: $path =item Return value: $absolute_path =back Translates the given path into an absolute path. =head2 resolve_path =over 4 =item Arguments: $path =item Return value: $absolute_path =back Calls the following in a pipeline, passing the result from the previous to the next, in an attempt to find where to configure the environment for a local library installation: L</resolve_empty_path>, L</resolve_home_path>, L</resolve_relative_path>. Passes the given path argument to L</resolve_empty_path> which then returns a result that is passed to L</resolve_home_path>, which then has its result passed to L</resolve_relative_path>. The result of this final call is returned from L</resolve_path>. =head1 OBJECT INTERFACE =head2 new =over 4 =item Arguments: %attributes =item Return value: $local_lib =back Constructs a new C<local::lib> object, representing the current state of C<@INC> and the relevant environment variables. =head1 ATTRIBUTES =head2 roots An arrayref representing active C<local::lib> directories. =head2 inc An arrayref representing C<@INC>. =head2 libs An arrayref representing the PERL5LIB environment variable. =head2 bins An arrayref representing the PATH environment variable. =head2 extra A hashref of extra environment variables (e.g. C<PERL_MM_OPT> and C<PERL_MB_OPT>) =head2 no_create If set, C<local::lib> will not try to create directories when activating them. =head1 OBJECT METHODS =head2 clone =over 4 =item Arguments: %attributes =item Return value: $local_lib =back Constructs a new C<local::lib> object based on the existing one, overriding the specified attributes. =head2 activate =over 4 =item Arguments: $path =item Return value: $new_local_lib =back Constructs a new instance with the specified path active. =head2 deactivate =over 4 =item Arguments: $path =item Return value: $new_local_lib =back Constructs a new instance with the specified path deactivated. =head2 deactivate_all =over 4 =item Arguments: None =item Return value: $new_local_lib =back Constructs a new instance with all C<local::lib> directories deactivated. =head2 environment_vars_string =over 4 =item Arguments: [ $shelltype ] =item Return value: $shell_env_string =back Returns a string to set up the C<local::lib>, meant to be run by a shell. =head2 build_environment_vars =over 4 =item Arguments: None =item Return value: %environment_vars =back Returns a hash with the variables listed above, properly set to use the given path as the base directory. =head2 setup_env_hash =over 4 =item Arguments: None =item Return value: None =back Constructs the C<%ENV> keys for the given path, by calling L</build_environment_vars>. =head2 setup_local_lib Constructs the C<%ENV> hash using L</setup_env_hash>, and set up C<@INC>. =head1 A WARNING ABOUT UNINST=1 Be careful about using local::lib in combination with "make install UNINST=1". The idea of this feature is that will uninstall an old version of a module before installing a new one. However it lacks a safety check that the old version and the new version will go in the same directory. Used in combination with local::lib, you can potentially delete a globally accessible version of a module while installing the new version in a local place. Only combine "make install UNINST=1" and local::lib if you understand these possible consequences. =head1 LIMITATIONS =over 4 =item * Directory names with spaces in them are not well supported by the perl toolchain and the programs it uses. Pure-perl distributions should support spaces, but problems are more likely with dists that require compilation. A workaround you can do is moving your local::lib to a directory with spaces B<after> you installed all modules inside your local::lib bootstrap. But be aware that you can't update or install CPAN modules after the move. =item * Rather basic shell detection. Right now anything with csh in its name is assumed to be a C shell or something compatible, and everything else is assumed to be Bourne, except on Win32 systems. If the C<SHELL> environment variable is not set, a Bourne-compatible shell is assumed. =item * Kills any existing PERL_MM_OPT or PERL_MB_OPT. =item * Should probably auto-fixup CPAN config if not already done. =item * On VMS and MacOS Classic (pre-OS X), local::lib loads L<File::Spec>. This means any L<File::Spec> version installed in the local::lib will be ignored by scripts using local::lib. A workaround for this is using C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly. =item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option. C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and sane behavior. If something attempts to use the C<PREFIX> option when running a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two options conflict. This can be worked around by temporarily unsetting the C<PERL_MM_OPT> environment variable. =item * Conflicts with L<Module::Build>'s C<--prefix> option. Similar to the previous limitation, but any C<--prefix> option specified will be ignored. This can be worked around by temporarily unsetting the C<PERL_MB_OPT> environment variable. =back Patches very much welcome for any of the above. =over 4 =item * On Win32 systems, does not have a way to write the created environment variables to the registry, so that they can persist through a reboot. =back =head1 TROUBLESHOOTING If you've configured local::lib to install CPAN modules somewhere in to your home directory, and at some point later you try to install a module with C<cpan -i Foo::Bar>, but it fails with an error like: C<Warning: You do not have permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at /usr/lib64/perl5/5.8.8/Foo/Bar.pm> and buried within the install log is an error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then you've somehow lost your updated ExtUtils::MakeMaker module. To remedy this situation, rerun the bootstrapping procedure documented above. Then, run C<rm -r ~/.cpan/build/Foo-Bar*> Finally, re-run C<cpan -i Foo::Bar> and it should install without problems. =head1 ENVIRONMENT =over 4 =item SHELL =item COMSPEC local::lib looks at the user's C<SHELL> environment variable when printing out commands to add to the shell configuration file. On Win32 systems, C<COMSPEC> is also examined. =back =head1 SEE ALSO =over 4 =item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html> =back =head1 SUPPORT IRC: Join #toolchain on irc.perl.org. =head1 AUTHOR Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/ auto_install fixes kindly sponsored by http://www.takkle.com/ =head1 CONTRIBUTORS Patches to correctly output commands for csh style shells, as well as some documentation additions, contributed by Christopher Nehren <apeiron@cpan.org>. Doc patches for a custom local::lib directory, more cleanups in the english documentation and a L<german documentation|POD2::DE::local::lib> contributed by Torsten Raudssus <torsten@raudssus.de>. Hans Dieter Pearcey <hdp@cpan.org> sent in some additional tests for ensuring things will install properly, submitted a fix for the bug causing problems with writing Makefiles during bootstrapping, contributed an example program, and submitted yet another fix to ensure that local::lib can install and bootstrap properly. Many, many thanks! pattern of Freenode IRC contributed the beginnings of the Troubleshooting section. Many thanks! Patch to add Win32 support contributed by Curtis Jewell <csjewell@cpan.org>. Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced by a patch from Marco Emilio Poleggi. Mark Stosberg <mark@summersault.com> provided the code for the now deleted '--self-contained' option. Documentation patches to make win32 usage clearer by David Mertens <dcmertens.perl@gmail.com> (run4flat). Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc patches contributed by Breno G. de Oliveira <garu@cpan.org>. Improvements to stacking multiple local::lib dirs and removing them from the environment later on contributed by Andrew Rodland <arodland@cpan.org>. Patch for Carp version mismatch contributed by Hakim Cassimally <osfameron@cpan.org>. Rewrite of internals and numerous bug fixes and added features contributed by Graham Knop <haarg@haarg.org>. =head1 COPYRIGHT Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> as listed above. =head1 LICENSE 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 perl5/Capture/Tiny.pm 0000444 00000071730 14711217543 0010472 0 ustar 00 use 5.006; use strict; use warnings; package Capture::Tiny; # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs our $VERSION = '0.48'; use Carp (); use Exporter (); use IO::Handle (); use File::Spec (); use File::Temp qw/tempfile tmpnam/; use Scalar::Util qw/reftype blessed/; # Get PerlIO or fake it BEGIN { local $@; eval { require PerlIO; PerlIO->can('get_layers') } or *PerlIO::get_layers = sub { return () }; } #--------------------------------------------------------------------------# # create API subroutines and export them # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag] #--------------------------------------------------------------------------# my %api = ( capture => [1,1,0,0], capture_stdout => [1,0,0,0], capture_stderr => [0,1,0,0], capture_merged => [1,1,1,0], tee => [1,1,0,1], tee_stdout => [1,0,0,1], tee_stderr => [0,1,0,1], tee_merged => [1,1,1,1], ); for my $sub ( keys %api ) { my $args = join q{, }, @{$api{$sub}}; eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic } our @ISA = qw/Exporter/; our @EXPORT_OK = keys %api; our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); #--------------------------------------------------------------------------# # constants and fixtures #--------------------------------------------------------------------------# my $IS_WIN32 = $^O eq 'MSWin32'; ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG}; ## ##my $DEBUGFH; ##open $DEBUGFH, "> DEBUG" if $DEBUG; ## ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0}; our $TIMEOUT = 30; #--------------------------------------------------------------------------# # command to tee output -- the argument is a filename that must # be opened to signal that the process is ready to receive input. # This is annoying, but seems to be the best that can be done # as a simple, portable IPC technique #--------------------------------------------------------------------------# my @cmd = ($^X, '-C0', '-e', <<'HERE'); use Fcntl; $SIG{HUP}=sub{exit}; if ( my $fn=shift ) { sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!; print {$fh} $$; close $fh; } my $buf; while (sysread(STDIN, $buf, 2048)) { syswrite(STDOUT, $buf); syswrite(STDERR, $buf); } HERE #--------------------------------------------------------------------------# # filehandle manipulation #--------------------------------------------------------------------------# sub _relayer { my ($fh, $apply_layers) = @_; # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n"); # eliminate pseudo-layers binmode( $fh, ":raw" ); # strip off real layers until only :unix is left while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) { binmode( $fh, ":pop" ); } # apply other layers my @to_apply = @$apply_layers; shift @to_apply; # eliminate initial :unix # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n"); binmode($fh, ":" . join(":",@to_apply)); } sub _name { my $glob = shift; no strict 'refs'; ## no critic return *{$glob}{NAME}; } sub _open { open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!"; # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" ); } sub _close { # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" ); close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!"; } my %dup; # cache this so STDIN stays fd0 my %proxy_count; sub _proxy_std { my %proxies; if ( ! defined fileno STDIN ) { $proxy_count{stdin}++; if (defined $dup{stdin}) { _open \*STDIN, "<&=" . fileno($dup{stdin}); # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); } else { _open \*STDIN, "<" . File::Spec->devnull; # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" ); _open $dup{stdin} = IO::Handle->new, "<&=STDIN"; } $proxies{stdin} = \*STDIN; binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDOUT ) { $proxy_count{stdout}++; if (defined $dup{stdout}) { _open \*STDOUT, ">&=" . fileno($dup{stdout}); # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); } else { _open \*STDOUT, ">" . File::Spec->devnull; # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" ); _open $dup{stdout} = IO::Handle->new, ">&=STDOUT"; } $proxies{stdout} = \*STDOUT; binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic } if ( ! defined fileno STDERR ) { $proxy_count{stderr}++; if (defined $dup{stderr}) { _open \*STDERR, ">&=" . fileno($dup{stderr}); # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); } else { _open \*STDERR, ">" . File::Spec->devnull; # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" ); _open $dup{stderr} = IO::Handle->new, ">&=STDERR"; } $proxies{stderr} = \*STDERR; binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic } return %proxies; } sub _unproxy { my (%proxies) = @_; # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" ); for my $p ( keys %proxies ) { $proxy_count{$p}--; # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" ); if ( ! $proxy_count{$p} ) { _close $proxies{$p}; _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup delete $dup{$p}; } } } sub _copy_std { my %handles; for my $h ( qw/stdout stderr stdin/ ) { next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied my $redir = $h eq 'stdin' ? "<&" : ">&"; _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN" } return \%handles; } # In some cases we open all (prior to forking) and in others we only open # the output handles (setting up redirection) sub _open_std { my ($handles) = @_; _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin}; _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout}; _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr}; } #--------------------------------------------------------------------------# # private subs #--------------------------------------------------------------------------# sub _start_tee { my ($which, $stash) = @_; # $which is "stdout" or "stderr" # setup pipes $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/; pipe $stash->{reader}{$which}, $stash->{tee}{$which}; # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" ); select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush # setup desired redirection for parent and child $stash->{new}{$which} = $stash->{tee}{$which}; $stash->{child}{$which} = { stdin => $stash->{reader}{$which}, stdout => $stash->{old}{$which}, stderr => $stash->{capture}{$which}, }; # flag file is used to signal the child is ready $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$; # execute @cmd as a separate process if ( $IS_WIN32 ) { my $old_eval_err=$@; undef $@; eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ "; # _debug( "# Win32API::File loaded\n") unless $@; my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} ); # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE(); my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0); # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n")); _open_std( $stash->{child}{$which} ); $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which}); # not restoring std here as it all gets redirected again shortly anyway $@=$old_eval_err; } else { # use fork _fork_exec( $which, $stash ); } } sub _fork_exec { my ($which, $stash) = @_; # $which is "stdout" or "stderr" my $pid = fork; if ( not defined $pid ) { Carp::confess "Couldn't fork(): $!"; } elsif ($pid == 0) { # child # _debug( "# in child process ...\n" ); untie *STDIN; untie *STDOUT; untie *STDERR; _close $stash->{tee}{$which}; # _debug( "# redirecting handles in child ...\n" ); _open_std( $stash->{child}{$which} ); # _debug( "# calling exec on command ...\n" ); exec @cmd, $stash->{flag_files}{$which}; } $stash->{pid}{$which} = $pid } my $have_usleep = eval "use Time::HiRes 'usleep'; 1"; sub _files_exist { return 1 if @_ == grep { -f } @_; Time::HiRes::usleep(1000) if $have_usleep; return 0; } sub _wait_for_tees { my ($stash) = @_; my $start = time; my @files = values %{$stash->{flag_files}}; my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT} ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT; 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout)); Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files); unlink $_ for @files; } sub _kill_tees { my ($stash) = @_; if ( $IS_WIN32 ) { # _debug( "# closing handles\n"); close($_) for values %{ $stash->{tee} }; # _debug( "# waiting for subprocesses to finish\n"); my $start = time; 1 until wait == -1 || (time - $start > 30); } else { _close $_ for values %{ $stash->{tee} }; waitpid $_, 0 for values %{ $stash->{pid} }; } } sub _slurp { my ($name, $stash) = @_; my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/; # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n"); seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n"; my $text = do { local $/; scalar readline $fh }; return defined($text) ? $text : ""; } #--------------------------------------------------------------------------# # _capture_tee() -- generic main sub for capturing or teeing #--------------------------------------------------------------------------# sub _capture_tee { # _debug( "# starting _capture_tee with (@_)...\n" ); my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_; my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ()); Carp::confess("Custom capture options must be given as key/value pairs\n") unless @opts % 2 == 0; my $stash = { capture => { @opts } }; for ( keys %{$stash->{capture}} ) { my $fh = $stash->{capture}{$_}; Carp::confess "Custom handle for $_ must be seekable\n" unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable")); } # save existing filehandles and setup captures local *CT_ORIG_STDIN = *STDIN ; local *CT_ORIG_STDOUT = *STDOUT; local *CT_ORIG_STDERR = *STDERR; # find initial layers my %layers = ( stdin => [PerlIO::get_layers(\*STDIN) ], stdout => [PerlIO::get_layers(\*STDOUT, output => 1)], stderr => [PerlIO::get_layers(\*STDERR, output => 1)], ); # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # get layers from underlying glob of tied filehandles if we can # (this only works for things that work like Tie::StdHandle) $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)] if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB'); $layers{stderr} = [PerlIO::get_layers(tied *STDERR)] if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB'); # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # bypass scalar filehandles and tied handles # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN my %localize; $localize{stdin}++, local(*STDIN) if grep { $_ eq 'scalar' } @{$layers{stdin}}; $localize{stdout}++, local(*STDOUT) if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}}; $localize{stderr}++, local(*STDERR) if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}}; $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0") if tied *STDIN && $] >= 5.008; $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if $do_stdout && tied *STDOUT && $] >= 5.008; $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008; # _debug( "# localized $_\n" ) for keys %localize; # proxy any closed/localized handles so we don't use fds 0, 1 or 2 my %proxy_std = _proxy_std(); # _debug( "# proxy std: @{ [%proxy_std] }\n" ); # update layers after any proxying $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout}; $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr}; # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/; # store old handles and setup handles for capture $stash->{old} = _copy_std(); $stash->{new} = { %{$stash->{old}} }; # default to originals for ( keys %do ) { $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new); seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n"; $stash->{pos}{$_} = tell $stash->{capture}{$_}; # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" ); _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new} } _wait_for_tees( $stash ) if $do_tee; # finalize redirection $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge; # _debug( "# redirecting in parent ...\n" ); _open_std( $stash->{new} ); # execute user provided code my ($exit_code, $inner_error, $outer_error, $orig_pid, @result); { $orig_pid = $$; local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN # _debug( "# finalizing layers ...\n" ); _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; # _debug( "# running code $code ...\n" ); my $old_eval_err=$@; undef $@; eval { @result = $code->(); $inner_error = $@ }; $exit_code = $?; # save this for later $outer_error = $@; # save this for later STDOUT->flush if $do_stdout; STDERR->flush if $do_stderr; $@ = $old_eval_err; } # restore prior filehandles and shut down tees # _debug( "# restoring filehandles ...\n" ); _open_std( $stash->{old} ); _close( $_ ) for values %{$stash->{old}}; # don't leak fds # shouldn't need relayering originals, but see rt.perl.org #114404 _relayer(\*STDOUT, $layers{stdout}) if $do_stdout; _relayer(\*STDERR, $layers{stderr}) if $do_stderr; _unproxy( %proxy_std ); # _debug( "# killing tee subprocesses ...\n" ) if $do_tee; _kill_tees( $stash ) if $do_tee; # return captured output, but shortcut in void context # unless we have to echo output to tied/scalar handles; my %got; if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) { for ( keys %do ) { _relayer($stash->{capture}{$_}, $layers{$_}); $got{$_} = _slurp($_, $stash); # _debug("# slurped " . length($got{$_}) . " bytes from $_\n"); } print CT_ORIG_STDOUT $got{stdout} if $do_stdout && $do_tee && $localize{stdout}; print CT_ORIG_STDERR $got{stderr} if $do_stderr && $do_tee && $localize{stderr}; } $? = $exit_code; $@ = $inner_error if $inner_error; die $outer_error if $outer_error; # _debug( "# ending _capture_tee with (@_)...\n" ); return unless defined wantarray; my @return; push @return, $got{stdout} if $do_stdout; push @return, $got{stderr} if $do_stderr && ! $do_merge; push @return, @result; return wantarray ? @return : $return[0]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs =head1 VERSION version 0.48 =head1 SYNOPSIS use Capture::Tiny ':all'; # capture from external command ($stdout, $stderr, $exit) = capture { system( $cmd, @args ); }; # capture from arbitrary code (Perl or external) ($stdout, $stderr, @result) = capture { # your code here }; # capture partial or merged output $stdout = capture_stdout { ... }; $stderr = capture_stderr { ... }; $merged = capture_merged { ... }; # tee output ($stdout, $stderr) = tee { # your code here }; $stdout = tee_stdout { ... }; $stderr = tee_stderr { ... }; $merged = tee_merged { ... }; =head1 DESCRIPTION Capture::Tiny provides a simple, portable way to capture almost anything sent to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or from an external program. Optionally, output can be teed so that it is captured while being passed through to the original filehandles. Yes, it even works on Windows (usually). Stop guessing which of a dozen capturing modules to use in any particular situation and just use this one. =head1 USAGE The following functions are available. None are exported by default. =head2 capture ($stdout, $stderr, @result) = capture \&code; $stdout = capture \&code; The C<capture> function takes a code reference and returns what is sent to STDOUT and STDERR as well as any return values from the code reference. In scalar context, it returns only STDOUT. If no output was received for a filehandle, it returns an empty string for that filehandle. Regardless of calling context, all output is captured -- nothing is passed to the existing filehandles. It is prototyped to take a subroutine reference as an argument. Thus, it can be called in block form: ($stdout, $stderr) = capture { # your code here ... }; Note that the coderef is evaluated in list context. If you wish to force scalar context on the return value, you must use the C<scalar> keyword. ($stdout, $stderr, $count) = capture { my @list = qw/one two three/; return scalar @list; # $count will be 3 }; Also note that within the coderef, the C<@_> variable will be empty. So don't use arguments from a surrounding subroutine without copying them to an array first: sub wont_work { my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG ... } sub will_work { my @args = @_; my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT ... } Captures are normally done to an anonymous temporary filehandle. To capture via a named file (e.g. to externally monitor a long-running capture), provide custom filehandles as a trailing list of option pairs: my $out_fh = IO::File->new("out.txt", "w+"); my $err_fh = IO::File->new("out.txt", "w+"); capture { ... } stdout => $out_fh, stderr => $err_fh; The filehandles must be read/write and seekable. Modifying the files or filehandles during a capture operation will give unpredictable results. Existing IO layers on them may be changed by the capture. When called in void context, C<capture> saves memory and time by not reading back from the capture handles. =head2 capture_stdout ($stdout, @result) = capture_stdout \&code; $stdout = capture_stdout \&code; The C<capture_stdout> function works just like C<capture> except only STDOUT is captured. STDERR is not captured. =head2 capture_stderr ($stderr, @result) = capture_stderr \&code; $stderr = capture_stderr \&code; The C<capture_stderr> function works just like C<capture> except only STDERR is captured. STDOUT is not captured. =head2 capture_merged ($merged, @result) = capture_merged \&code; $merged = capture_merged \&code; The C<capture_merged> function works just like C<capture> except STDOUT and STDERR are merged. (Technically, STDERR is redirected to the same capturing handle as STDOUT before executing the function.) Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head2 tee ($stdout, $stderr, @result) = tee \&code; $stdout = tee \&code; The C<tee> function works just like C<capture>, except that output is captured as well as passed on to the original STDOUT and STDERR. When called in void context, C<tee> saves memory and time by not reading back from the capture handles, except when the original STDOUT OR STDERR were tied or opened to a scalar handle. =head2 tee_stdout ($stdout, @result) = tee_stdout \&code; $stdout = tee_stdout \&code; The C<tee_stdout> function works just like C<tee> except only STDOUT is teed. STDERR is not teed (output goes to STDERR as usual). =head2 tee_stderr ($stderr, @result) = tee_stderr \&code; $stderr = tee_stderr \&code; The C<tee_stderr> function works just like C<tee> except only STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual). =head2 tee_merged ($merged, @result) = tee_merged \&code; $merged = tee_merged \&code; The C<tee_merged> function works just like C<capture_merged> except that output is captured as well as passed on to STDOUT. Caution: STDOUT and STDERR output in the merged result are not guaranteed to be properly ordered due to buffering. =head1 LIMITATIONS =head2 Portability Portability is a goal, not a guarantee. C<tee> requires fork, except on Windows where C<system(1, @cmd)> is used instead. Not tested on any particularly esoteric platforms yet. See the L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny> for test result by platform. =head2 PerlIO layers Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to STDOUT or STDERR I<before> the call to C<capture> or C<tee>. This may not work for tied filehandles (see below). =head2 Modifying filehandles before capturing Generally speaking, you should do little or no manipulation of the standard IO filehandles prior to using Capture::Tiny. In particular, closing, reopening, localizing or tying standard filehandles prior to capture may cause a variety of unexpected, undesirable and/or unreliable behaviors, as described below. Capture::Tiny does its best to compensate for these situations, but the results may not be what you desire. =head3 Closed filehandles Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously closed. However, since they will be reopened to capture or tee output, any code within the captured block that depends on finding them closed will, of course, not find them to be closed. If they started closed, Capture::Tiny will close them again when the capture block finishes. Note that this reopening will happen even for STDIN or a filehandle not being captured to ensure that the filehandle used for capture is not opened to file descriptor 0, as this causes problems on various platforms. Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles and also breaks tee() for undiagnosed reasons. So don't do that. =head3 Localized filehandles If code localizes any of Perl's standard filehandles before capturing, the capture will affect the localized filehandles and not the original ones. External system calls are not affected by localizing a filehandle in Perl and will continue to send output to the original filehandles (which will thus not be captured). =head3 Scalar filehandles If STDOUT or STDERR are reopened to scalar filehandles prior to the call to C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured output to the output filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar reference, but note that external processes will not be able to read from such a handle. Capture::Tiny tries to ensure that external processes will read from the null device instead, but this is not guaranteed. =head3 Tied output filehandles If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then Capture::Tiny will attempt to override the tie for the duration of the C<capture> or C<tee> call and then send captured output to the tied filehandle after the capture is complete. (Requires Perl 5.8) Capture::Tiny may not succeed resending UTF-8 encoded data to a tied STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine appropriate layers like C<:utf8> from the underlying filehandle and do the right thing. =head3 Tied input filehandle Capture::Tiny attempts to preserve the semantics of tied STDIN, but this requires Perl 5.8 and is not entirely predictable. External processes will not be able to read from such a handle. Unless having STDIN tied is crucial, it may be safest to localize STDIN when capturing: my ($out, $err) = do { local *STDIN; capture { ... } }; =head2 Modifying filehandles during a capture Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is almost certainly going to cause problems. Don't do that. =head3 Forking inside a capture Forks aren't portable. The behavior of filehandles during a fork is even less so. If Capture::Tiny detects that a fork has occurred within a capture, it will shortcut in the child process and return empty strings for captures. Other problems may occur in the child or parent, as well. Forking in a capture block is not recommended. =head3 Using threads Filehandles are global. Mixing up I/O and captures in different threads without coordination is going to cause problems. Besides, threads are officially discouraged. =head3 Dropping privileges during a capture If you drop privileges during a capture, temporary files created to facilitate the capture may not be cleaned up afterwards. =head2 No support for Perl 5.8.0 It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later is recommended. =head2 Limited support for Perl 5.6 Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly. =head1 ENVIRONMENT =head2 PERL_CAPTURE_TINY_TIMEOUT Capture::Tiny uses subprocesses internally for C<tee>. By default, Capture::Tiny will timeout with an error if such subprocesses are not ready to receive data within 30 seconds (or whatever is the value of C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable. Setting it to zero will disable timeouts. B<NOTE>, this does not timeout the code reference being captured -- this only prevents Capture::Tiny itself from hanging your process waiting for its child processes to be ready to proceed. =head1 SEE ALSO This module was inspired by L<IO::CaptureOutput>, which provides similar functionality without the ability to tee output and with more complicated code and API. L<IO::CaptureOutput> does not handle layers or most of the unusual cases described in the L</Limitations> section and I no longer recommend it. There are many other CPAN modules that provide some sort of output capture, albeit with various limitations that make them appropriate only in particular circumstances. I'm probably missing some. The long list is provided to show why I felt Capture::Tiny was necessary. =over 4 =item * L<IO::Capture> =item * L<IO::Capture::Extended> =item * L<IO::CaptureOutput> =item * L<IPC::Capture> =item * L<IPC::Cmd> =item * L<IPC::Open2> =item * L<IPC::Open3> =item * L<IPC::Open3::Simple> =item * L<IPC::Open3::Utils> =item * L<IPC::Run> =item * L<IPC::Run::SafeHandles> =item * L<IPC::Run::Simple> =item * L<IPC::Run3> =item * L<IPC::System::Simple> =item * L<Tee> =item * L<IO::Tee> =item * L<File::Tee> =item * L<Filter::Handle> =item * L<Tie::STDERR> =item * L<Tie::STDOUT> =item * L<Test::Output> =back =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/dagolden/Capture-Tiny/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/dagolden/Capture-Tiny> git clone https://github.com/dagolden/Capture-Tiny.git =head1 AUTHOR David Golden <dagolden@cpan.org> =head1 CONTRIBUTORS =for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson =over 4 =item * Dagfinn Ilmari Mannsåker <ilmari@ilmari.org> =item * David E. Wheeler <david@justatheory.com> =item * fecundf <not.com+github@gmail.com> =item * Graham Knop <haarg@haarg.org> =item * Peter Rabbitson <ribasushi@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2009 by David Golden. This is free software, licensed under: The Apache License, Version 2.0, January 2004 =cut perl5/XML/Simple.pm 0000444 00000305420 14711217543 0010031 0 ustar 00 package XML::Simple; $XML::Simple::VERSION = '2.25'; =head1 NAME XML::Simple - An API for simple XML files =head1 SYNOPSIS PLEASE DO NOT USE THIS MODULE IN NEW CODE. If you ignore this warning and use it anyway, the C<qw(:strict)> mode will save you a little pain. use XML::Simple qw(:strict); my $ref = XMLin([<xml file or string>] [, <options>]); my $xml = XMLout($hashref [, <options>]); Or the object oriented way: require XML::Simple qw(:strict); my $xs = XML::Simple->new([<options>]); my $ref = $xs->XMLin([<xml file or string>] [, <options>]); my $xml = $xs->XMLout($hashref [, <options>]); (or see L<"SAX SUPPORT"> for 'the SAX way'). Note, in these examples, the square brackets are used to denote optional items not to imply items should be supplied in arrayrefs. =cut # See after __END__ for more POD documentation # Load essentials here, other modules loaded on demand later use strict; use warnings; use warnings::register; use Carp; use Scalar::Util qw(); require Exporter; ############################################################################## # Define some constants # use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER); @ISA = qw(Exporter); @EXPORT = qw(XMLin XMLout); @EXPORT_OK = qw(xml_in xml_out); my %StrictMode = (); my @KnownOptIn = qw(keyattr keeproot forcecontent contentkey noattr searchpath forcearray cache suppressempty parseropts grouptags nsexpand datahandler varattr variables normalisespace normalizespace valueattr strictmode); my @KnownOptOut = qw(keyattr keeproot contentkey noattr rootname xmldecl outputfile noescape suppressempty grouptags nsexpand handler noindent attrindent nosort valueattr numericescape strictmode); my @DefKeyAttr = qw(name key id); my $DefRootName = qq(opt); my $DefContentKey = qq(content); my $DefXmlDecl = qq(<?xml version='1.0' standalone='yes'?>); my $xmlns_ns = 'http://www.w3.org/2000/xmlns/'; my $bad_def_ns_jcn = '{' . $xmlns_ns . '}'; # LibXML::SAX workaround ############################################################################## # Globals for use by caching routines # my %MemShareCache = (); my %MemCopyCache = (); ############################################################################## # Wrapper for Exporter - handles ':strict' # sub import { # Handle the :strict tag my($calling_package) = caller(); _strict_mode_for_caller(1) if grep(/^:strict$/, @_); # Pass everything else to Exporter.pm @_ = grep(!/^:strict$/, @_); goto &Exporter::import; } ############################################################################## # Constructor for optional object interface. # sub new { my $class = shift; if(@_ % 2) { croak "Default options must be name=>value pairs (odd number supplied)"; } my %known_opt; @known_opt{@KnownOptIn, @KnownOptOut} = (); my %raw_opt = @_; $raw_opt{strictmode} = _strict_mode_for_caller() unless exists $raw_opt{strictmode}; my %def_opt; while(my($key, $val) = each %raw_opt) { my $lkey = lc($key); $lkey =~ s/_//g; croak "Unrecognised option: $key" unless(exists($known_opt{$lkey})); $def_opt{$lkey} = $val; } my $self = { def_opt => \%def_opt }; return(bless($self, $class)); } ############################################################################## # Sub: _strict_mode_for_caller() # # Gets or sets the XML::Simple :strict mode flag for the calling namespace. # Walks back through call stack to find the calling namespace and sets the # :strict mode flag for that namespace if an argument was supplied and returns # the flag value if not. # sub _strict_mode_for_caller { my $set_mode = @_; my $frame = 1; while(my($package) = caller($frame++)) { next if $package eq 'XML::Simple'; $StrictMode{$package} = 1 if $set_mode; return $StrictMode{$package}; } return(0); } ############################################################################## # Sub: _get_object() # # Helper routine called from XMLin() and XMLout() to create an object if none # was provided. Note, this routine does mess with the caller's @_ array. # sub _get_object { my $self; if($_[0] and UNIVERSAL::isa($_[0], 'XML::Simple')) { $self = shift; } else { $self = XML::Simple->new(); } return $self; } ############################################################################## # Sub/Method: XMLin() # # Exported routine for slurping XML into a hashref - see pod for info. # # May be called as object method or as a plain function. # # Expects one arg for the source XML, optionally followed by a number of # name => value option pairs. # sub XMLin { my $self = &_get_object; # note, @_ is passed implicitly my $target = shift; # Work out whether to parse a string, a file or a filehandle if(not defined $target) { return $self->parse_file(undef, @_); } elsif($target eq '-') { local($/) = undef; $target = <STDIN>; return $self->parse_string(\$target, @_); } elsif(my $type = ref($target)) { if($type eq 'SCALAR') { return $self->parse_string($target, @_); } else { return $self->parse_fh($target, @_); } } elsif($target =~ m{<.*?>}s) { return $self->parse_string(\$target, @_); } else { return $self->parse_file($target, @_); } } ############################################################################## # Sub/Method: parse_file() # # Same as XMLin, but only parses from a named file. # sub parse_file { my $self = &_get_object; # note, @_ is passed implicitly my $filename = shift; $self->handle_options('in', @_); $filename = $self->default_config_file if not defined $filename; $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}}); # Check cache for previous parse if($self->{opt}->{cache}) { foreach my $scheme (@{$self->{opt}->{cache}}) { my $method = 'cache_read_' . $scheme; my $opt = $self->$method($filename); return($opt) if($opt); } } my $ref = $self->build_simple_tree($filename, undef); if($self->{opt}->{cache}) { my $method = 'cache_write_' . $self->{opt}->{cache}->[0]; $self->$method($ref, $filename); } return $ref; } ############################################################################## # Sub/Method: parse_fh() # # Same as XMLin, but only parses from a filehandle. # sub parse_fh { my $self = &_get_object; # note, @_ is passed implicitly my $fh = shift; croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') . " as a filehandle" unless ref $fh; $self->handle_options('in', @_); return $self->build_simple_tree(undef, $fh); } ############################################################################## # Sub/Method: parse_string() # # Same as XMLin, but only parses from a string or a reference to a string. # sub parse_string { my $self = &_get_object; # note, @_ is passed implicitly my $string = shift; $self->handle_options('in', @_); return $self->build_simple_tree(undef, ref $string ? $string : \$string); } ############################################################################## # Method: default_config_file() # # Returns the name of the XML file to parse if no filename (or XML string) # was provided. # sub default_config_file { my $self = shift; require File::Basename; my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+'); # Add script directory to searchpath if($script_dir) { unshift(@{$self->{opt}->{searchpath}}, $script_dir); } return $basename . '.xml'; } ############################################################################## # Method: build_simple_tree() # # Builds a 'tree' data structure as provided by XML::Parser and then # 'simplifies' it as specified by the various options in effect. # sub build_simple_tree { my $self = shift; my $tree = eval { $self->build_tree(@_); }; Carp::croak("$@XML::Simple called") if $@; return $self->{opt}->{keeproot} ? $self->collapse({}, @$tree) : $self->collapse(@{$tree->[1]}); } ############################################################################## # Method: build_tree() # # This routine will be called if there is no suitable pre-parsed tree in a # cache. It parses the XML and returns an XML::Parser 'Tree' style data # structure (summarised in the comments for the collapse() routine below). # # XML::Simple requires the services of another module that knows how to parse # XML. If XML::SAX is installed, the default SAX parser will be used, # otherwise XML::Parser will be used. # # This routine expects to be passed a filename as argument 1 or a 'string' as # argument 2. The 'string' might be a string of XML (passed by reference to # save memory) or it might be a reference to an IO::Handle. (This # non-intuitive mess results in part from the way XML::Parser works but that's # really no excuse). # sub build_tree { my $self = shift; my $filename = shift; my $string = shift; my $preferred_parser = $PREFERRED_PARSER; unless(defined($preferred_parser)) { $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || ''; } if($preferred_parser eq 'XML::Parser') { return($self->build_tree_xml_parser($filename, $string)); } eval { require XML::SAX; }; # We didn't need it until now if($@) { # No XML::SAX - fall back to XML::Parser if($preferred_parser) { # unless a SAX parser was expressly requested croak "XMLin() could not load XML::SAX"; } return($self->build_tree_xml_parser($filename, $string)); } $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser); my $sp = XML::SAX::ParserFactory->parser(Handler => $self); $self->{nocollapse} = 1; my($tree); if($filename) { $tree = $sp->parse_uri($filename); } else { if(ref($string) && ref($string) ne 'SCALAR') { $tree = $sp->parse_file($string); } else { $tree = $sp->parse_string($$string); } } return($tree); } ############################################################################## # Method: build_tree_xml_parser() # # This routine will be called if XML::SAX is not installed, or if XML::Parser # was specifically requested. It takes the same arguments as build_tree() and # returns the same data structure (XML::Parser 'Tree' style). # sub build_tree_xml_parser { my $self = shift; my $filename = shift; my $string = shift; eval { local($^W) = 0; # Suppress warning from Expat.pm re File::Spec::load() require XML::Parser; # We didn't need it until now }; if($@) { croak "XMLin() requires either XML::SAX or XML::Parser"; } if($self->{opt}->{nsexpand}) { carp "'nsexpand' option requires XML::SAX"; } my $xp = $self->new_xml_parser(); my($tree); if($filename) { # $tree = $xp->parsefile($filename); # Changed due to prob w/mod_perl open(my $xfh, '<', $filename) || croak qq($filename - $!); $tree = $xp->parse($xfh); } else { $tree = $xp->parse($$string); } return($tree); } ############################################################################## # Method: new_xml_parser() # # Simply calls the XML::Parser constructor. Override this method to customise # the behaviour of the parser. # sub new_xml_parser { my($self) = @_; my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}}); $xp->setHandlers(ExternEnt => sub {return $_[2]}); return $xp; } ############################################################################## # Method: cache_write_storable() # # Wrapper routine for invoking Storable::nstore() to cache a parsed data # structure. # sub cache_write_storable { my($self, $data, $filename) = @_; my $cachefile = $self->storable_filename($filename); require Storable; # We didn't need it until now if ('VMS' eq $^O) { Storable::nstore($data, $cachefile); } else { # If the following line fails for you, your Storable.pm is old - upgrade Storable::lock_nstore($data, $cachefile); } } ############################################################################## # Method: cache_read_storable() # # Wrapper routine for invoking Storable::retrieve() to read a cached parsed # data structure. Only returns cached data if the cache file exists and is # newer than the source XML file. # sub cache_read_storable { my($self, $filename) = @_; my $cachefile = $self->storable_filename($filename); return unless(-r $cachefile); return unless((stat($cachefile))[9] > (stat($filename))[9]); require Storable; # We didn't need it until now if ('VMS' eq $^O) { return(Storable::retrieve($cachefile)); } else { return(Storable::lock_retrieve($cachefile)); } } ############################################################################## # Method: storable_filename() # # Translates the supplied source XML filename into a filename for the storable # cached data. A '.stor' suffix is added after stripping an optional '.xml' # suffix. # sub storable_filename { my($self, $cachefile) = @_; $cachefile =~ s{(\.xml)?$}{.stor}; return $cachefile; } ############################################################################## # Method: cache_write_memshare() # # Takes the supplied data structure reference and stores it away in a global # hash structure. # sub cache_write_memshare { my($self, $data, $filename) = @_; $MemShareCache{$filename} = [time(), $data]; } ############################################################################## # Method: cache_read_memshare() # # Takes a filename and looks in a global hash for a cached parsed version. # sub cache_read_memshare { my($self, $filename) = @_; return unless($MemShareCache{$filename}); return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]); return($MemShareCache{$filename}->[1]); } ############################################################################## # Method: cache_write_memcopy() # # Takes the supplied data structure and stores a copy of it in a global hash # structure. # sub cache_write_memcopy { my($self, $data, $filename) = @_; require Storable; # We didn't need it until now $MemCopyCache{$filename} = [time(), Storable::dclone($data)]; } ############################################################################## # Method: cache_read_memcopy() # # Takes a filename and looks in a global hash for a cached parsed version. # Returns a reference to a copy of that data structure. # sub cache_read_memcopy { my($self, $filename) = @_; return unless($MemCopyCache{$filename}); return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]); return(Storable::dclone($MemCopyCache{$filename}->[1])); } ############################################################################## # Sub/Method: XMLout() # # Exported routine for 'unslurping' a data structure out to XML. # # Expects a reference to a data structure and an optional list of option # name => value pairs. # sub XMLout { my $self = &_get_object; # note, @_ is passed implicitly croak "XMLout() requires at least one argument" unless(@_); my $ref = shift; $self->handle_options('out', @_); # If namespace expansion is set, XML::NamespaceSupport is required if($self->{opt}->{nsexpand}) { require XML::NamespaceSupport; $self->{nsup} = XML::NamespaceSupport->new(); $self->{ns_prefix} = 'aaa'; } # Wrap top level arrayref in a hash if(UNIVERSAL::isa($ref, 'ARRAY')) { $ref = { anon => $ref }; } # Extract rootname from top level hash if keeproot enabled if($self->{opt}->{keeproot}) { my(@keys) = keys(%$ref); if(@keys == 1) { $ref = $ref->{$keys[0]}; $self->{opt}->{rootname} = $keys[0]; } } # Ensure there are no top level attributes if we're not adding root elements elsif($self->{opt}->{rootname} eq '') { if(UNIVERSAL::isa($ref, 'HASH')) { my $refsave = $ref; $ref = {}; foreach (keys(%$refsave)) { if(ref($refsave->{$_})) { $ref->{$_} = $refsave->{$_}; } else { $ref->{$_} = [ $refsave->{$_} ]; } } } } # Encode the hashref and write to file if necessary $self->{_ancestors} = {}; my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, ''); delete $self->{_ancestors}; if($self->{opt}->{xmldecl}) { $xml = $self->{opt}->{xmldecl} . "\n" . $xml; } if($self->{opt}->{outputfile}) { if(ref($self->{opt}->{outputfile})) { my $fh = $self->{opt}->{outputfile}; if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) { eval { require IO::Handle; }; croak $@ if $@; } return($fh->print($xml)); } else { open(my $out, '>', "$self->{opt}->{outputfile}") || croak "open($self->{opt}->{outputfile}): $!"; binmode($out, ':utf8') if($] >= 5.008); print $out $xml or croak "print: $!"; close $out or croak "close: $!"; } } elsif($self->{opt}->{handler}) { require XML::SAX; my $sp = XML::SAX::ParserFactory->parser( Handler => $self->{opt}->{handler} ); return($sp->parse_string($xml)); } else { return($xml); } } ############################################################################## # Method: handle_options() # # Helper routine for both XMLin() and XMLout(). Both routines handle their # first argument and assume all other args are options handled by this routine. # Saves a hash of options in $self->{opt}. # # If default options were passed to the constructor, they will be retrieved # here and merged with options supplied to the method call. # # First argument should be the string 'in' or the string 'out'. # # Remaining arguments should be name=>value pairs. Sets up default values # for options not supplied. Unrecognised options are a fatal error. # sub handle_options { my $self = shift; my $dirn = shift; # Determine valid options based on context my %known_opt; if($dirn eq 'in') { @known_opt{@KnownOptIn} = @KnownOptIn; } else { @known_opt{@KnownOptOut} = @KnownOptOut; } # Store supplied options in hashref and weed out invalid ones if(@_ % 2) { croak "Options must be name=>value pairs (odd number supplied)"; } my %raw_opt = @_; my $opt = {}; $self->{opt} = $opt; while(my($key, $val) = each %raw_opt) { my $lkey = lc($key); $lkey =~ s/_//g; croak "Unrecognised option: $key" unless($known_opt{$lkey}); $opt->{$lkey} = $val; } # Merge in options passed to constructor foreach (keys(%known_opt)) { unless(exists($opt->{$_})) { if(exists($self->{def_opt}->{$_})) { $opt->{$_} = $self->{def_opt}->{$_}; } } } # Set sensible defaults if not supplied if(exists($opt->{rootname})) { unless(defined($opt->{rootname})) { $opt->{rootname} = ''; } } else { $opt->{rootname} = $DefRootName; } if($opt->{xmldecl} and $opt->{xmldecl} eq '1') { $opt->{xmldecl} = $DefXmlDecl; } if(exists($opt->{contentkey})) { if($opt->{contentkey} =~ m{^-(.*)$}) { $opt->{contentkey} = $1; $opt->{collapseagain} = 1; } } else { $opt->{contentkey} = $DefContentKey; } unless(exists($opt->{normalisespace})) { $opt->{normalisespace} = $opt->{normalizespace}; } $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace})); # Cleanups for values assumed to be arrays later if($opt->{searchpath}) { unless(ref($opt->{searchpath})) { $opt->{searchpath} = [ $opt->{searchpath} ]; } } else { $opt->{searchpath} = [ ]; } if($opt->{cache} and !ref($opt->{cache})) { $opt->{cache} = [ $opt->{cache} ]; } if($opt->{cache}) { $_ = lc($_) foreach (@{$opt->{cache}}); foreach my $scheme (@{$opt->{cache}}) { my $method = 'cache_read_' . $scheme; croak "Unsupported caching scheme: $scheme" unless($self->can($method)); } } if(exists($opt->{parseropts})) { if(warnings::enabled()) { carp "Warning: " . "'ParserOpts' is deprecated, contact the author if you need it"; } } else { $opt->{parseropts} = [ ]; } # Special cleanup for {forcearray} which could be regex, arrayref or boolean # or left to default to 0 if(exists($opt->{forcearray})) { if(ref($opt->{forcearray}) eq 'Regexp') { $opt->{forcearray} = [ $opt->{forcearray} ]; } if(ref($opt->{forcearray}) eq 'ARRAY') { my @force_list = @{$opt->{forcearray}}; if(@force_list) { $opt->{forcearray} = {}; foreach my $tag (@force_list) { if(ref($tag) eq 'Regexp') { push @{$opt->{forcearray}->{_regex}}, $tag; } else { $opt->{forcearray}->{$tag} = 1; } } } else { $opt->{forcearray} = 0; } } else { $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 ); } } else { if($opt->{strictmode} and $dirn eq 'in') { croak "No value specified for 'ForceArray' option in call to XML$dirn()"; } $opt->{forcearray} = 0; } # Special cleanup for {keyattr} which could be arrayref or hashref or left # to default to arrayref if(exists($opt->{keyattr})) { if(ref($opt->{keyattr})) { if(ref($opt->{keyattr}) eq 'HASH') { # Make a copy so we can mess with it $opt->{keyattr} = { %{$opt->{keyattr}} }; # Convert keyattr => { elem => '+attr' } # to keyattr => { elem => [ 'attr', '+' ] } foreach my $el (keys(%{$opt->{keyattr}})) { if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) { $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ]; if($opt->{strictmode} and $dirn eq 'in') { next if($opt->{forcearray} == 1); next if(ref($opt->{forcearray}) eq 'HASH' and $opt->{forcearray}->{$el}); croak "<$el> set in KeyAttr but not in ForceArray"; } } else { delete($opt->{keyattr}->{$el}); # Never reached (famous last words?) } } } else { if(@{$opt->{keyattr}} == 0) { delete($opt->{keyattr}); } } } else { $opt->{keyattr} = [ $opt->{keyattr} ]; } } else { if($opt->{strictmode}) { croak "No value specified for 'KeyAttr' option in call to XML$dirn()"; } $opt->{keyattr} = [ @DefKeyAttr ]; } # Special cleanup for {valueattr} which could be arrayref or hashref if(exists($opt->{valueattr})) { if(ref($opt->{valueattr}) eq 'ARRAY') { $opt->{valueattrlist} = {}; $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} }); } } # make sure there's nothing weird in {grouptags} if($opt->{grouptags}) { croak "Illegal value for 'GroupTags' option - expected a hashref" unless UNIVERSAL::isa($opt->{grouptags}, 'HASH'); while(my($key, $val) = each %{$opt->{grouptags}}) { next if $key ne $val; croak "Bad value in GroupTags: '$key' => '$val'"; } } # Check the {variables} option is valid and initialise variables hash if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) { croak "Illegal value for 'Variables' option - expected a hashref"; } if($opt->{variables}) { $self->{_var_values} = { %{$opt->{variables}} }; } elsif($opt->{varattr}) { $self->{_var_values} = {}; } } ############################################################################## # Method: find_xml_file() # # Helper routine for XMLin(). # Takes a filename, and a list of directories, attempts to locate the file in # the directories listed. # Returns a full pathname on success; croaks on failure. # sub find_xml_file { my $self = shift; my $file = shift; my @search_path = @_; require File::Basename; require File::Spec; my($filename, $filedir) = File::Basename::fileparse($file); if($filename ne $file) { # Ignore searchpath if dir component return($file) if(-e $file); } else { my($path); foreach $path (@search_path) { my $fullpath = File::Spec->catfile($path, $file); return($fullpath) if(-e $fullpath); } } # If user did not supply a search path, default to current directory if(!@search_path) { return($file) if(-e $file); croak "File does not exist: $file"; } croak "Could not find $file in ", join(':', @search_path); } ############################################################################## # Method: collapse() # # Helper routine for XMLin(). This routine really comprises the 'smarts' (or # value add) of this module. # # Takes the parse tree that XML::Parser produced from the supplied XML and # recurses through it 'collapsing' unnecessary levels of indirection (nested # arrays etc) to produce a data structure that is easier to work with. # # Elements in the original parser tree are represented as an element name # followed by an arrayref. The first element of the array is a hashref # containing the attributes. The rest of the array contains a list of any # nested elements as name+arrayref pairs: # # <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ] # # The special element name '0' (zero) flags text content. # # This routine cuts down the noise by discarding any text content consisting of # only whitespace and then moves the nested elements into the attribute hash # using the name of the nested element as the hash key and the collapsed # version of the nested element as the value. Multiple nested elements with # the same name will initially be represented as an arrayref, but this may be # 'folded' into a hashref depending on the value of the keyattr option. # sub collapse { my $self = shift; # Start with the hash of attributes my $attr = shift; if($self->{opt}->{noattr}) { # Discard if 'noattr' set $attr = $self->new_hashref; } elsif($self->{opt}->{normalisespace} == 2) { while(my($key, $value) = each %$attr) { $attr->{$key} = $self->normalise_space($value) } } # Do variable substitutions if(my $var = $self->{_var_values}) { while(my($key, $val) = each(%$attr)) { $val =~ s^\$\{([\w.]+)\}^ $self->get_var($1) ^ge; $attr->{$key} = $val; } } # Roll up 'value' attributes (but only if no nested elements) if(!@_ and keys %$attr == 1) { my($k) = keys %$attr; if($self->{opt}->{valueattrlist} and $self->{opt}->{valueattrlist}->{$k}) { return $attr->{$k}; } } # Add any nested elements my($key, $val); while(@_) { $key = shift; $val = shift; $val = '' if not defined $val; if(ref($val)) { $val = $self->collapse(@$val); next if(!defined($val) and $self->{opt}->{suppressempty}); } elsif($key eq '0') { next if($val =~ m{^\s*$}s); # Skip all whitespace content $val = $self->normalise_space($val) if($self->{opt}->{normalisespace} == 2); # do variable substitutions if(my $var = $self->{_var_values}) { $val =~ s^\$\{(\w+)\}^ $self->get_var($1) ^ge; } # look for variable definitions if(my $var = $self->{opt}->{varattr}) { if(exists $attr->{$var}) { $self->set_var($attr->{$var}, $val); } } # Collapse text content in element with no attributes to a string if(!%$attr and !@_) { return($self->{opt}->{forcecontent} ? { $self->{opt}->{contentkey} => $val } : $val ); } $key = $self->{opt}->{contentkey}; } # Combine duplicate attributes into arrayref if required if(exists($attr->{$key})) { if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) { push(@{$attr->{$key}}, $val); } else { $attr->{$key} = [ $attr->{$key}, $val ]; } } elsif(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) { $attr->{$key} = [ $val ]; } else { if( $key ne $self->{opt}->{contentkey} and ( ($self->{opt}->{forcearray} == 1) or ( (ref($self->{opt}->{forcearray}) eq 'HASH') and ( $self->{opt}->{forcearray}->{$key} or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}}) ) ) ) ) { $attr->{$key} = [ $val ]; } else { $attr->{$key} = $val; } } } # Turn arrayrefs into hashrefs if key fields present if($self->{opt}->{keyattr}) { while(($key,$val) = each %$attr) { if(defined($val) and UNIVERSAL::isa($val, 'ARRAY')) { $attr->{$key} = $self->array_to_hash($key, $val); } } } # disintermediate grouped tags if($self->{opt}->{grouptags}) { while(my($key, $val) = each(%$attr)) { next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1)); next unless(exists($self->{opt}->{grouptags}->{$key})); my($child_key, $child_val) = %$val; if($self->{opt}->{grouptags}->{$key} eq $child_key) { $attr->{$key}= $child_val; } } } # Fold hashes containing a single anonymous array up into just the array my $count = scalar keys %$attr; if($count == 1 and exists $attr->{anon} and UNIVERSAL::isa($attr->{anon}, 'ARRAY') ) { return($attr->{anon}); } # Do the right thing if hash is empty, otherwise just return it if(!%$attr and exists($self->{opt}->{suppressempty})) { if(defined($self->{opt}->{suppressempty}) and $self->{opt}->{suppressempty} eq '') { return(''); } return(undef); } # Roll up named elements with named nested 'value' attributes if($self->{opt}->{valueattr}) { while(my($key, $val) = each(%$attr)) { next unless($self->{opt}->{valueattr}->{$key}); next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1)); my($k) = keys %$val; next unless($k eq $self->{opt}->{valueattr}->{$key}); $attr->{$key} = $val->{$k}; } } return($attr) } ############################################################################## # Method: set_var() # # Called when a variable definition is encountered in the XML. (A variable # definition looks like <element attrname="name">value</element> where attrname # matches the varattr setting). # sub set_var { my($self, $name, $value) = @_; $self->{_var_values}->{$name} = $value; } ############################################################################## # Method: get_var() # # Called during variable substitution to get the value for the named variable. # sub get_var { my($self, $name) = @_; my $value = $self->{_var_values}->{$name}; return $value if(defined($value)); return '${' . $name . '}'; } ############################################################################## # Method: normalise_space() # # Strips leading and trailing whitespace and collapses sequences of whitespace # characters to a single space. # sub normalise_space { my($self, $text) = @_; $text =~ s/^\s+//s; $text =~ s/\s+$//s; $text =~ s/\s\s+/ /sg; return $text; } ############################################################################## # Method: array_to_hash() # # Helper routine for collapse(). # Attempts to 'fold' an array of hashes into an hash of hashes. Returns a # reference to the hash on success or the original array if folding is # not possible. Behaviour is controlled by 'keyattr' option. # sub array_to_hash { my $self = shift; my $name = shift; my $arrayref = shift; my $hashref = $self->new_hashref; my($i, $key, $val, $flag); # Handle keyattr => { .... } if(ref($self->{opt}->{keyattr}) eq 'HASH') { return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name})); ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}}; for($i = 0; $i < @$arrayref; $i++) { if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and exists($arrayref->[$i]->{$key}) ) { $val = $arrayref->[$i]->{$key}; if(ref($val)) { $self->die_or_warn("<$name> element has non-scalar '$key' key attribute"); return($arrayref); } $val = $self->normalise_space($val) if($self->{opt}->{normalisespace} == 1); $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val") if(exists($hashref->{$val})); $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} ); $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-'); delete $hashref->{$val}->{$key} unless($flag eq '+'); } else { $self->die_or_warn("<$name> element has no '$key' key attribute"); return($arrayref); } } } # Or assume keyattr => [ .... ] else { my $default_keys = join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}}); ELEMENT: for($i = 0; $i < @$arrayref; $i++) { return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH')); foreach $key (@{$self->{opt}->{keyattr}}) { if(defined($arrayref->[$i]->{$key})) { $val = $arrayref->[$i]->{$key}; if(ref($val)) { $self->die_or_warn("<$name> element has non-scalar '$key' key attribute") if not $default_keys; return($arrayref); } $val = $self->normalise_space($val) if($self->{opt}->{normalisespace} == 1); $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val") if(exists($hashref->{$val})); $hashref->{$val} = $self->new_hashref( %{$arrayref->[$i]} ); delete $hashref->{$val}->{$key}; next ELEMENT; } } return($arrayref); # No keyfield matched } } # collapse any hashes which now only have a 'content' key if($self->{opt}->{collapseagain}) { $hashref = $self->collapse_content($hashref); } return($hashref); } ############################################################################## # Method: die_or_warn() # # Takes a diagnostic message and does one of three things: # 1. dies if strict mode is enabled # 2. warns if warnings are enabled but strict mode is not # 3. ignores message and returns silently if neither strict mode nor warnings # are enabled # sub die_or_warn { my $self = shift; my $msg = shift; croak $msg if($self->{opt}->{strictmode}); if(warnings::enabled()) { carp "Warning: $msg"; } } ############################################################################## # Method: new_hashref() # # This is a hook routine for overriding in a sub-class. Some people believe # that using Tie::IxHash here will solve order-loss problems. # sub new_hashref { my $self = shift; return { @_ }; } ############################################################################## # Method: collapse_content() # # Helper routine for array_to_hash # # Arguments expected are: # - an XML::Simple object # - a hashref # the hashref is a former array, turned into a hash by array_to_hash because # of the presence of key attributes # at this point collapse_content avoids over-complicated structures like # dir => { libexecdir => { content => '$exec_prefix/libexec' }, # localstatedir => { content => '$prefix' }, # } # into # dir => { libexecdir => '$exec_prefix/libexec', # localstatedir => '$prefix', # } sub collapse_content { my $self = shift; my $hashref = shift; my $contentkey = $self->{opt}->{contentkey}; # first go through the values,checking that they are fit to collapse foreach my $val (values %$hashref) { return $hashref unless ( (ref($val) eq 'HASH') and (keys %$val == 1) and (exists $val->{$contentkey}) ); } # now collapse them foreach my $key (keys %$hashref) { $hashref->{$key}= $hashref->{$key}->{$contentkey}; } return $hashref; } ############################################################################## # Method: value_to_xml() # # Helper routine for XMLout() - recurses through a data structure building up # and returning an XML representation of that structure as a string. # # Arguments expected are: # - the data structure to be encoded (usually a reference) # - the XML tag name to use for this item # - a string of spaces for use as the current indent level # sub value_to_xml { my $self = shift;; # Grab the other arguments my($ref, $name, $indent) = @_; my $named = (defined($name) and $name ne '' ? 1 : 0); my $nl = "\n"; my $is_root = $indent eq '' ? 1 : 0; # Warning, dirty hack! if($self->{opt}->{noindent}) { $indent = ''; $nl = ''; } # Convert to XML my $refaddr = Scalar::Util::refaddr($ref); if($refaddr) { croak "circular data structures not supported" if $self->{_ancestors}->{$refaddr}; $self->{_ancestors}->{$refaddr} = $ref; # keep ref alive until we delete it } else { if($named) { return(join('', $indent, '<', $name, '>', ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)), '</', $name, ">", $nl )); } else { return("$ref$nl"); } } # Unfold hash to array if possible if(UNIVERSAL::isa($ref, 'HASH') # It is a hash and keys %$ref # and it's not empty and $self->{opt}->{keyattr} # and folding is enabled and !$is_root # and its not the root element ) { $ref = $self->hash_to_array($name, $ref); } my @result = (); my($key, $value); # Handle hashrefs if(UNIVERSAL::isa($ref, 'HASH')) { # Reintermediate grouped values if applicable if($self->{opt}->{grouptags}) { $ref = $self->copy_hash($ref); while(my($key, $val) = each %$ref) { if($self->{opt}->{grouptags}->{$key}) { $ref->{$key} = $self->new_hashref( $self->{opt}->{grouptags}->{$key} => $val ); } } } # Scan for namespace declaration attributes my $nsdecls = ''; my $default_ns_uri; if($self->{nsup}) { $ref = $self->copy_hash($ref); $self->{nsup}->push_context(); # Look for default namespace declaration first if(exists($ref->{xmlns})) { $self->{nsup}->declare_prefix('', $ref->{xmlns}); $nsdecls .= qq( xmlns="$ref->{xmlns}"); delete($ref->{xmlns}); } $default_ns_uri = $self->{nsup}->get_uri(''); # Then check all the other keys foreach my $qname (keys(%$ref)) { my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname); if($uri) { if($uri eq $xmlns_ns) { $self->{nsup}->declare_prefix($lname, $ref->{$qname}); $nsdecls .= qq( xmlns:$lname="$ref->{$qname}"); delete($ref->{$qname}); } } } # Translate any remaining Clarkian names foreach my $qname (keys(%$ref)) { my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname); if($uri) { if($default_ns_uri and $uri eq $default_ns_uri) { $ref->{$lname} = $ref->{$qname}; delete($ref->{$qname}); } else { my $prefix = $self->{nsup}->get_prefix($uri); unless($prefix) { # $self->{nsup}->declare_prefix(undef, $uri); # $prefix = $self->{nsup}->get_prefix($uri); $prefix = $self->{ns_prefix}++; $self->{nsup}->declare_prefix($prefix, $uri); $nsdecls .= qq( xmlns:$prefix="$uri"); } $ref->{"$prefix:$lname"} = $ref->{$qname}; delete($ref->{$qname}); } } } } my @nested = (); my $text_content = undef; if($named) { push @result, $indent, '<', $name, $nsdecls; } if(keys %$ref) { my $first_arg = 1; foreach my $key ($self->sorted_keys($name, $ref)) { my $value = $ref->{$key}; next if(substr($key, 0, 1) eq '-'); if(!defined($value)) { next if $self->{opt}->{suppressempty}; unless(exists($self->{opt}->{suppressempty}) and !defined($self->{opt}->{suppressempty}) ) { carp 'Use of uninitialized value' if warnings::enabled(); } if($key eq $self->{opt}->{contentkey}) { $text_content = ''; } else { $value = exists($self->{opt}->{suppressempty}) ? {} : ''; } } if(!ref($value) and $self->{opt}->{valueattr} and $self->{opt}->{valueattr}->{$key} ) { $value = $self->new_hashref( $self->{opt}->{valueattr}->{$key} => $value ); } if(ref($value) or $self->{opt}->{noattr}) { push @nested, $self->value_to_xml($value, $key, "$indent "); } else { if($key eq $self->{opt}->{contentkey}) { $value = $self->escape_value($value) unless($self->{opt}->{noescape}); $text_content = $value; } else { $value = $self->escape_attr($value) unless($self->{opt}->{noescape}); push @result, "\n$indent " . ' ' x length($name) if($self->{opt}->{attrindent} and !$first_arg); push @result, ' ', $key, '="', $value , '"'; $first_arg = 0; } } } } else { $text_content = ''; } if(@nested or defined($text_content)) { if($named) { push @result, ">"; if(defined($text_content)) { push @result, $text_content; $nested[0] =~ s/^\s+// if(@nested); } else { push @result, $nl; } if(@nested) { push @result, @nested, $indent; } push @result, '</', $name, ">", $nl; } else { push @result, @nested; # Special case if no root elements } } else { push @result, " />", $nl; } $self->{nsup}->pop_context() if($self->{nsup}); } # Handle arrayrefs elsif(UNIVERSAL::isa($ref, 'ARRAY')) { foreach $value (@$ref) { next if !defined($value) and $self->{opt}->{suppressempty}; if(!ref($value)) { push @result, $indent, '<', $name, '>', ($self->{opt}->{noescape} ? $value : $self->escape_value($value)), '</', $name, ">$nl"; } elsif(UNIVERSAL::isa($value, 'HASH')) { push @result, $self->value_to_xml($value, $name, $indent); } else { push @result, $indent, '<', $name, ">$nl", $self->value_to_xml($value, 'anon', "$indent "), $indent, '</', $name, ">$nl"; } } } else { croak "Can't encode a value of type: " . ref($ref); } delete $self->{_ancestors}->{$refaddr}; return(join('', @result)); } ############################################################################## # Method: sorted_keys() # # Returns the keys of the referenced hash sorted into alphabetical order, but # with the 'key' key (as in KeyAttr) first, if there is one. # sub sorted_keys { my($self, $name, $ref) = @_; return keys %$ref if $self->{opt}->{nosort}; my %hash = %$ref; my $keyattr = $self->{opt}->{keyattr}; my @key; if(ref $keyattr eq 'HASH') { if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) { push @key, $keyattr->{$name}->[0]; delete $hash{$keyattr->{$name}->[0]}; } } elsif(ref $keyattr eq 'ARRAY') { foreach (@{$keyattr}) { if(exists $hash{$_}) { push @key, $_; delete $hash{$_}; last; } } } return(@key, sort keys %hash); } ############################################################################## # Method: escape_value() # # Helper routine for automatically escaping values for XMLout(). # Expects a scalar data value. Returns escaped version. # sub escape_value { my($self, $data) = @_; return '' unless(defined($data)); $data =~ s/&/&/sg; $data =~ s/</</sg; $data =~ s/>/>/sg; $data =~ s/"/"/sg; my $level = $self->{opt}->{numericescape} or return $data; return $self->numeric_escape($data, $level); } sub numeric_escape { my($self, $data, $level) = @_; if($self->{opt}->{numericescape} eq '2') { $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse; } else { $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse; } return $data; } ############################################################################## # Method: escape_attr() # # Helper routine for escaping attribute values. Defaults to escape_value(), # but may be overridden by a subclass to customise behaviour. # sub escape_attr { my $self = shift; return $self->escape_value(@_); } ############################################################################## # Method: hash_to_array() # # Helper routine for value_to_xml(). # Attempts to 'unfold' a hash of hashes into an array of hashes. Returns a # reference to the array on success or the original hash if unfolding is # not possible. # sub hash_to_array { my $self = shift; my $parent = shift; my $hashref = shift; my $arrayref = []; my($key, $value); my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref; foreach $key (@keys) { $value = $hashref->{$key}; return($hashref) unless(UNIVERSAL::isa($value, 'HASH')); if(ref($self->{opt}->{keyattr}) eq 'HASH') { return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent})); push @$arrayref, $self->copy_hash( $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key ); } else { push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value }); } } return($arrayref); } ############################################################################## # Method: copy_hash() # # Helper routine for hash_to_array(). When unfolding a hash of hashes into # an array of hashes, we need to copy the key from the outer hash into the # inner hash. This routine makes a copy of the original hash so we don't # destroy the original data structure. You might wish to override this # method if you're using tied hashes and don't want them to get untied. # sub copy_hash { my($self, $orig, @extra) = @_; return { @extra, %$orig }; } ############################################################################## # Methods required for building trees from SAX events ############################################################################## sub start_document { my $self = shift; $self->handle_options('in') unless($self->{opt}); $self->{lists} = []; $self->{curlist} = $self->{tree} = []; } sub start_element { my $self = shift; my $element = shift; my $name = $element->{Name}; if($self->{opt}->{nsexpand}) { $name = $element->{LocalName} || ''; if($element->{NamespaceURI}) { $name = '{' . $element->{NamespaceURI} . '}' . $name; } } my $attributes = {}; if($element->{Attributes}) { # Might be undef foreach my $attr (values %{$element->{Attributes}}) { if($self->{opt}->{nsexpand}) { my $name = $attr->{LocalName} || ''; if($attr->{NamespaceURI}) { $name = '{' . $attr->{NamespaceURI} . '}' . $name } $name = 'xmlns' if($name eq $bad_def_ns_jcn); $attributes->{$name} = $attr->{Value}; } else { $attributes->{$attr->{Name}} = $attr->{Value}; } } } my $newlist = [ $attributes ]; push @{ $self->{lists} }, $self->{curlist}; push @{ $self->{curlist} }, $name => $newlist; $self->{curlist} = $newlist; } sub characters { my $self = shift; my $chars = shift; my $text = $chars->{Data}; my $clist = $self->{curlist}; my $pos = $#$clist; if ($pos > 0 and $clist->[$pos - 1] eq '0') { $clist->[$pos] .= $text; } else { push @$clist, 0 => $text; } } sub end_element { my $self = shift; $self->{curlist} = pop @{ $self->{lists} }; } sub end_document { my $self = shift; delete($self->{curlist}); delete($self->{lists}); my $tree = $self->{tree}; delete($self->{tree}); # Return tree as-is to XMLin() return($tree) if($self->{nocollapse}); # Or collapse it before returning it to SAX parser class if($self->{opt}->{keeproot}) { $tree = $self->collapse({}, @$tree); } else { $tree = $self->collapse(@{$tree->[1]}); } if($self->{opt}->{datahandler}) { return($self->{opt}->{datahandler}->($self, $tree)); } return($tree); } *xml_in = \&XMLin; *xml_out = \&XMLout; 1; __END__ =head1 STATUS OF THIS MODULE The use of this module in new code is B<strongly discouraged>. Other modules are available which provide more straightforward and consistent interfaces. In particular, L<XML::LibXML> is highly recommended and you can refer to L<Perl XML::LibXML by Example|http://grantm.github.io/perl-libxml-by-example/> for a tutorial introduction. L<XML::Twig> is another excellent alternative. The major problems with this module are the large number of options (some of which have unfortunate defaults) and the arbitrary ways in which these options interact - often producing unexpected results. Patches with bug fixes and documentation fixes are welcome, but new features are unlikely to be added. =head1 QUICK START Say you have a script called B<foo> and a file of configuration options called B<foo.xml> containing the following: <config logdir="/var/log/foo/" debugfile="/tmp/foo.debug"> <server name="sahara" osname="solaris" osversion="2.6"> <address>10.0.0.101</address> <address>10.0.1.101</address> </server> <server name="gobi" osname="irix" osversion="6.5"> <address>10.0.0.102</address> </server> <server name="kalahari" osname="linux" osversion="2.0.34"> <address>10.0.0.103</address> <address>10.0.1.103</address> </server> </config> The following lines of code in B<foo>: use XML::Simple qw(:strict); my $config = XMLin(undef, KeyAttr => { server => 'name' }, ForceArray => [ 'server', 'address' ]); will 'slurp' the configuration options into the hashref $config (because no filename or XML string was passed as the first argument to C<XMLin()> the name and location of the XML file will be inferred from name and location of the script). You can dump out the contents of the hashref using Data::Dumper: use Data::Dumper; print Dumper($config); which will produce something like this (formatting has been adjusted for brevity): { 'logdir' => '/var/log/foo/', 'debugfile' => '/tmp/foo.debug', 'server' => { 'sahara' => { 'osversion' => '2.6', 'osname' => 'solaris', 'address' => [ '10.0.0.101', '10.0.1.101' ] }, 'gobi' => { 'osversion' => '6.5', 'osname' => 'irix', 'address' => [ '10.0.0.102' ] }, 'kalahari' => { 'osversion' => '2.0.34', 'osname' => 'linux', 'address' => [ '10.0.0.103', '10.0.1.103' ] } } } Your script could then access the name of the log directory like this: print $config->{logdir}; similarly, the second address on the server 'kalahari' could be referenced as: print $config->{server}->{kalahari}->{address}->[1]; Note: If the mapping between the output of Data::Dumper and the print statements above is not obvious to you, then please refer to the 'references' tutorial (AKA: "Mark's very short tutorial about references") at L<perlreftut>. In this example, the C<< ForceArray >> option was used to list elements that might occur multiple times and should therefore be represented as arrayrefs (even when only one element is present). The C<< KeyAttr >> option was used to indicate that each C<< <server> >> element has a unique identifier in the C<< name >> attribute. This allows you to index directly to a particular server record using the name as a hash key (as shown above). For simple requirements, that's really all there is to it. If you want to store your XML in a different directory or file, or pass it in as a string or even pass it in via some derivative of an IO::Handle, you'll need to check out L<"OPTIONS">. If you want to turn off or tweak the array folding feature (that neat little transformation that produced $config->{server}) you'll find options for that as well. If you want to generate XML (for example to write a modified version of $config back out as XML), check out C<XMLout()>. If your needs are not so simple, this may not be the module for you. In that case, you might want to read L<"WHERE TO FROM HERE?">. =head1 DESCRIPTION The XML::Simple module provides a simple API layer on top of an underlying XML parsing module (either XML::Parser or one of the SAX2 parser modules). Two functions are exported: C<XMLin()> and C<XMLout()>. Note: you can explicitly request the lower case versions of the function names: C<xml_in()> and C<xml_out()>. The simplest approach is to call these two functions directly, but an optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below) allows them to be called as methods of an B<XML::Simple> object. The object interface can also be used at either end of a SAX pipeline. =head2 XMLin() Parses XML formatted data and returns a reference to a data structure which contains the same information in a more readily accessible form. (Skip down to L<"EXAMPLES"> below, for more sample code). C<XMLin()> accepts an optional XML specifier followed by zero or more 'name => value' option pairs. The XML specifier can be one of the following: =over 4 =item A filename If the filename contains no directory components C<XMLin()> will look for the file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the current directory if the SearchPath option is not defined. eg: $ref = XMLin('/etc/params.xml'); Note, the filename '-' can be used to parse from STDIN. =item undef If there is no XML specifier, C<XMLin()> will check the script directory and each of the SearchPath directories for a file with the same name as the script but with the extension '.xml'. Note: if you wish to specify options, you must specify the value 'undef'. eg: $ref = XMLin(undef, ForceArray => 1); =item A string of XML A string containing XML (recognised by the presence of '<' and '>' characters) will be parsed directly. eg: $ref = XMLin('<opt username="bob" password="flurp" />'); =item An IO::Handle object An IO::Handle object will be read to EOF and its contents parsed. eg: $fh = IO::File->new('/etc/params.xml'); $ref = XMLin($fh); =back =head2 XMLout() Takes a data structure (generally a hashref) and returns an XML encoding of that structure. If the resulting XML is parsed using C<XMLin()>, it should return a data structure equivalent to the original (see caveats below). The C<XMLout()> function can also be used to output the XML as SAX events see the C<Handler> option and L<"SAX SUPPORT"> for more details). When translating hashes to XML, hash keys which have a leading '-' will be silently skipped. This is the approved method for marking elements of a data structure which should be ignored by C<XMLout>. (Note: If these items were not skipped the key names would be emitted as element or attribute names with a leading '-' which would not be valid XML). =head2 Caveats Some care is required in creating data structures which will be passed to C<XMLout()>. Hash keys from the data structure will be encoded as either XML element names or attribute names. Therefore, you should use hash key names which conform to the relatively strict XML naming rules: Names in XML must begin with a letter. The remaining characters may be letters, digits, hyphens (-), underscores (_) or full stops (.). It is also allowable to include one colon (:) in an element name but this should only be used when working with namespaces (B<XML::Simple> can only usefully work with namespaces when teamed with a SAX Parser). You can use other punctuation characters in hash values (just not in hash keys) however B<XML::Simple> does not support dumping binary data. If you break these rules, the current implementation of C<XMLout()> will simply emit non-compliant XML which will be rejected if you try to read it back in. (A later version of B<XML::Simple> might take a more proactive approach). Note also that although you can nest hashes and arrays to arbitrary levels, circular data structures are not supported and will cause C<XMLout()> to die. If you wish to 'round-trip' arbitrary data structures from Perl to XML and back to Perl, then you should probably disable array folding (using the KeyAttr option) both with C<XMLout()> and with C<XMLin()>. If you still don't get the expected results, you may prefer to use L<XML::Dumper> which is designed for exactly that purpose. Refer to L<"WHERE TO FROM HERE?"> if C<XMLout()> is too simple for your needs. =head1 OPTIONS B<XML::Simple> supports a number of options (in fact as each release of B<XML::Simple> adds more options, the module's claim to the name 'Simple' becomes increasingly tenuous). If you find yourself repeatedly having to specify the same options, you might like to investigate L<"OPTIONAL OO INTERFACE"> below. If you can't be bothered reading the documentation, refer to L<"STRICT MODE"> to automatically catch common mistakes. Because there are so many options, it's hard for new users to know which ones are important, so here are the two you really need to know about: =over 4 =item * check out C<ForceArray> because you'll almost certainly want to turn it on =item * make sure you know what the C<KeyAttr> option does and what its default value is because it may surprise you otherwise (note in particular that 'KeyAttr' affects both C<XMLin> and C<XMLout>) =back The option name headings below have a trailing 'comment' - a hash followed by two pieces of metadata: =over 4 =item * Options are marked with 'I<in>' if they are recognised by C<XMLin()> and 'I<out>' if they are recognised by C<XMLout()>. =item * Each option is also flagged to indicate whether it is: 'important' - don't use the module until you understand this one 'handy' - you can skip this on the first time through 'advanced' - you can skip this on the second time through 'SAX only' - don't worry about this unless you're using SAX (or alternatively if you need this, you also need SAX) 'seldom used' - you'll probably never use this unless you were the person that requested the feature =back The options are listed alphabetically: Note: option names are no longer case sensitive so you can use the mixed case versions shown here; all lower case as required by versions 2.03 and earlier; or you can add underscores between the words (eg: key_attr). =head2 AttrIndent => 1 I<# out - handy> When you are using C<XMLout()>, enable this option to have attributes printed one-per-line with sensible indentation rather than all on one line. =head2 Cache => [ cache schemes ] I<# in - advanced> Because loading the B<XML::Parser> module and parsing an XML file can consume a significant number of CPU cycles, it is often desirable to cache the output of C<XMLin()> for later reuse. When parsing from a named file, B<XML::Simple> supports a number of caching schemes. The 'Cache' option may be used to specify one or more schemes (using an anonymous array). Each scheme will be tried in turn in the hope of finding a cached pre-parsed representation of the XML file. If no cached copy is found, the file will be parsed and the first cache scheme in the list will be used to save a copy of the results. The following cache schemes have been implemented: =over 4 =item storable Utilises B<Storable.pm> to read/write a cache file with the same name as the XML file but with the extension .stor =item memshare When a file is first parsed, a copy of the resulting data structure is retained in memory in the B<XML::Simple> module's namespace. Subsequent calls to parse the same file will return a reference to this structure. This cached version will persist only for the life of the Perl interpreter (which in the case of mod_perl for example, may be some significant time). Because each caller receives a reference to the same data structure, a change made by one caller will be visible to all. For this reason, the reference returned should be treated as read-only. =item memcopy This scheme works identically to 'memshare' (above) except that each caller receives a reference to a new data structure which is a copy of the cached version. Copying the data structure will add a little processing overhead, therefore this scheme should only be used where the caller intends to modify the data structure (or wishes to protect itself from others who might). This scheme uses B<Storable.pm> to perform the copy. =back Warning! The memory-based caching schemes compare the timestamp on the file to the time when it was last parsed. If the file is stored on an NFS filesystem (or other network share) and the clock on the file server is not exactly synchronised with the clock where your script is run, updates to the source XML file may appear to be ignored. =head2 ContentKey => 'keyname' I<# in+out - seldom used> When text content is parsed to a hash value, this option lets you specify a name for the hash key to override the default 'content'. So for example: XMLin('<opt one="1">Text</opt>', ContentKey => 'text') will parse to: { 'one' => 1, 'text' => 'Text' } instead of: { 'one' => 1, 'content' => 'Text' } C<XMLout()> will also honour the value of this option when converting a hashref to XML. You can also prefix your selected key name with a '-' character to have C<XMLin()> try a little harder to eliminate unnecessary 'content' keys after array folding. For example: XMLin( '<opt><item name="one">First</item><item name="two">Second</item></opt>', KeyAttr => {item => 'name'}, ForceArray => [ 'item' ], ContentKey => '-content' ) will parse to: { 'item' => { 'one' => 'First' 'two' => 'Second' } } rather than this (without the '-'): { 'item' => { 'one' => { 'content' => 'First' } 'two' => { 'content' => 'Second' } } } =head2 DataHandler => code_ref I<# in - SAX only> When you use an B<XML::Simple> object as a SAX handler, it will return a 'simple tree' data structure in the same format as C<XMLin()> would return. If this option is set (to a subroutine reference), then when the tree is built the subroutine will be called and passed two arguments: a reference to the B<XML::Simple> object and a reference to the data tree. The return value from the subroutine will be returned to the SAX driver. (See L<"SAX SUPPORT"> for more details). =head2 ForceArray => 1 I<# in - important> This option should be set to '1' to force nested elements to be represented as arrays even when there is only one. Eg, with ForceArray enabled, this XML: <opt> <name>value</name> </opt> would parse to this: { 'name' => [ 'value' ] } instead of this (the default): { 'name' => 'value' } This option is especially useful if the data structure is likely to be written back out as XML and the default behaviour of rolling single nested elements up into attributes is not desirable. If you are using the array folding feature, you should almost certainly enable this option. If you do not, single nested elements will not be parsed to arrays and therefore will not be candidates for folding to a hash. (Given that the default value of 'KeyAttr' enables array folding, the default value of this option should probably also have been enabled too - sorry). =head2 ForceArray => [ names ] I<# in - important> This alternative (and preferred) form of the 'ForceArray' option allows you to specify a list of element names which should always be forced into an array representation, rather than the 'all or nothing' approach above. It is also possible (since version 2.05) to include compiled regular expressions in the list - any element names which match the pattern will be forced to arrays. If the list contains only a single regex, then it is not necessary to enclose it in an arrayref. Eg: ForceArray => qr/_list$/ =head2 ForceContent => 1 I<# in - seldom used> When C<XMLin()> parses elements which have text content as well as attributes, the text content must be represented as a hash value rather than a simple scalar. This option allows you to force text content to always parse to a hash value even when there are no attributes. So for example: XMLin('<opt><x>text1</x><y a="2">text2</y></opt>', ForceContent => 1) will parse to: { 'x' => { 'content' => 'text1' }, 'y' => { 'a' => 2, 'content' => 'text2' } } instead of: { 'x' => 'text1', 'y' => { 'a' => 2, 'content' => 'text2' } } =head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy> You can use this option to eliminate extra levels of indirection in your Perl data structure. For example this XML: <opt> <searchpath> <dir>/usr/bin</dir> <dir>/usr/local/bin</dir> <dir>/usr/X11/bin</dir> </searchpath> </opt> Would normally be read into a structure like this: { searchpath => { dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ] } } But when read in with the appropriate value for 'GroupTags': my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' }); It will return this simpler structure: { searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ] } The grouping element (C<< <searchpath> >> in the example) must not contain any attributes or elements other than the grouped element. You can specify multiple 'grouping element' to 'grouped element' mappings in the same hashref. If this option is combined with C<KeyAttr>, the array folding will occur first and then the grouped element names will be eliminated. C<XMLout> will also use the grouptag mappings to re-introduce the tags around the grouped elements. Beware though that this will occur in all places that the 'grouping tag' name occurs - you probably don't want to use the same name for elements as well as attributes. =head2 Handler => object_ref I<# out - SAX only> Use the 'Handler' option to have C<XMLout()> generate SAX events rather than returning a string of XML. For more details see L<"SAX SUPPORT"> below. Note: the current implementation of this option generates a string of XML and uses a SAX parser to translate it into SAX events. The normal encoding rules apply here - your data must be UTF8 encoded unless you specify an alternative encoding via the 'XMLDecl' option; and by the time the data reaches the handler object, it will be in UTF8 form regardless of the encoding you supply. A future implementation of this option may generate the events directly. =head2 KeepRoot => 1 I<# in+out - handy> In its attempt to return a data structure free of superfluous detail and unnecessary levels of indirection, C<XMLin()> normally discards the root element name. Setting the 'KeepRoot' option to '1' will cause the root element name to be retained. So after executing this code: $config = XMLin('<config tempdir="/tmp" />', KeepRoot => 1) You'll be able to reference the tempdir as C<$config-E<gt>{config}-E<gt>{tempdir}> instead of the default C<$config-E<gt>{tempdir}>. Similarly, setting the 'KeepRoot' option to '1' will tell C<XMLout()> that the data structure already contains a root element name and it is not necessary to add another. =head2 KeyAttr => [ list ] I<# in+out - important> This option controls the 'array folding' feature which translates nested elements from an array to a hash. It also controls the 'unfolding' of hashes to arrays. For example, this XML: <opt> <user login="grep" fullname="Gary R Epstein" /> <user login="stty" fullname="Simon T Tyson" /> </opt> would, by default, parse to this: { 'user' => [ { 'login' => 'grep', 'fullname' => 'Gary R Epstein' }, { 'login' => 'stty', 'fullname' => 'Simon T Tyson' } ] } If the option 'KeyAttr => "login"' were used to specify that the 'login' attribute is a key, the same XML would parse to: { 'user' => { 'stty' => { 'fullname' => 'Simon T Tyson' }, 'grep' => { 'fullname' => 'Gary R Epstein' } } } The key attribute names should be supplied in an arrayref if there is more than one. C<XMLin()> will attempt to match attribute names in the order supplied. C<XMLout()> will use the first attribute name supplied when 'unfolding' a hash into an array. Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id']. If you do not want folding on input or unfolding on output you must set this option to an empty list to disable the feature. Note 2: If you wish to use this option, you should also enable the C<ForceArray> option. Without 'ForceArray', a single nested element will be rolled up into a scalar rather than an array and therefore will not be folded (since only arrays get folded). =head2 KeyAttr => { list } I<# in+out - important> This alternative (and preferred) method of specifying the key attributes allows more fine grained control over which elements are folded and on which attributes. For example the option 'KeyAttr => { package => 'id' } will cause any package elements to be folded on the 'id' attribute. No other elements which have an 'id' attribute will be folded at all. Note: C<XMLin()> will generate a warning (or a fatal error in L<"STRICT MODE">) if this syntax is used and an element which does not have the specified key attribute is encountered (eg: a 'package' element without an 'id' attribute, to use the example above). Warnings can be suppressed with the lexical C<no warnings;> pragma or C<no warnings 'XML::Simple';>. Two further variations are made possible by prefixing a '+' or a '-' character to the attribute name: The option 'KeyAttr => { user => "+login" }' will cause this XML: <opt> <user login="grep" fullname="Gary R Epstein" /> <user login="stty" fullname="Simon T Tyson" /> </opt> to parse to this data structure: { 'user' => { 'stty' => { 'fullname' => 'Simon T Tyson', 'login' => 'stty' }, 'grep' => { 'fullname' => 'Gary R Epstein', 'login' => 'grep' } } } The '+' indicates that the value of the key attribute should be copied rather than moved to the folded hash key. A '-' prefix would produce this result: { 'user' => { 'stty' => { 'fullname' => 'Simon T Tyson', '-login' => 'stty' }, 'grep' => { 'fullname' => 'Gary R Epstein', '-login' => 'grep' } } } As described earlier, C<XMLout> will ignore hash keys starting with a '-'. =head2 NoAttr => 1 I<# in+out - handy> When used with C<XMLout()>, the generated XML will contain no attributes. All hash key/values will be represented as nested elements instead. When used with C<XMLin()>, any attributes in the XML will be ignored. =head2 NoEscape => 1 I<# out - seldom used> By default, C<XMLout()> will translate the characters 'E<lt>', 'E<gt>', '&' and '"' to '<', '>', '&' and '"' respectively. Use this option to suppress escaping (presumably because you've already escaped the data in some more sophisticated manner). =head2 NoIndent => 1 I<# out - seldom used> Set this option to 1 to disable C<XMLout()>'s default 'pretty printing' mode. With this option enabled, the XML output will all be on one line (unless there are newlines in the data) - this may be easier for downstream processing. =head2 NoSort => 1 I<# out - seldom used> Newer versions of XML::Simple sort elements and attributes alphabetically (*), by default. Enable this option to suppress the sorting - possibly for backwards compatibility. * Actually, sorting is alphabetical but 'key' attribute or element names (as in 'KeyAttr') sort first. Also, when a hash of hashes is 'unfolded', the elements are sorted alphabetically by the value of the key field. =head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy> This option controls how whitespace in text content is handled. Recognised values for the option are: =over 4 =item * 0 = (default) whitespace is passed through unaltered (except of course for the normalisation of whitespace in attribute values which is mandated by the XML recommendation) =item * 1 = whitespace is normalised in any value used as a hash key (normalising means removing leading and trailing whitespace and collapsing sequences of whitespace characters to a single space) =item * 2 = whitespace is normalised in all text content =back Note: you can spell this option with a 'z' if that is more natural for you. =head2 NSExpand => 1 I<# in+out handy - SAX only> This option controls namespace expansion - the translation of element and attribute names of the form 'prefix:name' to '{uri}name'. For example the element name 'xsl:template' might be expanded to: '{http://www.w3.org/1999/XSL/Transform}template'. By default, C<XMLin()> will return element names and attribute names exactly as they appear in the XML. Setting this option to 1 will cause all element and attribute names to be expanded to include their namespace prefix. I<Note: You must be using a SAX parser for this option to work (ie: it does not work with XML::Parser)>. This option also controls whether C<XMLout()> performs the reverse translation from '{uri}name' back to 'prefix:name'. The default is no translation. If your data contains expanded names, you should set this option to 1 otherwise C<XMLout> will emit XML which is not well formed. I<Note: You must have the XML::NamespaceSupport module installed if you want C<XMLout()> to translate URIs back to prefixes>. =head2 NumericEscape => 0 | 1 | 2 I<# out - handy> Use this option to have 'high' (non-ASCII) characters in your Perl data structure converted to numeric entities (eg: €) in the XML output. Three levels are possible: 0 - default: no numeric escaping (OK if you're writing out UTF8) 1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output 2 - all characters above 0x7F are escaped (good for plain ASCII output) =head2 OutputFile => <file specifier> I<# out - handy> The default behaviour of C<XMLout()> is to return the XML as a string. If you wish to write the XML to a file, simply supply the filename using the 'OutputFile' option. This option also accepts an IO handle object - especially useful in Perl 5.8.0 and later for output using an encoding other than UTF-8, eg: open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!"; XMLout($ref, OutputFile => $fh); Note, XML::Simple does not require that the object you pass in to the OutputFile option inherits from L<IO::Handle> - it simply assumes the object supports a C<print> method. =head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this> I<Note: This option is now officially deprecated. If you find it useful, email the author with an example of what you use it for. Do not use this option to set the ProtocolEncoding, that's just plain wrong - fix the XML>. This option allows you to pass parameters to the constructor of the underlying XML::Parser object (which of course assumes you're not using SAX). =head2 RootName => 'string' I<# out - handy> By default, when C<XMLout()> generates XML, the root element will be named 'opt'. This option allows you to specify an alternative name. Specifying either undef or the empty string for the RootName option will produce XML with no root elements. In most cases the resulting XML fragment will not be 'well formed' and therefore could not be read back in by C<XMLin()>. Nevertheless, the option has been found to be useful in certain circumstances. =head2 SearchPath => [ list ] I<# in - handy> If you pass C<XMLin()> a filename, but the filename include no directory component, you can use this option to specify which directories should be searched to locate the file. You might use this option to search first in the user's home directory, then in a global directory such as /etc. If a filename is provided to C<XMLin()> but SearchPath is not defined, the file is assumed to be in the current directory. If the first parameter to C<XMLin()> is undefined, the default SearchPath will contain only the directory in which the script itself is located. Otherwise the default SearchPath will be empty. =head2 StrictMode => 1 | 0 I<# in+out seldom used> This option allows you to turn L<STRICT MODE> on or off for a particular call, regardless of whether it was enabled at the time XML::Simple was loaded. =head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy> This option controls what C<XMLin()> should do with empty elements (no attributes and no content). The default behaviour is to represent them as empty hashes. Setting this option to a true value (eg: 1) will cause empty elements to be skipped altogether. Setting the option to 'undef' or the empty string will cause empty elements to be represented as the undefined value or the empty string respectively. The latter two alternatives are a little easier to test for in your code than a hash with no keys. The option also controls what C<XMLout()> does with undefined values. Setting the option to undef causes undefined values to be output as empty elements (rather than empty attributes), it also suppresses the generation of warnings about undefined values. Setting the option to a true value (eg: 1) causes undefined values to be skipped altogether on output. =head2 ValueAttr => [ names ] I<# in - handy> Use this option to deal elements which always have a single attribute and no content. Eg: <opt> <colour value="red" /> <size value="XXL" /> </opt> Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to: { colour => 'red', size => 'XXL' } instead of this (the default): { colour => { value => 'red' }, size => { value => 'XXL' } } Note: This form of the ValueAttr option is not compatible with C<XMLout()> - since the attribute name is discarded at parse time, the original XML cannot be reconstructed. =head2 ValueAttr => { element => attribute, ... } I<# in+out - handy> This (preferred) form of the ValueAttr option requires you to specify both the element and the attribute names. This is not only safer, it also allows the original XML to be reconstructed by C<XMLout()>. Note: You probably don't want to use this option and the NoAttr option at the same time. =head2 Variables => { name => value } I<# in - handy> This option allows variables in the XML to be expanded when the file is read. (there is no facility for putting the variable names back if you regenerate XML using C<XMLout>). A 'variable' is any text of the form C<${name}> which occurs in an attribute value or in the text content of an element. If 'name' matches a key in the supplied hashref, C<${name}> will be replaced with the corresponding value from the hashref. If no matching key is found, the variable will not be replaced. Names must match the regex: C<[\w.]+> (ie: only 'word' characters and dots are allowed). =head2 VarAttr => 'attr_name' I<# in - handy> In addition to the variables defined using C<Variables>, this option allows variables to be defined in the XML. A variable definition consists of an element with an attribute called 'attr_name' (the value of the C<VarAttr> option). The value of the attribute will be used as the variable name and the text content of the element will be used as the value. A variable defined in this way will override a variable defined using the C<Variables> option. For example: XMLin( '<opt> <dir name="prefix">/usr/local/apache</dir> <dir name="exec_prefix">${prefix}</dir> <dir name="bindir">${exec_prefix}/bin</dir> </opt>', VarAttr => 'name', ContentKey => '-content' ); produces the following data structure: { dir => { prefix => '/usr/local/apache', exec_prefix => '/usr/local/apache', bindir => '/usr/local/apache/bin', } } =head2 XMLDecl => 1 or XMLDecl => 'string' I<# out - handy> If you want the output from C<XMLout()> to start with the optional XML declaration, simply set the option to '1'. The default XML declaration is: <?xml version='1.0' standalone='yes'?> If you want some other string (for example to declare an encoding value), set the value of this option to the complete string you require. =head1 OPTIONAL OO INTERFACE The procedural interface is both simple and convenient however there are a couple of reasons why you might prefer to use the object oriented (OO) interface: =over 4 =item * to define a set of default values which should be used on all subsequent calls to C<XMLin()> or C<XMLout()> =item * to override methods in B<XML::Simple> to provide customised behaviour =back The default values for the options described above are unlikely to suit everyone. The OO interface allows you to effectively override B<XML::Simple>'s defaults with your preferred values. It works like this: First create an XML::Simple parser object with your preferred defaults: my $xs = XML::Simple->new(ForceArray => 1, KeepRoot => 1); then call C<XMLin()> or C<XMLout()> as a method of that object: my $ref = $xs->XMLin($xml); my $xml = $xs->XMLout($ref); You can also specify options when you make the method calls and these values will be merged with the values specified when the object was created. Values specified in a method call take precedence. Note: when called as methods, the C<XMLin()> and C<XMLout()> routines may be called as C<xml_in()> or C<xml_out()>. The method names are aliased so the only difference is the aesthetics. =head2 Parsing Methods You can explicitly call one of the following methods rather than rely on the C<xml_in()> method automatically determining whether the target to be parsed is a string, a file or a filehandle: =over 4 =item parse_string(text) Works exactly like the C<xml_in()> method but assumes the first argument is a string of XML (or a reference to a scalar containing a string of XML). =item parse_file(filename) Works exactly like the C<xml_in()> method but assumes the first argument is the name of a file containing XML. =item parse_fh(file_handle) Works exactly like the C<xml_in()> method but assumes the first argument is a filehandle which can be read to get XML. =back =head2 Hook Methods You can make your own class which inherits from XML::Simple and overrides certain behaviours. The following methods may provide useful 'hooks' upon which to hang your modified behaviour. You may find other undocumented methods by examining the source, but those may be subject to change in future releases. =over 4 =item new_xml_parser() This method will be called when a new XML::Parser object must be constructed (either because XML::SAX is not installed or XML::Parser is preferred). =item handle_options(direction, name => value ...) This method will be called when one of the parsing methods or the C<XMLout()> method is called. The initial argument will be a string (either 'in' or 'out') and the remaining arguments will be name value pairs. =item default_config_file() Calculates and returns the name of the file which should be parsed if no filename is passed to C<XMLin()> (default: C<$0.xml>). =item build_simple_tree(filename, string) Called from C<XMLin()> or any of the parsing methods. Takes either a file name as the first argument or C<undef> followed by a 'string' as the second argument. Returns a simple tree data structure. You could override this method to apply your own transformations before the data structure is returned to the caller. =item new_hashref() When the 'simple tree' data structure is being built, this method will be called to create any required anonymous hashrefs. =item sorted_keys(name, hashref) Called when C<XMLout()> is translating a hashref to XML. This routine returns a list of hash keys in the order that the corresponding attributes/elements should appear in the output. =item escape_value(string) Called from C<XMLout()>, takes a string and returns a copy of the string with XML character escaping rules applied. =item escape_attr(string) Called from C<XMLout()>, to handle attribute values. By default, just calls C<escape_value()>, but you can override this method if you want attributes escaped differently than text content. =item numeric_escape(string) Called from C<escape_value()>, to handle non-ASCII characters (depending on the value of the NumericEscape option). =item copy_hash(hashref, extra_key => value, ...) Called from C<XMLout()>, when 'unfolding' a hash of hashes into an array of hashes. You might wish to override this method if you're using tied hashes and don't want them to get untied. =back =head2 Cache Methods XML::Simple implements three caching schemes ('storable', 'memshare' and 'memcopy'). You can implement a custom caching scheme by implementing two methods - one for reading from the cache and one for writing to it. For example, you might implement a new 'dbm' scheme that stores cached data structures using the L<MLDBM> module. First, you would add a C<cache_read_dbm()> method which accepted a filename for use as a lookup key and returned a data structure on success, or undef on failure. Then, you would implement a C<cache_read_dbm()> method which accepted a data structure and a filename. You would use this caching scheme by specifying the option: Cache => [ 'dbm' ] =head1 STRICT MODE If you import the B<XML::Simple> routines like this: use XML::Simple qw(:strict); the following common mistakes will be detected and treated as fatal errors =over 4 =item * Failing to explicitly set the C<KeyAttr> option - if you can't be bothered reading about this option, turn it off with: KeyAttr => [ ] =item * Failing to explicitly set the C<ForceArray> option - if you can't be bothered reading about this option, set it to the safest mode with: ForceArray => 1 =item * Setting ForceArray to an array, but failing to list all the elements from the KeyAttr hash. =item * Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains one or more E<lt>partE<gt> elements without a 'partnum' attribute (or nested element). Note: if strict mode is not set but C<use warnings;> is in force, this condition triggers a warning. =item * Data error - as above, but non-unique values are present in the key attribute (eg: more than one E<lt>partE<gt> element with the same partnum). This will also trigger a warning if strict mode is not enabled. =item * Data error - as above, but value of key attribute (eg: partnum) is not a scalar string (due to nested elements etc). This will also trigger a warning if strict mode is not enabled. =back =head1 SAX SUPPORT From version 1.08_01, B<XML::Simple> includes support for SAX (the Simple API for XML) - specifically SAX2. In a typical SAX application, an XML parser (or SAX 'driver') module generates SAX events (start of element, character data, end of element, etc) as it parses an XML document and a 'handler' module processes the events to extract the required data. This simple model allows for some interesting and powerful possibilities: =over 4 =item * Applications written to the SAX API can extract data from huge XML documents without the memory overheads of a DOM or tree API. =item * The SAX API allows for plug and play interchange of parser modules without having to change your code to fit a new module's API. A number of SAX parsers are available with capabilities ranging from extreme portability to blazing performance. =item * A SAX 'filter' module can implement both a handler interface for receiving data and a generator interface for passing modified data on to a downstream handler. Filters can be chained together in 'pipelines'. =item * One filter module might split a data stream to direct data to two or more downstream handlers. =item * Generating SAX events is not the exclusive preserve of XML parsing modules. For example, a module might extract data from a relational database using DBI and pass it on to a SAX pipeline for filtering and formatting. =back B<XML::Simple> can operate at either end of a SAX pipeline. For example, you can take a data structure in the form of a hashref and pass it into a SAX pipeline using the 'Handler' option on C<XMLout()>: use XML::Simple; use Some::SAX::Filter; use XML::SAX::Writer; my $ref = { .... # your data here }; my $writer = XML::SAX::Writer->new(); my $filter = Some::SAX::Filter->new(Handler => $writer); my $simple = XML::Simple->new(Handler => $filter); $simple->XMLout($ref); You can also put B<XML::Simple> at the opposite end of the pipeline to take advantage of the simple 'tree' data structure once the relevant data has been isolated through filtering: use XML::SAX; use Some::SAX::Filter; use XML::Simple; my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']); my $filter = Some::SAX::Filter->new(Handler => $simple); my $parser = XML::SAX::ParserFactory->parser(Handler => $filter); my $ref = $parser->parse_uri('some_huge_file.xml'); print $ref->{part}->{'555-1234'}; You can build a filter by using an XML::Simple object as a handler and setting its DataHandler option to point to a routine which takes the resulting tree, modifies it and sends it off as SAX events to a downstream handler: my $writer = XML::SAX::Writer->new(); my $filter = XML::Simple->new( DataHandler => sub { my $simple = shift; my $data = shift; # Modify $data here $simple->XMLout($data, Handler => $writer); } ); my $parser = XML::SAX::ParserFactory->parser(Handler => $filter); $parser->parse_uri($filename); I<Note: In this last example, the 'Handler' option was specified in the call to C<XMLout()> but it could also have been specified in the constructor>. =head1 ENVIRONMENT If you don't care which parser module B<XML::Simple> uses then skip this section entirely (it looks more complicated than it really is). B<XML::Simple> will default to using a B<SAX> parser if one is available or B<XML::Parser> if SAX is not available. You can dictate which parser module is used by setting either the environment variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable $XML::Simple::PREFERRED_PARSER to contain the module name. The following rules are used: =over 4 =item * The package variable takes precedence over the environment variable if both are defined. To force B<XML::Simple> to ignore the environment settings and use its default rules, you can set the package variable to an empty string. =item * If the 'preferred parser' is set to the string 'XML::Parser', then L<XML::Parser> will be used (or C<XMLin()> will die if L<XML::Parser> is not installed). =item * If the 'preferred parser' is set to some other value, then it is assumed to be the name of a SAX parser module and is passed to L<XML::SAX::ParserFactory>. If L<XML::SAX> is not installed, or the requested parser module is not installed, then C<XMLin()> will die. =item * If the 'preferred parser' is not defined at all (the normal default state), an attempt will be made to load L<XML::SAX>. If L<XML::SAX> is installed, then a parser module will be selected according to L<XML::SAX::ParserFactory>'s normal rules (which typically means the last SAX parser installed). =item * if the 'preferred parser' is not defined and B<XML::SAX> is not installed, then B<XML::Parser> will be used. C<XMLin()> will die if L<XML::Parser> is not installed. =back Note: The B<XML::SAX> distribution includes an XML parser written entirely in Perl. It is very portable but it is not very fast. You should consider installing L<XML::LibXML> or L<XML::SAX::Expat> if they are available for your platform. =head1 ERROR HANDLING The XML standard is very clear on the issue of non-compliant documents. An error in parsing any single element (for example a missing end tag) must cause the whole document to be rejected. B<XML::Simple> will die with an appropriate message if it encounters a parsing error. If dying is not appropriate for your application, you should arrange to call C<XMLin()> in an eval block and look for errors in $@. eg: my $config = eval { XMLin() }; PopUpMessage($@) if($@); Note, there is a common misconception that use of B<eval> will significantly slow down a script. While that may be true when the code being eval'd is in a string, it is not true of code like the sample above. =head1 EXAMPLES When C<XMLin()> reads the following very simple piece of XML: <opt username="testuser" password="frodo"></opt> it returns the following data structure: { 'username' => 'testuser', 'password' => 'frodo' } The identical result could have been produced with this alternative XML: <opt username="testuser" password="frodo" /> Or this (although see 'ForceArray' option for variations): <opt> <username>testuser</username> <password>frodo</password> </opt> Repeated nested elements are represented as anonymous arrays: <opt> <person firstname="Joe" lastname="Smith"> <email>joe@smith.com</email> <email>jsmith@yahoo.com</email> </person> <person firstname="Bob" lastname="Smith"> <email>bob@smith.com</email> </person> </opt> { 'person' => [ { 'email' => [ 'joe@smith.com', 'jsmith@yahoo.com' ], 'firstname' => 'Joe', 'lastname' => 'Smith' }, { 'email' => 'bob@smith.com', 'firstname' => 'Bob', 'lastname' => 'Smith' } ] } Nested elements with a recognised key attribute are transformed (folded) from an array into a hash keyed on the value of that attribute (see the C<KeyAttr> option): <opt> <person key="jsmith" firstname="Joe" lastname="Smith" /> <person key="tsmith" firstname="Tom" lastname="Smith" /> <person key="jbloggs" firstname="Joe" lastname="Bloggs" /> </opt> { 'person' => { 'jbloggs' => { 'firstname' => 'Joe', 'lastname' => 'Bloggs' }, 'tsmith' => { 'firstname' => 'Tom', 'lastname' => 'Smith' }, 'jsmith' => { 'firstname' => 'Joe', 'lastname' => 'Smith' } } } The <anon> tag can be used to form anonymous arrays: <opt> <head><anon>Col 1</anon><anon>Col 2</anon><anon>Col 3</anon></head> <data><anon>R1C1</anon><anon>R1C2</anon><anon>R1C3</anon></data> <data><anon>R2C1</anon><anon>R2C2</anon><anon>R2C3</anon></data> <data><anon>R3C1</anon><anon>R3C2</anon><anon>R3C3</anon></data> </opt> { 'head' => [ [ 'Col 1', 'Col 2', 'Col 3' ] ], 'data' => [ [ 'R1C1', 'R1C2', 'R1C3' ], [ 'R2C1', 'R2C2', 'R2C3' ], [ 'R3C1', 'R3C2', 'R3C3' ] ] } Anonymous arrays can be nested to arbitrary levels and as a special case, if the surrounding tags for an XML document contain only an anonymous array the arrayref will be returned directly rather than the usual hashref: <opt> <anon><anon>Col 1</anon><anon>Col 2</anon></anon> <anon><anon>R1C1</anon><anon>R1C2</anon></anon> <anon><anon>R2C1</anon><anon>R2C2</anon></anon> </opt> [ [ 'Col 1', 'Col 2' ], [ 'R1C1', 'R1C2' ], [ 'R2C1', 'R2C2' ] ] Elements which only contain text content will simply be represented as a scalar. Where an element has both attributes and text content, the element will be represented as a hashref with the text content in the 'content' key (see the C<ContentKey> option): <opt> <one>first</one> <two attr="value">second</two> </opt> { 'one' => 'first', 'two' => { 'attr' => 'value', 'content' => 'second' } } Mixed content (elements which contain both text content and nested elements) will be not be represented in a useful way - element order and significant whitespace will be lost. If you need to work with mixed content, then XML::Simple is not the right tool for your job - check out the next section. =head1 WHERE TO FROM HERE? B<XML::Simple> is able to present a simple API because it makes some assumptions on your behalf. These include: =over 4 =item * You're not interested in text content consisting only of whitespace =item * You don't mind that when things get slurped into a hash the order is lost =item * You don't want fine-grained control of the formatting of generated XML =item * You would never use a hash key that was not a legal XML element name =item * You don't need help converting between different encodings =back In a serious XML project, you'll probably outgrow these assumptions fairly quickly. This section of the document used to offer some advice on choosing a more powerful option. That advice has now grown into the 'Perl-XML FAQ' document which you can find at: L<http://perl-xml.sourceforge.net/faq/> The advice in the FAQ boils down to a quick explanation of tree versus event based parsers and then recommends: For event based parsing, use SAX (do not set out to write any new code for XML::Parser's handler API - it is obsolete). For tree-based parsing, you could choose between the 'Perlish' approach of L<XML::Twig> and more standards based DOM implementations - preferably one with XPath support such as L<XML::LibXML>. =head1 SEE ALSO B<XML::Simple> requires either L<XML::Parser> or L<XML::SAX>. To generate documents with namespaces, L<XML::NamespaceSupport> is required. The optional caching functions require L<Storable>. Answers to Frequently Asked Questions about XML::Simple are bundled with this distribution as: L<XML::Simple::FAQ> =head1 COPYRIGHT Copyright 1999-2004 Grant McLean E<lt>grantm@cpan.orgE<gt> This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/XML/SAX.pm 0000444 00000022065 14711217550 0007232 0 ustar 00 # $Id$ package XML::SAX; use strict; use vars qw($VERSION @ISA @EXPORT_OK); $VERSION = '1.02'; use Exporter (); @ISA = ('Exporter'); @EXPORT_OK = qw(Namespaces Validation); use File::Basename qw(dirname); use File::Spec (); use Symbol qw(gensym); use XML::SAX::ParserFactory (); # loaded for simplicity use constant PARSER_DETAILS => "ParserDetails.ini"; use constant Namespaces => "http://xml.org/sax/features/namespaces"; use constant Validation => "http://xml.org/sax/features/validation"; my $known_parsers = undef; # load_parsers takes the ParserDetails.ini file out of the same directory # that XML::SAX is in, and looks at it. Format in POD below =begin EXAMPLE [XML::SAX::PurePerl] http://xml.org/sax/features/namespaces = 1 http://xml.org/sax/features/validation = 0 # a comment # blank lines ignored [XML::SAX::AnotherParser] http://xml.org/sax/features/namespaces = 0 http://xml.org/sax/features/validation = 1 =end EXAMPLE =cut sub load_parsers { my $class = shift; my $dir = shift; # reset parsers $known_parsers = []; # get directory from wherever XML::SAX is installed if (!$dir) { $dir = $INC{'XML/SAX.pm'}; $dir = dirname($dir); } my $fh = gensym(); if (!open($fh, File::Spec->catfile($dir, "SAX", PARSER_DETAILS))) { XML::SAX->do_warn("could not find " . PARSER_DETAILS . " in $dir/SAX\n"); return $class; } $known_parsers = $class->_parse_ini_file($fh); return $class; } sub _parse_ini_file { my $class = shift; my ($fh) = @_; my @config; my $lineno = 0; while (defined(my $line = <$fh>)) { $lineno++; my $original = $line; # strip whitespace $line =~ s/\s*$//m; $line =~ s/^\s*//m; # strip comments $line =~ s/[#;].*$//m; # ignore blanks next if $line =~ /^$/m; # heading if ($line =~ /^\[\s*(.*)\s*\]$/m) { push @config, { Name => $1 }; next; } # instruction elsif ($line =~ /^(.*?)\s*?=\s*(.*)$/) { unless(@config) { push @config, { Name => '' }; } $config[-1]{Features}{$1} = $2; } # not whitespace, comment, or instruction else { die "Invalid line in ini: $lineno\n>>> $original\n"; } } return \@config; } sub parsers { my $class = shift; if (!$known_parsers) { $class->load_parsers(); } return $known_parsers; } sub remove_parser { my $class = shift; my ($parser_module) = @_; if (!$known_parsers) { $class->load_parsers(); } @$known_parsers = grep { $_->{Name} ne $parser_module } @$known_parsers; return $class; } sub add_parser { my $class = shift; my ($parser_module) = @_; if (!$known_parsers) { $class->load_parsers(); } # first load module, then query features, then push onto known_parsers, my $parser_file = $parser_module; $parser_file =~ s/::/\//g; $parser_file .= ".pm"; require $parser_file; my @features = $parser_module->supported_features(); my $new = { Name => $parser_module }; foreach my $feature (@features) { $new->{Features}{$feature} = 1; } # If exists in list already, move to end. my $done = 0; my $pos = undef; for (my $i = 0; $i < @$known_parsers; $i++) { my $p = $known_parsers->[$i]; if ($p->{Name} eq $parser_module) { $pos = $i; } } if (defined $pos) { splice(@$known_parsers, $pos, 1); push @$known_parsers, $new; $done++; } # Otherwise (not in list), add at end of list. if (!$done) { push @$known_parsers, $new; } return $class; } sub save_parsers { my $class = shift; # get directory from wherever XML::SAX is installed my $dir = $INC{'XML/SAX.pm'}; $dir = dirname($dir); my $file = File::Spec->catfile($dir, "SAX", PARSER_DETAILS); chmod 0644, $file; unlink($file); my $fh = gensym(); open($fh, ">$file") || die "Cannot write to $file: $!"; foreach my $p (@$known_parsers) { print $fh "[$p->{Name}]\n"; foreach my $key (keys %{$p->{Features}}) { print $fh "$key = $p->{Features}{$key}\n"; } print $fh "\n"; } print $fh "\n"; close $fh; return $class; } sub do_warn { my $class = shift; # Don't output warnings if running under Test::Harness warn(@_) unless $ENV{HARNESS_ACTIVE}; } 1; __END__ =head1 NAME XML::SAX - Simple API for XML =head1 SYNOPSIS use XML::SAX; # get a list of known parsers my $parsers = XML::SAX->parsers(); # add/update a parser XML::SAX->add_parser(q(XML::SAX::PurePerl)); # remove parser XML::SAX->remove_parser(q(XML::SAX::Foodelberry)); # save parsers XML::SAX->save_parsers(); =head1 DESCRIPTION XML::SAX is a SAX parser access API for Perl. It includes classes and APIs required for implementing SAX drivers, along with a factory class for returning any SAX parser installed on the user's system. =head1 USING A SAX2 PARSER The factory class is XML::SAX::ParserFactory. Please see the documentation of that module for how to instantiate a SAX parser: L<XML::SAX::ParserFactory>. However if you don't want to load up another manual page, here's a short synopsis: use XML::SAX::ParserFactory; use XML::SAX::XYZHandler; my $handler = XML::SAX::XYZHandler->new(); my $p = XML::SAX::ParserFactory->parser(Handler => $handler); $p->parse_uri("foo.xml"); # or $p->parse_string("<foo/>") or $p->parse_file($fh); This will automatically load a SAX2 parser (defaulting to XML::SAX::PurePerl if no others are found) and return it to you. In order to learn how to use SAX to parse XML, you will need to read L<XML::SAX::Intro> and for reference, L<XML::SAX::Specification>. =head1 WRITING A SAX2 PARSER The first thing to remember in writing a SAX2 parser is to subclass XML::SAX::Base. This will make your life infinitely easier, by providing a number of methods automagically for you. See L<XML::SAX::Base> for more details. When writing a SAX2 parser that is compatible with XML::SAX, you need to inform XML::SAX of the presence of that driver when you install it. In order to do that, XML::SAX contains methods for saving the fact that the parser exists on your system to a "INI" file, which is then loaded to determine which parsers are installed. The best way to do this is to follow these rules: =over 4 =item * Add XML::SAX as a prerequisite in Makefile.PL: WriteMakefile( ... PREREQ_PM => { 'XML::SAX' => 0 }, ... ); Alternatively you may wish to check for it in other ways that will cause more than just a warning. =item * Add the following code snippet to your Makefile.PL: sub MY::install { package MY; my $script = shift->SUPER::install(@_); if (ExtUtils::MakeMaker::prompt( "Do you want to modify ParserDetails.ini?", 'Y') =~ /^y/i) { $script =~ s/install :: (.*)$/install :: $1 install_sax_driver/m; $script .= <<"INSTALL"; install_sax_driver : \t\@\$(PERL) -MXML::SAX -e "XML::SAX->add_parser(q(\$(NAME)))->save_parsers()" INSTALL } return $script; } Note that you should check the output of this - \$(NAME) will use the name of your distribution, which may not be exactly what you want. For example XML::LibXML has a driver called XML::LibXML::SAX::Generator, which is used in place of \$(NAME) in the above. =item * Add an XML::SAX test: A test file should be added to your t/ directory containing something like the following: use Test; BEGIN { plan tests => 3 } use XML::SAX; use XML::SAX::PurePerl::DebugHandler; XML::SAX->add_parser(q(XML::SAX::MyDriver)); local $XML::SAX::ParserPackage = 'XML::SAX::MyDriver'; eval { my $handler = XML::SAX::PurePerl::DebugHandler->new(); ok($handler); my $parser = XML::SAX::ParserFactory->parser(Handler => $handler); ok($parser); ok($parser->isa('XML::SAX::MyDriver'); $parser->parse_string("<tag/>"); ok($handler->{seen}{start_element}); }; =back =head1 EXPORTS By default, XML::SAX exports nothing into the caller's namespace. However you can request the symbols C<Namespaces> and C<Validation> which are the URIs for those features, allowing an easier way to request those features via ParserFactory: use XML::SAX qw(Namespaces Validation); my $factory = XML::SAX::ParserFactory->new(); $factory->require_feature(Namespaces); $factory->require_feature(Validation); my $parser = $factory->parser(); =head1 AUTHOR Current maintainer: Grant McLean, grantm@cpan.org Originally written by: Matt Sergeant, matt@sergeant.org Kip Hampton, khampton@totalcinema.com Robin Berjon, robin@knowscape.com =head1 LICENSE This is free software, you may use it and distribute it under the same terms as Perl itself. =head1 SEE ALSO L<XML::SAX::Base> for writing SAX Filters and Parsers L<XML::SAX::PurePerl> for an XML parser written in 100% pure perl. L<XML::SAX::Exception> for details on exception handling =cut perl5/XML/SAX/PurePerl.pm 0000444 00000050153 14711217551 0010770 0 ustar 00 # $Id$ package XML::SAX::PurePerl; use strict; use vars qw/$VERSION/; $VERSION = '1.02'; use XML::SAX::PurePerl::Productions qw($NameChar $SingleChar); use XML::SAX::PurePerl::Reader; use XML::SAX::PurePerl::EncodingDetect (); use XML::SAX::Exception; use XML::SAX::PurePerl::DocType (); use XML::SAX::PurePerl::DTDDecls (); use XML::SAX::PurePerl::XMLDecl (); use XML::SAX::DocumentLocator (); use XML::SAX::Base (); use XML::SAX qw(Namespaces); use XML::NamespaceSupport (); use IO::File; if ($] < 5.006) { require XML::SAX::PurePerl::NoUnicodeExt; } else { require XML::SAX::PurePerl::UnicodeExt; } use vars qw(@ISA); @ISA = ('XML::SAX::Base'); my %int_ents = ( amp => '&', lt => '<', gt => '>', quot => '"', apos => "'", ); my $xmlns_ns = "http://www.w3.org/2000/xmlns/"; my $xml_ns = "http://www.w3.org/XML/1998/namespace"; use Carp; sub _parse_characterstream { my $self = shift; my ($fh) = @_; confess("CharacterStream is not yet correctly implemented"); my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh); return $self->_parse($reader); } sub _parse_bytestream { my $self = shift; my ($fh) = @_; my $reader = XML::SAX::PurePerl::Reader::Stream->new($fh); return $self->_parse($reader); } sub _parse_string { my $self = shift; my ($str) = @_; my $reader = XML::SAX::PurePerl::Reader::String->new($str); return $self->_parse($reader); } sub _parse_systemid { my $self = shift; my ($uri) = @_; my $reader = XML::SAX::PurePerl::Reader::URI->new($uri); return $self->_parse($reader); } sub _parse { my ($self, $reader) = @_; $reader->public_id($self->{ParseOptions}{Source}{PublicId}); $reader->system_id($self->{ParseOptions}{Source}{SystemId}); $self->{NSHelper} = XML::NamespaceSupport->new({xmlns => 1}); $self->set_document_locator( XML::SAX::DocumentLocator->new( sub { $reader->public_id }, sub { $reader->system_id }, sub { $reader->line }, sub { $reader->column }, sub { $reader->get_encoding }, sub { $reader->get_xml_version }, ), ); $self->start_document({}); if (defined $self->{ParseOptions}{Source}{Encoding}) { $reader->set_encoding($self->{ParseOptions}{Source}{Encoding}); } else { $self->encoding_detect($reader); } # parse a document $self->document($reader); return $self->end_document({}); } sub parser_error { my $self = shift; my ($error, $reader) = @_; # warn("parser error: $error from ", $reader->line, " : ", $reader->column, "\n"); my $exception = XML::SAX::Exception::Parse->new( Message => $error, ColumnNumber => $reader->column, LineNumber => $reader->line, PublicId => $reader->public_id, SystemId => $reader->system_id, ); $self->fatal_error($exception); $exception->throw; } sub document { my ($self, $reader) = @_; # document ::= prolog element Misc* $self->prolog($reader); $self->element($reader) || $self->parser_error("Document requires an element", $reader); while(length($reader->data)) { $self->Misc($reader) || $self->parser_error("Only Comments, PIs and whitespace allowed at end of document", $reader); } } sub prolog { my ($self, $reader) = @_; $self->XMLDecl($reader); # consume all misc bits 1 while($self->Misc($reader)); if ($self->doctypedecl($reader)) { while (length($reader->data)) { $self->Misc($reader) || last; } } } sub element { my ($self, $reader) = @_; return 0 unless $reader->match('<'); my $name = $self->Name($reader) || $self->parser_error("Invalid element name", $reader); my %attribs; while( my ($k, $v) = $self->Attribute($reader) ) { $attribs{$k} = $v; } my $have_namespaces = $self->get_feature(Namespaces); # Namespace processing $self->{NSHelper}->push_context; my @new_ns; # my %attrs = @attribs; # while (my ($k,$v) = each %attrs) { if ($have_namespaces) { while ( my ($k, $v) = each %attribs ) { if ($k =~ m/^xmlns(:(.*))?$/) { my $prefix = $2 || ''; $self->{NSHelper}->declare_prefix($prefix, $v); my $ns = { Prefix => $prefix, NamespaceURI => $v, }; push @new_ns, $ns; $self->SUPER::start_prefix_mapping($ns); } } } # Create element object and fire event my %attrib_hash; while (my ($name, $value) = each %attribs ) { # TODO normalise value here my ($ns, $prefix, $lname); if ($have_namespaces) { ($ns, $prefix, $lname) = $self->{NSHelper}->process_attribute_name($name); } $ns ||= ''; $prefix ||= ''; $lname ||= ''; $attrib_hash{"{$ns}$lname"} = { Name => $name, LocalName => $lname, Prefix => $prefix, NamespaceURI => $ns, Value => $value, }; } %attribs = (); # lose the memory since we recurse deep my ($ns, $prefix, $lname); if ($self->get_feature(Namespaces)) { ($ns, $prefix, $lname) = $self->{NSHelper}->process_element_name($name); } else { $lname = $name; } $ns ||= ''; $prefix ||= ''; $lname ||= ''; # Process remainder of start_element $self->skip_whitespace($reader); my $have_content; my $data = $reader->data(2); if ($data =~ /^\/>/) { $reader->move_along(2); } else { $data =~ /^>/ or $self->parser_error("No close element tag", $reader); $reader->move_along(1); $have_content++; } my $el = { Name => $name, LocalName => $lname, Prefix => $prefix, NamespaceURI => $ns, Attributes => \%attrib_hash, }; $self->start_element($el); # warn("($name\n"); if ($have_content) { $self->content($reader); my $data = $reader->data(2); $data =~ /^<\// or $self->parser_error("No close tag marker", $reader); $reader->move_along(2); my $end_name = $self->Name($reader); $end_name eq $name || $self->parser_error("End tag mismatch ($end_name != $name)", $reader); $self->skip_whitespace($reader); $reader->match('>') or $self->parser_error("No close '>' on end tag", $reader); } my %end_el = %$el; delete $end_el{Attributes}; $self->end_element(\%end_el); for my $ns (@new_ns) { $self->end_prefix_mapping($ns); } $self->{NSHelper}->pop_context; return 1; } sub content { my ($self, $reader) = @_; while (1) { $self->CharData($reader); my $data = $reader->data(2); if ($data =~ /^<\//) { return 1; } elsif ($data =~ /^&/) { $self->Reference($reader) or $self->parser_error("bare & not allowed in content", $reader); next; } elsif ($data =~ /^<!/) { ($self->CDSect($reader) or $self->Comment($reader)) and next; } elsif ($data =~ /^<\?/) { $self->PI($reader) and next; } elsif ($data =~ /^</) { $self->element($reader) and next; } last; } return 1; } sub CDSect { my ($self, $reader) = @_; my $data = $reader->data(9); return 0 unless $data =~ /^<!\[CDATA\[/; $reader->move_along(9); $self->start_cdata({}); $data = $reader->data; while (1) { $self->parser_error("EOF looking for CDATA section end", $reader) unless length($data); if ($data =~ /^(.*?)\]\]>/s) { my $chars = $1; $reader->move_along(length($chars) + 3); $self->characters({Data => $chars}); last; } else { $self->characters({Data => $data}); $reader->move_along(length($data)); $data = $reader->data; } } $self->end_cdata({}); return 1; } sub CharData { my ($self, $reader) = @_; my $data = $reader->data; while (1) { return unless length($data); if ($data =~ /^([^<&]*)[<&]/s) { my $chars = $1; $self->parser_error("String ']]>' not allowed in character data", $reader) if $chars =~ /\]\]>/; $reader->move_along(length($chars)); $self->characters({Data => $chars}) if length($chars); last; } else { $self->characters({Data => $data}); $reader->move_along(length($data)); $data = $reader->data; } } } sub Misc { my ($self, $reader) = @_; if ($self->Comment($reader)) { return 1; } elsif ($self->PI($reader)) { return 1; } elsif ($self->skip_whitespace($reader)) { return 1; } return 0; } sub Reference { my ($self, $reader) = @_; return 0 unless $reader->match('&'); my $data = $reader->data; # Fetch more data if we have an incomplete numeric reference if ($data =~ /^(#\d*|#x[0-9a-fA-F]*)$/) { $data = $reader->data(length($data) + 6); } if ($data =~ /^#x([0-9a-fA-F]+);/) { my $ref = $1; $reader->move_along(length($ref) + 3); my $char = chr_ref(hex($ref)); $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader) unless $char =~ /$SingleChar/o; $self->characters({ Data => $char }); return 1; } elsif ($data =~ /^#([0-9]+);/) { my $ref = $1; $reader->move_along(length($ref) + 2); my $char = chr_ref($ref); $self->parser_error("Character reference &#$ref; refers to an illegal XML character ($char)", $reader) unless $char =~ /$SingleChar/o; $self->characters({ Data => $char }); return 1; } else { # EntityRef my $name = $self->Name($reader) || $self->parser_error("Invalid name in entity", $reader); $reader->match(';') or $self->parser_error("No semi-colon found after entity name", $reader); # warn("got entity: \&$name;\n"); # expand it if ($self->_is_entity($name)) { if ($self->_is_external($name)) { my $value = $self->_get_entity($name); my $ent_reader = XML::SAX::PurePerl::Reader::URI->new($value); $self->encoding_detect($ent_reader); $self->extParsedEnt($ent_reader); } else { my $value = $self->_stringify_entity($name); my $ent_reader = XML::SAX::PurePerl::Reader::String->new($value); $self->content($ent_reader); } return 1; } elsif ($name =~ /^(?:amp|gt|lt|quot|apos)$/) { $self->characters({ Data => $int_ents{$name} }); return 1; } else { $self->parser_error("Undeclared entity", $reader); } } } sub AttReference { my ($self, $name, $reader) = @_; if ($name =~ /^#x([0-9a-fA-F]+)$/) { my $chr = chr_ref(hex($1)); $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader); return $chr; } elsif ($name =~ /^#([0-9]+)$/) { my $chr = chr_ref($1); $chr =~ /$SingleChar/o or $self->parser_error("Character reference '&$name;' refers to an illegal XML character", $reader); return $chr; } else { if ($self->_is_entity($name)) { if ($self->_is_external($name)) { $self->parser_error("No external entity references allowed in attribute values", $reader); } else { my $value = $self->_stringify_entity($name); return $value; } } elsif ($name =~ /^(?:amp|lt|gt|quot|apos)$/) { return $int_ents{$name}; } else { $self->parser_error("Undeclared entity '$name'", $reader); } } } sub extParsedEnt { my ($self, $reader) = @_; $self->TextDecl($reader); $self->content($reader); } sub _is_external { my ($self, $name) = @_; # TODO: Fix this to use $reader to store the entities perhaps. if ($self->{ParseOptions}{external_entities}{$name}) { return 1; } return ; } sub _is_entity { my ($self, $name) = @_; # TODO: ditto above if (exists $self->{ParseOptions}{entities}{$name}) { return 1; } return 0; } sub _stringify_entity { my ($self, $name) = @_; # TODO: ditto above if (exists $self->{ParseOptions}{expanded_entity}{$name}) { return $self->{ParseOptions}{expanded_entity}{$name}; } # expand my $reader = XML::SAX::PurePerl::Reader::URI->new($self->{ParseOptions}{entities}{$name}); my $ent = ''; while(1) { my $data = $reader->data; $ent .= $data; $reader->move_along(length($data)) or last; } return $self->{ParseOptions}{expanded_entity}{$name} = $ent; } sub _get_entity { my ($self, $name) = @_; # TODO: ditto above return $self->{ParseOptions}{entities}{$name}; } sub skip_whitespace { my ($self, $reader) = @_; my $data = $reader->data; my $found = 0; while ($data =~ s/^([\x20\x0A\x0D\x09]*)//) { last unless length($1); $found++; $reader->move_along(length($1)); $data = $reader->data; } return $found; } sub Attribute { my ($self, $reader) = @_; $self->skip_whitespace($reader) || return; my $data = $reader->data(2); return if $data =~ /^\/?>/; if (my $name = $self->Name($reader)) { $self->skip_whitespace($reader); $reader->match('=') or $self->parser_error("No '=' in Attribute", $reader); $self->skip_whitespace($reader); my $value = $self->AttValue($reader); if (!$self->cdata_attrib($name)) { $value =~ s/^\x20*//; # discard leading spaces $value =~ s/\x20*$//; # discard trailing spaces $value =~ s/ {1,}/ /g; # all >1 space to single space } return $name, $value; } return; } sub cdata_attrib { # TODO implement this! return 1; } sub AttValue { my ($self, $reader) = @_; my $quote = $self->quote($reader); my $value = ''; while (1) { my $data = $reader->data; $self->parser_error("EOF found while looking for the end of attribute value", $reader) unless length($data); if ($data =~ /^([^$quote]*)$quote/) { $reader->move_along(length($1) + 1); $value .= $1; last; } else { $value .= $data; $reader->move_along(length($data)); } } if ($value =~ /</) { $self->parser_error("< character not allowed in attribute values", $reader); } $value =~ s/[\x09\x0A\x0D]/\x20/g; $value =~ s/&(#(x[0-9a-fA-F]+)|#([0-9]+)|\w+);/$self->AttReference($1, $reader)/geo; return $value; } sub Comment { my ($self, $reader) = @_; my $data = $reader->data(4); if ($data =~ /^<!--/) { $reader->move_along(4); my $comment_str = ''; while (1) { my $data = $reader->data; $self->parser_error("End of data seen while looking for close comment marker", $reader) unless length($data); if ($data =~ /^(.*?)-->/s) { $comment_str .= $1; $self->parser_error("Invalid comment (dash)", $reader) if $comment_str =~ /-$/; $reader->move_along(length($1) + 3); last; } else { $comment_str .= $data; $reader->move_along(length($data)); } } $self->comment({ Data => $comment_str }); return 1; } return 0; } sub PI { my ($self, $reader) = @_; my $data = $reader->data(2); if ($data =~ /^<\?/) { $reader->move_along(2); my ($target); $target = $self->Name($reader) || $self->parser_error("PI has no target", $reader); my $pi_data = ''; if ($self->skip_whitespace($reader)) { while (1) { my $data = $reader->data; $self->parser_error("End of data seen while looking for close PI marker", $reader) unless length($data); if ($data =~ /^(.*?)\?>/s) { $pi_data .= $1; $reader->move_along(length($1) + 2); last; } else { $pi_data .= $data; $reader->move_along(length($data)); } } } else { my $data = $reader->data(2); $data =~ /^\?>/ or $self->parser_error("PI closing sequence not found", $reader); $reader->move_along(2); } $self->processing_instruction({ Target => $target, Data => $pi_data }); return 1; } return 0; } sub Name { my ($self, $reader) = @_; my $name = ''; while(1) { my $data = $reader->data; return unless length($data); $data =~ /^([^\s>\/&\?;=<\)\(\[\],\%\#\!\*\|]*)/ or return; $name .= $1; my $len = length($1); $reader->move_along($len); last if ($len != length($data)); } return unless length($name); $name =~ /$NameChar/o or $self->parser_error("Name <$name> does not match NameChar production", $reader); return $name; } sub quote { my ($self, $reader) = @_; my $data = $reader->data; $data =~ /^(['"])/ or $self->parser_error("Invalid quote token", $reader); $reader->move_along(1); return $1; } 1; __END__ =head1 NAME XML::SAX::PurePerl - Pure Perl XML Parser with SAX2 interface =head1 SYNOPSIS use XML::Handler::Foo; use XML::SAX::PurePerl; my $handler = XML::Handler::Foo->new(); my $parser = XML::SAX::PurePerl->new(Handler => $handler); $parser->parse_uri("myfile.xml"); =head1 DESCRIPTION This module implements an XML parser in pure perl. It is written around the upcoming perl 5.8's unicode support and support for multiple document encodings (using the PerlIO layer), however it has been ported to work with ASCII/UTF8 documents under lower perl versions. The SAX2 API is described in detail at http://sourceforge.net/projects/perl-xml/, in the CVS archive, under libxml-perl/docs. Hopefully those documents will be in a better location soon. Please refer to the SAX2 documentation for how to use this module - it is merely a front end to SAX2, and implements nothing that is not in that spec (or at least tries not to - please email me if you find errors in this implementation). =head1 BUGS XML::SAX::PurePerl is B<slow>. Very slow. I suggest you use something else in fact. However it is great as a fallback parser for XML::SAX, where the user might not be able to install an XS based parser or C library. Currently lots, probably. At the moment the weakest area is parsing DOCTYPE declarations, though the code is in place to start doing this. Also parsing parameter entity references is causing me much confusion, since it's not exactly what I would call trivial, or well documented in the XML grammar. XML documents with internal subsets are likely to fail. I am however trying to work towards full conformance using the Oasis test suite. =head1 AUTHOR Matt Sergeant, matt@sergeant.org. Copyright 2001. Please report all bugs to the Perl-XML mailing list at perl-xml@listserv.activestate.com. =head1 LICENSE This is free software. You may use it or redistribute it under the same terms as Perl 5.7.2 itself. =cut perl5/XML/SAX/ParserDetails.ini 0000644 00000000574 14711217552 0012144 0 ustar 00 [XML::SAX::PurePerl] http://xml.org/sax/features/namespaces = 1 [XML::SAX::Expat] http://xml.org/sax/features/namespaces = 1 http://xml.org/sax/features/external-general-entities = 1 http://xml.org/sax/features/external-parameter-entities = 1 [XML::LibXML::SAX::Parser] http://xml.org/sax/features/namespaces = 1 [XML::LibXML::SAX] http://xml.org/sax/features/namespaces = 1 perl5/XML/SAX/ParserFactory.pm 0000444 00000014607 14711217552 0012023 0 ustar 00 # $Id$ package XML::SAX::ParserFactory; use strict; use vars qw($VERSION); $VERSION = '1.02'; use Symbol qw(gensym); use XML::SAX; use XML::SAX::Exception; sub new { my $class = shift; my %params = @_; # TODO : Fix this in spec. my $self = bless \%params, $class; $self->{KnownParsers} = XML::SAX->parsers(); return $self; } sub parser { my $self = shift; my @parser_params = @_; if (!ref($self)) { $self = $self->new(); } my $parser_class = $self->_parser_class(); my $version = ''; if ($parser_class =~ s/\s*\(([\d\.]+)\)\s*$//) { $version = " $1"; } if (!$parser_class->can('new')) { eval "require $parser_class $version;"; die $@ if $@; } return $parser_class->new(@parser_params); } sub require_feature { my $self = shift; my ($feature) = @_; $self->{RequiredFeatures}{$feature}++; return $self; } sub _parser_class { my $self = shift; # First try ParserPackage if ($XML::SAX::ParserPackage) { return $XML::SAX::ParserPackage; } # Now check if required/preferred is there if ($self->{RequiredFeatures}) { my %required = %{$self->{RequiredFeatures}}; # note - we never go onto the next try (ParserDetails.ini), # because if we can't provide the requested feature # we need to throw an exception. PARSER: foreach my $parser (reverse @{$self->{KnownParsers}}) { foreach my $feature (keys %required) { if (!exists $parser->{Features}{$feature}) { next PARSER; } } # got here - all features must exist! return $parser->{Name}; } # TODO : should this be NotSupported() ? throw XML::SAX::Exception ( Message => "Unable to provide required features", ); } # Next try SAX.ini for my $dir (@INC) { my $fh = gensym(); if (open($fh, "$dir/SAX.ini")) { my $param_list = XML::SAX->_parse_ini_file($fh); my $params = $param_list->[0]->{Features}; if ($params->{ParserPackage}) { return $params->{ParserPackage}; } else { # we have required features (or nothing?) PARSER: foreach my $parser (reverse @{$self->{KnownParsers}}) { foreach my $feature (keys %$params) { if (!exists $parser->{Features}{$feature}) { next PARSER; } } return $parser->{Name}; } XML::SAX->do_warn("Unable to provide SAX.ini required features. Using fallback\n"); } last; # stop after first INI found } } if (@{$self->{KnownParsers}}) { return $self->{KnownParsers}[-1]{Name}; } else { return "XML::SAX::PurePerl"; # backup plan! } } 1; __END__ =head1 NAME XML::SAX::ParserFactory - Obtain a SAX parser =head1 SYNOPSIS use XML::SAX::ParserFactory; use XML::SAX::XYZHandler; my $handler = XML::SAX::XYZHandler->new(); my $p = XML::SAX::ParserFactory->parser(Handler => $handler); $p->parse_uri("foo.xml"); # or $p->parse_string("<foo/>") or $p->parse_file($fh); =head1 DESCRIPTION XML::SAX::ParserFactory is a factory class for providing an application with a Perl SAX2 XML parser. It is akin to DBI - a front end for other parser classes. Each new SAX2 parser installed will register itself with XML::SAX, and then it will become available to all applications that use XML::SAX::ParserFactory to obtain a SAX parser. Unlike DBI however, XML/SAX parsers almost all work alike (especially if they subclass XML::SAX::Base, as they should), so rather than specifying the parser you want in the call to C<parser()>, XML::SAX has several ways to automatically choose which parser to use: =over 4 =item * $XML::SAX::ParserPackage If this package variable is set, then this package is C<require()>d and an instance of this package is returned by calling the C<new()> class method in that package. If it cannot be loaded or there is an error, an exception will be thrown. The variable can also contain a version number: $XML::SAX::ParserPackage = "XML::SAX::Expat (0.72)"; And the number will be treated as a minimum version number. =item * Required features It is possible to require features from the parsers. For example, you may wish for a parser that supports validation via a DTD. To do that, use the following code: use XML::SAX::ParserFactory; my $factory = XML::SAX::ParserFactory->new(); $factory->require_feature('http://xml.org/sax/features/validation'); my $parser = $factory->parser(...); Alternatively, specify the required features in the call to the ParserFactory constructor: my $factory = XML::SAX::ParserFactory->new( RequiredFeatures => { 'http://xml.org/sax/features/validation' => 1, } ); If the features you have asked for are unavailable (for example the user might not have a validating parser installed), then an exception will be thrown. The list of known parsers is searched in reverse order, so it will always return the last installed parser that supports all of your requested features (Note: this is subject to change if someone comes up with a better way of making this work). =item * SAX.ini ParserFactory will search @INC for a file called SAX.ini, which is in a simple format: # a comment looks like this, ; or like this, and are stripped anywhere in the file key = value # SAX.in contains key/value pairs. All whitespace is non-significant. This file can contain either a line: ParserPackage = MyParserModule (1.02) Where MyParserModule is the module to load and use for the parser, and the number in brackets is a minimum version to load. Or you can list required features: http://xml.org/sax/features/validation = 1 And each feature with a true value will be required. =item * Fallback If none of the above works, the last parser installed on the user's system will be used. The XML::SAX package ships with a pure perl XML parser, XML::SAX::PurePerl, so that there will always be a fallback parser. =back =head1 AUTHOR Matt Sergeant, matt@sergeant.org =head1 LICENSE This is free software, you may use it and distribute it under the same terms as Perl itself. =cut perl5/XML/SAX/Exception.pm 0000444 00000005731 14711217552 0011173 0 ustar 00 package XML::SAX::Exception; $XML::SAX::Exception::VERSION = '1.09'; use strict; use overload '""' => "stringify", 'fallback' => 1; use vars qw($StackTrace); use Carp; $StackTrace = $ENV{XML_DEBUG} || 0; # Other exception classes: @XML::SAX::Exception::NotRecognized::ISA = ('XML::SAX::Exception'); @XML::SAX::Exception::NotSupported::ISA = ('XML::SAX::Exception'); @XML::SAX::Exception::Parse::ISA = ('XML::SAX::Exception'); sub throw { my $class = shift; if (ref($class)) { die $class; } die $class->new(@_); } sub new { my $class = shift; my %opts = @_; confess "Invalid options: " . join(', ', keys %opts) unless exists $opts{Message}; bless { ($StackTrace ? (StackTrace => stacktrace()) : ()), %opts }, $class; } sub stringify { my $self = shift; local $^W; my $error; if (exists $self->{LineNumber}) { $error = $self->{Message} . " [Ln: " . $self->{LineNumber} . ", Col: " . $self->{ColumnNumber} . "]"; } else { $error = $self->{Message}; } if ($StackTrace) { $error .= stackstring($self->{StackTrace}); } $error .= "\n"; return $error; } sub stacktrace { my $i = 2; my @fulltrace; while (my @trace = caller($i++)) { my %hash; @hash{qw(Package Filename Line)} = @trace[0..2]; push @fulltrace, \%hash; } return \@fulltrace; } sub stackstring { my $stacktrace = shift; my $string = "\nFrom:\n"; foreach my $current (@$stacktrace) { $string .= $current->{Filename} . " Line: " . $current->{Line} . "\n"; } return $string; } 1; __END__ =head1 NAME XML::SAX::Exception - Exception classes for XML::SAX =head1 SYNOPSIS throw XML::SAX::Exception::NotSupported( Message => "The foo feature is not supported", ); =head1 DESCRIPTION This module is the base class for all SAX Exceptions, those defined in the spec as well as those that one may create for one's own SAX errors. There are three subclasses included, corresponding to those of the SAX spec: XML::SAX::Exception::NotSupported XML::SAX::Exception::NotRecognized XML::SAX::Exception::Parse Use them wherever you want, and as much as possible when you encounter such errors. SAX is meant to use exceptions as much as possible to flag problems. =head1 CREATING NEW EXCEPTION CLASSES All you need to do to create a new exception class is: @XML::SAX::Exception::MyException::ISA = ('XML::SAX::Exception') The given package doesn't need to exist, it'll behave correctly this way. If your exception refines an existing exception class, then you may also inherit from that instead of from the base class. =head1 THROWING EXCEPTIONS This is as simple as exemplified in the SYNOPSIS. In fact, there's nothing more to know. All you have to do is: throw XML::SAX::Exception::MyException( Message => 'Something went wrong' ); and voila, you've thrown an exception which can be caught in an eval block. =cut perl5/XML/SAX/BuildSAXBase.pl 0000444 00000070017 14711217553 0011442 0 ustar 00 #!/usr/bin/perl # # This file is used to generate lib/XML/SAX/Base.pm. There is a pre-generated # Base.pm file included in the distribution so you don't need to run this # script unless you are attempting to modify the code. # # The code in this file was adapted from the Makefile.PL when XML::SAX::Base # was split back out into its own distribution. # # You can manually run this file: # # perl ./BuildSAXBase.pl # # or better yet it will be invoked by automatically Dist::Zilla when building # a release from the git repository. # # dzil build # package SAX::Base::Builder; use strict; use warnings; use File::Spec; write_xml_sax_base() unless caller(); sub build_xml_sax_base { my $code = <<'EOHEADER'; package XML::SAX::Base; # version 0.10 - Kip Hampton <khampton@totalcinema.com> # version 0.13 - Robin Berjon <robin@knowscape.com> # version 0.15 - Kip Hampton <khampton@totalcinema.com> # version 0.17 - Kip Hampton <khampton@totalcinema.com> # version 0.19 - Kip Hampton <khampton@totalcinema.com> # version 0.21 - Kip Hampton <khampton@totalcinema.com> # version 0.22 - Robin Berjon <robin@knowscape.com> # version 0.23 - Matt Sergeant <matt@sergeant.org> # version 0.24 - Robin Berjon <robin@knowscape.com> # version 0.25 - Kip Hampton <khampton@totalcinema.com> # version 1.00 - Kip Hampton <khampton@totalcinema.com> # version 1.01 - Kip Hampton <khampton@totalcinema.com> # version 1.02 - Robin Berjon <robin@knowscape.com> # version 1.03 - Matt Sergeant <matt@sergeant.org> # version 1.04 - Kip Hampton <khampton@totalcinema.com> # version 1.05 - Grant McLean <grantm@cpan.org> # version 1.06 - Grant McLean <grantm@cpan.org> # version 1.07 - Grant McLean <grantm@cpan.org> # version 1.08 - Grant McLean <grantm@cpan.org> #-----------------------------------------------------# # STOP!!!!! # # This file is generated by the 'BuildSAXBase.pl' file # that ships with the XML::SAX::Base distribution. # If you need to make changes, patch that file NOT # XML/SAX/Base.pm Better yet, fork the git repository # commit your changes and send a pull request: # https://github.com/grantm/XML-SAX-Base #-----------------------------------------------------# use strict; use XML::SAX::Exception qw(); EOHEADER my %EVENT_SPEC = ( start_document => [qw(ContentHandler DocumentHandler Handler)], end_document => [qw(ContentHandler DocumentHandler Handler)], start_element => [qw(ContentHandler DocumentHandler Handler)], end_element => [qw(ContentHandler DocumentHandler Handler)], characters => [qw(ContentHandler DocumentHandler Handler)], processing_instruction => [qw(ContentHandler DocumentHandler Handler)], ignorable_whitespace => [qw(ContentHandler DocumentHandler Handler)], set_document_locator => [qw(ContentHandler DocumentHandler Handler)], start_prefix_mapping => [qw(ContentHandler Handler)], end_prefix_mapping => [qw(ContentHandler Handler)], skipped_entity => [qw(ContentHandler Handler)], start_cdata => [qw(DocumentHandler LexicalHandler Handler)], end_cdata => [qw(DocumentHandler LexicalHandler Handler)], comment => [qw(DocumentHandler LexicalHandler Handler)], entity_reference => [qw(DocumentHandler Handler)], notation_decl => [qw(DTDHandler Handler)], unparsed_entity_decl => [qw(DTDHandler Handler)], element_decl => [qw(DeclHandler Handler)], attlist_decl => [qw(DTDHandler Handler)], doctype_decl => [qw(DTDHandler Handler)], xml_decl => [qw(DTDHandler Handler)], entity_decl => [qw(DTDHandler Handler)], attribute_decl => [qw(DeclHandler Handler)], internal_entity_decl => [qw(DeclHandler Handler)], external_entity_decl => [qw(DeclHandler Handler)], resolve_entity => [qw(EntityResolver Handler)], start_dtd => [qw(LexicalHandler Handler)], end_dtd => [qw(LexicalHandler Handler)], start_entity => [qw(LexicalHandler Handler)], end_entity => [qw(LexicalHandler Handler)], warning => [qw(ErrorHandler Handler)], error => [qw(ErrorHandler Handler)], fatal_error => [qw(ErrorHandler Handler)], ); for my $ev (keys %EVENT_SPEC) { $code .= <<" EOTOPCODE"; sub $ev { my \$self = shift; if (defined \$self->{Methods}->{'$ev'}) { \$self->{Methods}->{'$ev'}->(\@_); } else { my \$method; my \$callbacks; if (exists \$self->{ParseOptions}) { \$callbacks = \$self->{ParseOptions}; } else { \$callbacks = \$self; } if (0) { # dummy to make elsif's below compile } EOTOPCODE my ($can_string, $aload_string); for my $h (@{$EVENT_SPEC{$ev}}) { $can_string .= <<" EOCANBLOCK"; elsif (defined \$callbacks->{'$h'} and \$method = \$callbacks->{'$h'}->can('$ev') ) { my \$handler = \$callbacks->{'$h'}; \$self->{Methods}->{'$ev'} = sub { \$method->(\$handler, \@_) }; return \$method->(\$handler, \@_); } EOCANBLOCK $aload_string .= <<" EOALOADBLOCK"; elsif (defined \$callbacks->{'$h'} and \$callbacks->{'$h'}->can('AUTOLOAD') and \$callbacks->{'$h'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my \$res = eval { \$callbacks->{'$h'}->$ev(\@_) }; if (\$@) { die \$@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my \$handler = \$callbacks->{'$h'}; \$self->{Methods}->{'$ev'} = sub { \$handler->$ev(\@_) }; } return \$res; } EOALOADBLOCK } $code .= $can_string . $aload_string; $code .= <<" EOFALLTHROUGH"; else { \$self->{Methods}->{'$ev'} = sub { }; } } EOFALLTHROUGH $code .= "\n}\n\n"; } $code .= <<'BODY'; #-------------------------------------------------------------------# # Class->new(%options) #-------------------------------------------------------------------# sub new { my $proto = shift; my $class = ref($proto) || $proto; my $options = ($#_ == 0) ? shift : { @_ }; unless ( defined( $options->{Handler} ) or defined( $options->{ContentHandler} ) or defined( $options->{DTDHandler} ) or defined( $options->{DocumentHandler} ) or defined( $options->{LexicalHandler} ) or defined( $options->{ErrorHandler} ) or defined( $options->{DeclHandler} ) ) { $options->{Handler} = XML::SAX::Base::NoHandler->new; } my $self = bless $options, $class; # turn NS processing on by default $self->set_feature('http://xml.org/sax/features/namespaces', 1); return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse(%options) #-------------------------------------------------------------------# sub parse { my $self = shift; my $parse_options = $self->get_options(@_); local $self->{ParseOptions} = $parse_options; if ($self->{Parent}) { # calling parse on a filter for some reason return $self->{Parent}->parse($parse_options); } else { my $method; if (defined $parse_options->{Source}{CharacterStream} and $method = $self->can('_parse_characterstream')) { warn("parse charstream???\n"); return $method->($self, $parse_options->{Source}{CharacterStream}); } elsif (defined $parse_options->{Source}{ByteStream} and $method = $self->can('_parse_bytestream')) { return $method->($self, $parse_options->{Source}{ByteStream}); } elsif (defined $parse_options->{Source}{String} and $method = $self->can('_parse_string')) { return $method->($self, $parse_options->{Source}{String}); } elsif (defined $parse_options->{Source}{SystemId} and $method = $self->can('_parse_systemid')) { return $method->($self, $parse_options->{Source}{SystemId}); } else { die "No _parse_* routine defined on this driver (If it is a filter, remember to set the Parent property. If you call the parse() method, make sure to set a Source. You may want to call parse_uri, parse_string or parse_file instead.) [$self]"; } } } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse_file(%options) #-------------------------------------------------------------------# sub parse_file { my $self = shift; my $file = shift; return $self->parse_uri($file, @_) if ref(\$file) eq 'SCALAR'; my $parse_options = $self->get_options(@_); $parse_options->{Source}{ByteStream} = $file; return $self->parse($parse_options); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse_uri(%options) #-------------------------------------------------------------------# sub parse_uri { my $self = shift; my $file = shift; my $parse_options = $self->get_options(@_); $parse_options->{Source}{SystemId} = $file; return $self->parse($parse_options); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse_string(%options) #-------------------------------------------------------------------# sub parse_string { my $self = shift; my $string = shift; my $parse_options = $self->get_options(@_); $parse_options->{Source}{String} = $string; return $self->parse($parse_options); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_options #-------------------------------------------------------------------# sub get_options { my $self = shift; if (@_ == 1) { return { %$self, %{$_[0]} }; } else { return { %$self, @_ }; } } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_features #-------------------------------------------------------------------# sub get_features { return ( 'http://xml.org/sax/features/external-general-entities' => undef, 'http://xml.org/sax/features/external-parameter-entities' => undef, 'http://xml.org/sax/features/is-standalone' => undef, 'http://xml.org/sax/features/lexical-handler' => undef, 'http://xml.org/sax/features/parameter-entities' => undef, 'http://xml.org/sax/features/namespaces' => 1, 'http://xml.org/sax/features/namespace-prefixes' => 0, 'http://xml.org/sax/features/string-interning' => undef, 'http://xml.org/sax/features/use-attributes2' => undef, 'http://xml.org/sax/features/use-locator2' => undef, 'http://xml.org/sax/features/validation' => undef, 'http://xml.org/sax/properties/dom-node' => undef, 'http://xml.org/sax/properties/xml-string' => undef, ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_feature #-------------------------------------------------------------------# sub get_feature { my $self = shift; my $feat = shift; # check %FEATURES to see if it's there, and return it if so # throw XML::SAX::Exception::NotRecognized if it's not there # throw XML::SAX::Exception::NotSupported if it's there but we # don't support it my %features = $self->get_features(); if (exists $features{$feat}) { my %supported = map { $_ => 1 } $self->supported_features(); if ($supported{$feat}) { return $self->{__PACKAGE__ . "::Features"}{$feat}; } throw XML::SAX::Exception::NotSupported( Message => "The feature '$feat' is not supported by " . ref($self), Exception => undef, ); } throw XML::SAX::Exception::NotRecognized( Message => "The feature '$feat' is not recognized by " . ref($self), Exception => undef, ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # set_feature #-------------------------------------------------------------------# sub set_feature { my $self = shift; my $feat = shift; my $value = shift; # check %FEATURES to see if it's there, and set it if so # throw XML::SAX::Exception::NotRecognized if it's not there # throw XML::SAX::Exception::NotSupported if it's there but we # don't support it my %features = $self->get_features(); if (exists $features{$feat}) { my %supported = map { $_ => 1 } $self->supported_features(); if ($supported{$feat}) { return $self->{__PACKAGE__ . "::Features"}{$feat} = $value; } throw XML::SAX::Exception::NotSupported( Message => "The feature '$feat' is not supported by " . ref($self), Exception => undef, ); } throw XML::SAX::Exception::NotRecognized( Message => "The feature '$feat' is not recognized by " . ref($self), Exception => undef, ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_handler and friends #-------------------------------------------------------------------# sub get_handler { my $self = shift; my $handler_type = shift; $handler_type ||= 'Handler'; return defined( $self->{$handler_type} ) ? $self->{$handler_type} : undef; } sub get_document_handler { my $self = shift; return $self->get_handler('DocumentHandler', @_); } sub get_content_handler { my $self = shift; return $self->get_handler('ContentHandler', @_); } sub get_dtd_handler { my $self = shift; return $self->get_handler('DTDHandler', @_); } sub get_lexical_handler { my $self = shift; return $self->get_handler('LexicalHandler', @_); } sub get_decl_handler { my $self = shift; return $self->get_handler('DeclHandler', @_); } sub get_error_handler { my $self = shift; return $self->get_handler('ErrorHandler', @_); } sub get_entity_resolver { my $self = shift; return $self->get_handler('EntityResolver', @_); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # set_handler and friends #-------------------------------------------------------------------# sub set_handler { my $self = shift; my ($new_handler, $handler_type) = reverse @_; $handler_type ||= 'Handler'; $self->{Methods} = {} if $self->{Methods}; $self->{$handler_type} = $new_handler; $self->{ParseOptions}->{$handler_type} = $new_handler; return 1; } sub set_document_handler { my $self = shift; return $self->set_handler('DocumentHandler', @_); } sub set_content_handler { my $self = shift; return $self->set_handler('ContentHandler', @_); } sub set_dtd_handler { my $self = shift; return $self->set_handler('DTDHandler', @_); } sub set_lexical_handler { my $self = shift; return $self->set_handler('LexicalHandler', @_); } sub set_decl_handler { my $self = shift; return $self->set_handler('DeclHandler', @_); } sub set_error_handler { my $self = shift; return $self->set_handler('ErrorHandler', @_); } sub set_entity_resolver { my $self = shift; return $self->set_handler('EntityResolver', @_); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # supported_features #-------------------------------------------------------------------# sub supported_features { my $self = shift; # Only namespaces are required by all parsers return ( 'http://xml.org/sax/features/namespaces', ); } #-------------------------------------------------------------------# sub no_op { # this space intentionally blank } package XML::SAX::Base::NoHandler; # we need a fake handler that doesn't implement anything, this # simplifies the code a lot (though given the recent changes, # it may be better to do without) sub new { #warn "no handler called\n"; return bless {}; } 1; BODY $code .= "__END__\n"; $code .= <<'FOOTER'; =head1 NAME XML::SAX::Base - Base class SAX Drivers and Filters =head1 SYNOPSIS package MyFilter; use XML::SAX::Base; @ISA = ('XML::SAX::Base'); =head1 DESCRIPTION This module has a very simple task - to be a base class for PerlSAX drivers and filters. It's default behaviour is to pass the input directly to the output unchanged. It can be useful to use this module as a base class so you don't have to, for example, implement the characters() callback. The main advantages that it provides are easy dispatching of events the right way (ie it takes care for you of checking that the handler has implemented that method, or has defined an AUTOLOAD), and the guarantee that filters will pass along events that they aren't implementing to handlers downstream that might nevertheless be interested in them. =head1 WRITING SAX DRIVERS AND FILTERS The Perl Sax API Reference is at L<http://perl-xml.sourceforge.net/perl-sax/>. Writing SAX Filters is tremendously easy: all you need to do is inherit from this module, and define the events you want to handle. A more detailed explanation can be found at http://www.xml.com/pub/a/2001/10/10/sax-filters.html. Writing Drivers is equally simple. The one thing you need to pay attention to is B<NOT> to call events yourself (this applies to Filters as well). For instance: package MyFilter; use base qw(XML::SAX::Base); sub start_element { my $self = shift; my $data = shift; # do something $self->{Handler}->start_element($data); # BAD } The above example works well as precisely that: an example. But it has several faults: 1) it doesn't test to see whether the handler defines start_element. Perhaps it doesn't want to see that event, in which case you shouldn't throw it (otherwise it'll die). 2) it doesn't check ContentHandler and then Handler (ie it doesn't look to see that the user hasn't requested events on a specific handler, and if not on the default one), 3) if it did check all that, not only would the code be cumbersome (see this module's source to get an idea) but it would also probably have to check for a DocumentHandler (in case this were SAX1) and for AUTOLOADs potentially defined in all these packages. As you can tell, that would be fairly painful. Instead of going through that, simply remember to use code similar to the following instead: package MyFilter; use base qw(XML::SAX::Base); sub start_element { my $self = shift; my $data = shift; # do something to filter $self->SUPER::start_element($data); # GOOD (and easy) ! } This way, once you've done your job you hand the ball back to XML::SAX::Base and it takes care of all those problems for you! Note that the above example doesn't apply to filters only, drivers will benefit from the exact same feature. =head1 METHODS A number of methods are defined within this class for the purpose of inheritance. Some probably don't need to be overridden (eg parse_file) but some clearly should be (eg parse). Options for these methods are described in the PerlSAX2 specification available from http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/~checkout~/perl-xml/libxml-perl/doc/sax-2.0.html?rev=HEAD&content-type=text/html. =over 4 =item * parse The parse method is the main entry point to parsing documents. Internally the parse method will detect what type of "thing" you are parsing, and call the appropriate method in your implementation class. Here is the mapping table of what is in the Source options (see the Perl SAX 2.0 specification for the meaning of these values): Source Contains parse() calls =============== ============= CharacterStream (*) _parse_characterstream($stream, $options) ByteStream _parse_bytestream($stream, $options) String _parse_string($string, $options) SystemId _parse_systemid($string, $options) However note that these methods may not be sensible if your driver class is not for parsing XML. An example might be a DBI driver that generates XML/SAX from a database table. If that is the case, you likely want to write your own parse() method. Also note that the Source may contain both a PublicId entry, and an Encoding entry. To get at these, examine $options->{Source} as passed to your method. (*) A CharacterStream is a filehandle that does not need any encoding translation done on it. This is implemented as a regular filehandle and only works under Perl 5.7.2 or higher using PerlIO. To get a single character, or number of characters from it, use the perl core read() function. To get a single byte from it (or number of bytes), you can use sysread(). The encoding of the stream should be in the Encoding entry for the Source. =item * parse_file, parse_uri, parse_string These are all convenience variations on parse(), and in fact simply set up the options before calling it. You probably don't need to override these. =item * get_options This is a convenience method to get options in SAX2 style, or more generically either as hashes or as hashrefs (it returns a hashref). You will probably want to use this method in your own implementations of parse() and of new(). =item * get_feature, set_feature These simply get and set features, and throw the appropriate exceptions defined in the specification if need be. If your subclass defines features not defined in this one, then you should override these methods in such a way that they check for your features first, and then call the base class's methods for features not defined by your class. An example would be: sub get_feature { my $self = shift; my $feat = shift; if (exists $MY_FEATURES{$feat}) { # handle the feature in various ways } else { return $self->SUPER::get_feature($feat); } } Currently this part is unimplemented. =item * set_handler This method takes a handler type (Handler, ContentHandler, etc.) and a handler object as arguments, and changes the current handler for that handler type, while taking care of resetting the internal state that needs to be reset. This allows one to change a handler during parse without running into problems (changing it on the parser object directly will most likely cause trouble). =item * set_document_handler, set_content_handler, set_dtd_handler, set_lexical_handler, set_decl_handler, set_error_handler, set_entity_resolver These are just simple wrappers around the former method, and take a handler object as their argument. Internally they simply call set_handler with the correct arguments. =item * get_handler The inverse of set_handler, this method takes a an optional string containing a handler type (DTDHandler, ContentHandler, etc. 'Handler' is used if no type is passed). It returns a reference to the object that implements that class, or undef if that handler type is not set for the current driver/filter. =item * get_document_handler, get_content_handler, get_dtd_handler, get_lexical_handler, get_decl_handler, get_error_handler, get_entity_resolver These are just simple wrappers around the get_handler() method, and take no arguments. Internally they simply call get_handler with the correct handler type name. =back It would be rather useless to describe all the methods that this module implements here. They are all the methods supported in SAX1 and SAX2. In case your memory is a little short, here is a list. The apparent duplicates are there so that both versions of SAX can be supported. =over 4 =item * start_document =item * end_document =item * start_element =item * start_document =item * end_document =item * start_element =item * end_element =item * characters =item * processing_instruction =item * ignorable_whitespace =item * set_document_locator =item * start_prefix_mapping =item * end_prefix_mapping =item * skipped_entity =item * start_cdata =item * end_cdata =item * comment =item * entity_reference =item * notation_decl =item * unparsed_entity_decl =item * element_decl =item * attlist_decl =item * doctype_decl =item * xml_decl =item * entity_decl =item * attribute_decl =item * internal_entity_decl =item * external_entity_decl =item * resolve_entity =item * start_dtd =item * end_dtd =item * start_entity =item * end_entity =item * warning =item * error =item * fatal_error =back =head1 TODO - more tests - conform to the "SAX Filters" and "Java and DOM compatibility" sections of the SAX2 document. =head1 AUTHOR Kip Hampton (khampton@totalcinema.com) did most of the work, after porting it from XML::Filter::Base. Robin Berjon (robin@knowscape.com) pitched in with patches to make it usable as a base for drivers as well as filters, along with other patches. Matt Sergeant (matt@sergeant.org) wrote the original XML::Filter::Base, and patched a few things here and there, and imported it into the XML::SAX distribution. =head1 SEE ALSO L<XML::SAX> =cut FOOTER return $code; } sub write_xml_sax_base { confirm_forced_update(); my $path = File::Spec->catfile("lib", "XML", "SAX", "Base.pm"); save_original_xml_sax_base($path); my $code = build_xml_sax_base(); $code = add_version_stanzas($code); open my $fh, ">", $path or die "Cannot write $path: $!"; print $fh $code; close $fh or die "Error writing $path: $!"; print "Wrote $path\n"; } sub confirm_forced_update { return if grep { $_ eq '--force' } @ARGV; print <<'EOF'; *** WARNING *** The BuildSAXBase.pl script is used to generate the lib/XML/SAX/Base.pm file. However a pre-generated version of Base.pm is included in the distribution so you do not need to run this script unless you intend to modify the code. You must use the --force option to deliberately overwrite the distributed version of lib/XML/SAX/Base.pm EOF exit; } sub save_original_xml_sax_base { my($path) = @_; return unless -e $path; (my $save_path = $path) =~ s{Base}{Base-orig}; return if -e $save_path; print "Saving $path to $save_path\n"; rename($path, $save_path); } sub add_version_stanzas { my($code) = @_; my $version = get_xml_sax_base_version(); $code =~ s<^(package\s+(\w[:\w]+).*?\n)> <${1}BEGIN {\n \$${2}::VERSION = '$version';\n}\n>mg; return $code; } sub get_xml_sax_base_version { open my $fh, '<', 'dist.ini' or die "open(<dist.ini): $!"; while(<$fh>) { m{^\s*version\s*=\s*(\S+)} && return $1; } die "Failed to find version in dist.ini"; } perl5/XML/SAX/Base.pm 0000444 00000360025 14711217556 0010113 0 ustar 00 package XML::SAX::Base; $XML::SAX::Base::VERSION = '1.09'; # version 0.10 - Kip Hampton <khampton@totalcinema.com> # version 0.13 - Robin Berjon <robin@knowscape.com> # version 0.15 - Kip Hampton <khampton@totalcinema.com> # version 0.17 - Kip Hampton <khampton@totalcinema.com> # version 0.19 - Kip Hampton <khampton@totalcinema.com> # version 0.21 - Kip Hampton <khampton@totalcinema.com> # version 0.22 - Robin Berjon <robin@knowscape.com> # version 0.23 - Matt Sergeant <matt@sergeant.org> # version 0.24 - Robin Berjon <robin@knowscape.com> # version 0.25 - Kip Hampton <khampton@totalcinema.com> # version 1.00 - Kip Hampton <khampton@totalcinema.com> # version 1.01 - Kip Hampton <khampton@totalcinema.com> # version 1.02 - Robin Berjon <robin@knowscape.com> # version 1.03 - Matt Sergeant <matt@sergeant.org> # version 1.04 - Kip Hampton <khampton@totalcinema.com> # version 1.05 - Grant McLean <grantm@cpan.org> # version 1.06 - Grant McLean <grantm@cpan.org> # version 1.07 - Grant McLean <grantm@cpan.org> # version 1.08 - Grant McLean <grantm@cpan.org> #-----------------------------------------------------# # STOP!!!!! # # This file is generated by the 'BuildSAXBase.pl' file # that ships with the XML::SAX::Base distribution. # If you need to make changes, patch that file NOT # XML/SAX/Base.pm Better yet, fork the git repository # commit your changes and send a pull request: # https://github.com/grantm/XML-SAX-Base #-----------------------------------------------------# use strict; use XML::SAX::Exception qw(); sub end_entity { my $self = shift; if (defined $self->{Methods}->{'end_entity'}) { $self->{Methods}->{'end_entity'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_entity') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'end_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_entity') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->end_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'end_entity'} = sub { $handler->end_entity(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->end_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_entity'} = sub { $handler->end_entity(@_) }; } return $res; } else { $self->{Methods}->{'end_entity'} = sub { }; } } } sub set_document_locator { my $self = shift; if (defined $self->{Methods}->{'set_document_locator'}) { $self->{Methods}->{'set_document_locator'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('set_document_locator') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('set_document_locator') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('set_document_locator') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'set_document_locator'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->set_document_locator(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->set_document_locator(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->set_document_locator(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'set_document_locator'} = sub { $handler->set_document_locator(@_) }; } return $res; } else { $self->{Methods}->{'set_document_locator'} = sub { }; } } } sub notation_decl { my $self = shift; if (defined $self->{Methods}->{'notation_decl'}) { $self->{Methods}->{'notation_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('notation_decl') ) { my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'notation_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('notation_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'notation_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DTDHandler'} and $callbacks->{'DTDHandler'}->can('AUTOLOAD') and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DTDHandler'}->notation_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'notation_decl'} = sub { $handler->notation_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->notation_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'notation_decl'} = sub { $handler->notation_decl(@_) }; } return $res; } else { $self->{Methods}->{'notation_decl'} = sub { }; } } } sub attlist_decl { my $self = shift; if (defined $self->{Methods}->{'attlist_decl'}) { $self->{Methods}->{'attlist_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('attlist_decl') ) { my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'attlist_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('attlist_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'attlist_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DTDHandler'} and $callbacks->{'DTDHandler'}->can('AUTOLOAD') and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DTDHandler'}->attlist_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'attlist_decl'} = sub { $handler->attlist_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->attlist_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'attlist_decl'} = sub { $handler->attlist_decl(@_) }; } return $res; } else { $self->{Methods}->{'attlist_decl'} = sub { }; } } } sub fatal_error { my $self = shift; if (defined $self->{Methods}->{'fatal_error'}) { $self->{Methods}->{'fatal_error'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('fatal_error') ) { my $handler = $callbacks->{'ErrorHandler'}; $self->{Methods}->{'fatal_error'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('fatal_error') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'fatal_error'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ErrorHandler'} and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ErrorHandler'}->fatal_error(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ErrorHandler'}; $self->{Methods}->{'fatal_error'} = sub { $handler->fatal_error(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->fatal_error(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'fatal_error'} = sub { $handler->fatal_error(@_) }; } return $res; } else { $self->{Methods}->{'fatal_error'} = sub { }; } } } sub start_document { my $self = shift; if (defined $self->{Methods}->{'start_document'}) { $self->{Methods}->{'start_document'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_document') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_document') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_document') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_document'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->start_document(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->start_document(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->start_document(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_document'} = sub { $handler->start_document(@_) }; } return $res; } else { $self->{Methods}->{'start_document'} = sub { }; } } } sub warning { my $self = shift; if (defined $self->{Methods}->{'warning'}) { $self->{Methods}->{'warning'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('warning') ) { my $handler = $callbacks->{'ErrorHandler'}; $self->{Methods}->{'warning'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('warning') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'warning'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ErrorHandler'} and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ErrorHandler'}->warning(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ErrorHandler'}; $self->{Methods}->{'warning'} = sub { $handler->warning(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->warning(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'warning'} = sub { $handler->warning(@_) }; } return $res; } else { $self->{Methods}->{'warning'} = sub { }; } } } sub ignorable_whitespace { my $self = shift; if (defined $self->{Methods}->{'ignorable_whitespace'}) { $self->{Methods}->{'ignorable_whitespace'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('ignorable_whitespace') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('ignorable_whitespace') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('ignorable_whitespace') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'ignorable_whitespace'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->ignorable_whitespace(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->ignorable_whitespace(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->ignorable_whitespace(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'ignorable_whitespace'} = sub { $handler->ignorable_whitespace(@_) }; } return $res; } else { $self->{Methods}->{'ignorable_whitespace'} = sub { }; } } } sub resolve_entity { my $self = shift; if (defined $self->{Methods}->{'resolve_entity'}) { $self->{Methods}->{'resolve_entity'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'EntityResolver'} and $method = $callbacks->{'EntityResolver'}->can('resolve_entity') ) { my $handler = $callbacks->{'EntityResolver'}; $self->{Methods}->{'resolve_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('resolve_entity') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'resolve_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'EntityResolver'} and $callbacks->{'EntityResolver'}->can('AUTOLOAD') and $callbacks->{'EntityResolver'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'EntityResolver'}->resolve_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'EntityResolver'}; $self->{Methods}->{'resolve_entity'} = sub { $handler->resolve_entity(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->resolve_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'resolve_entity'} = sub { $handler->resolve_entity(@_) }; } return $res; } else { $self->{Methods}->{'resolve_entity'} = sub { }; } } } sub external_entity_decl { my $self = shift; if (defined $self->{Methods}->{'external_entity_decl'}) { $self->{Methods}->{'external_entity_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('external_entity_decl') ) { my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'external_entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('external_entity_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'external_entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DeclHandler'} and $callbacks->{'DeclHandler'}->can('AUTOLOAD') and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DeclHandler'}->external_entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'external_entity_decl'} = sub { $handler->external_entity_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->external_entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'external_entity_decl'} = sub { $handler->external_entity_decl(@_) }; } return $res; } else { $self->{Methods}->{'external_entity_decl'} = sub { }; } } } sub entity_reference { my $self = shift; if (defined $self->{Methods}->{'entity_reference'}) { $self->{Methods}->{'entity_reference'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('entity_reference') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'entity_reference'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('entity_reference') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'entity_reference'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->entity_reference(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'entity_reference'} = sub { $handler->entity_reference(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->entity_reference(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'entity_reference'} = sub { $handler->entity_reference(@_) }; } return $res; } else { $self->{Methods}->{'entity_reference'} = sub { }; } } } sub start_entity { my $self = shift; if (defined $self->{Methods}->{'start_entity'}) { $self->{Methods}->{'start_entity'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_entity') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'start_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_entity') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->start_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'start_entity'} = sub { $handler->start_entity(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->start_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_entity'} = sub { $handler->start_entity(@_) }; } return $res; } else { $self->{Methods}->{'start_entity'} = sub { }; } } } sub end_dtd { my $self = shift; if (defined $self->{Methods}->{'end_dtd'}) { $self->{Methods}->{'end_dtd'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_dtd') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'end_dtd'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_dtd') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_dtd'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->end_dtd(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'end_dtd'} = sub { $handler->end_dtd(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->end_dtd(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_dtd'} = sub { $handler->end_dtd(@_) }; } return $res; } else { $self->{Methods}->{'end_dtd'} = sub { }; } } } sub element_decl { my $self = shift; if (defined $self->{Methods}->{'element_decl'}) { $self->{Methods}->{'element_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('element_decl') ) { my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'element_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('element_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'element_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DeclHandler'} and $callbacks->{'DeclHandler'}->can('AUTOLOAD') and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DeclHandler'}->element_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'element_decl'} = sub { $handler->element_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->element_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'element_decl'} = sub { $handler->element_decl(@_) }; } return $res; } else { $self->{Methods}->{'element_decl'} = sub { }; } } } sub start_element { my $self = shift; if (defined $self->{Methods}->{'start_element'}) { $self->{Methods}->{'start_element'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_element') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_element') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_element') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_element'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->start_element(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->start_element(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->start_element(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_element'} = sub { $handler->start_element(@_) }; } return $res; } else { $self->{Methods}->{'start_element'} = sub { }; } } } sub error { my $self = shift; if (defined $self->{Methods}->{'error'}) { $self->{Methods}->{'error'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ErrorHandler'} and $method = $callbacks->{'ErrorHandler'}->can('error') ) { my $handler = $callbacks->{'ErrorHandler'}; $self->{Methods}->{'error'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('error') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'error'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ErrorHandler'} and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') and $callbacks->{'ErrorHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ErrorHandler'}->error(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ErrorHandler'}; $self->{Methods}->{'error'} = sub { $handler->error(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->error(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'error'} = sub { $handler->error(@_) }; } return $res; } else { $self->{Methods}->{'error'} = sub { }; } } } sub xml_decl { my $self = shift; if (defined $self->{Methods}->{'xml_decl'}) { $self->{Methods}->{'xml_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('xml_decl') ) { my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'xml_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('xml_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'xml_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DTDHandler'} and $callbacks->{'DTDHandler'}->can('AUTOLOAD') and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DTDHandler'}->xml_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'xml_decl'} = sub { $handler->xml_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->xml_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'xml_decl'} = sub { $handler->xml_decl(@_) }; } return $res; } else { $self->{Methods}->{'xml_decl'} = sub { }; } } } sub end_document { my $self = shift; if (defined $self->{Methods}->{'end_document'}) { $self->{Methods}->{'end_document'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_document') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_document') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_document') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_document'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->end_document(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->end_document(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->end_document(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_document'} = sub { $handler->end_document(@_) }; } return $res; } else { $self->{Methods}->{'end_document'} = sub { }; } } } sub attribute_decl { my $self = shift; if (defined $self->{Methods}->{'attribute_decl'}) { $self->{Methods}->{'attribute_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('attribute_decl') ) { my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'attribute_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('attribute_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'attribute_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DeclHandler'} and $callbacks->{'DeclHandler'}->can('AUTOLOAD') and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DeclHandler'}->attribute_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'attribute_decl'} = sub { $handler->attribute_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->attribute_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'attribute_decl'} = sub { $handler->attribute_decl(@_) }; } return $res; } else { $self->{Methods}->{'attribute_decl'} = sub { }; } } } sub internal_entity_decl { my $self = shift; if (defined $self->{Methods}->{'internal_entity_decl'}) { $self->{Methods}->{'internal_entity_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DeclHandler'} and $method = $callbacks->{'DeclHandler'}->can('internal_entity_decl') ) { my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'internal_entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('internal_entity_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'internal_entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DeclHandler'} and $callbacks->{'DeclHandler'}->can('AUTOLOAD') and $callbacks->{'DeclHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DeclHandler'}->internal_entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DeclHandler'}; $self->{Methods}->{'internal_entity_decl'} = sub { $handler->internal_entity_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->internal_entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'internal_entity_decl'} = sub { $handler->internal_entity_decl(@_) }; } return $res; } else { $self->{Methods}->{'internal_entity_decl'} = sub { }; } } } sub doctype_decl { my $self = shift; if (defined $self->{Methods}->{'doctype_decl'}) { $self->{Methods}->{'doctype_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('doctype_decl') ) { my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'doctype_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('doctype_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'doctype_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DTDHandler'} and $callbacks->{'DTDHandler'}->can('AUTOLOAD') and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DTDHandler'}->doctype_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'doctype_decl'} = sub { $handler->doctype_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->doctype_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'doctype_decl'} = sub { $handler->doctype_decl(@_) }; } return $res; } else { $self->{Methods}->{'doctype_decl'} = sub { }; } } } sub unparsed_entity_decl { my $self = shift; if (defined $self->{Methods}->{'unparsed_entity_decl'}) { $self->{Methods}->{'unparsed_entity_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('unparsed_entity_decl') ) { my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'unparsed_entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('unparsed_entity_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'unparsed_entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DTDHandler'} and $callbacks->{'DTDHandler'}->can('AUTOLOAD') and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DTDHandler'}->unparsed_entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'unparsed_entity_decl'} = sub { $handler->unparsed_entity_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->unparsed_entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'unparsed_entity_decl'} = sub { $handler->unparsed_entity_decl(@_) }; } return $res; } else { $self->{Methods}->{'unparsed_entity_decl'} = sub { }; } } } sub skipped_entity { my $self = shift; if (defined $self->{Methods}->{'skipped_entity'}) { $self->{Methods}->{'skipped_entity'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('skipped_entity') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'skipped_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('skipped_entity') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'skipped_entity'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->skipped_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'skipped_entity'} = sub { $handler->skipped_entity(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->skipped_entity(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'skipped_entity'} = sub { $handler->skipped_entity(@_) }; } return $res; } else { $self->{Methods}->{'skipped_entity'} = sub { }; } } } sub end_prefix_mapping { my $self = shift; if (defined $self->{Methods}->{'end_prefix_mapping'}) { $self->{Methods}->{'end_prefix_mapping'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_prefix_mapping') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'end_prefix_mapping'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_prefix_mapping') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_prefix_mapping'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->end_prefix_mapping(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'end_prefix_mapping'} = sub { $handler->end_prefix_mapping(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->end_prefix_mapping(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_prefix_mapping'} = sub { $handler->end_prefix_mapping(@_) }; } return $res; } else { $self->{Methods}->{'end_prefix_mapping'} = sub { }; } } } sub characters { my $self = shift; if (defined $self->{Methods}->{'characters'}) { $self->{Methods}->{'characters'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('characters') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'characters'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('characters') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'characters'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('characters') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'characters'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->characters(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'characters'} = sub { $handler->characters(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->characters(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'characters'} = sub { $handler->characters(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->characters(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'characters'} = sub { $handler->characters(@_) }; } return $res; } else { $self->{Methods}->{'characters'} = sub { }; } } } sub comment { my $self = shift; if (defined $self->{Methods}->{'comment'}) { $self->{Methods}->{'comment'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('comment') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'comment'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('comment') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'comment'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('comment') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'comment'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->comment(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'comment'} = sub { $handler->comment(@_) }; } return $res; } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->comment(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'comment'} = sub { $handler->comment(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->comment(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'comment'} = sub { $handler->comment(@_) }; } return $res; } else { $self->{Methods}->{'comment'} = sub { }; } } } sub start_dtd { my $self = shift; if (defined $self->{Methods}->{'start_dtd'}) { $self->{Methods}->{'start_dtd'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_dtd') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'start_dtd'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_dtd') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_dtd'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->start_dtd(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'start_dtd'} = sub { $handler->start_dtd(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->start_dtd(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_dtd'} = sub { $handler->start_dtd(@_) }; } return $res; } else { $self->{Methods}->{'start_dtd'} = sub { }; } } } sub entity_decl { my $self = shift; if (defined $self->{Methods}->{'entity_decl'}) { $self->{Methods}->{'entity_decl'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DTDHandler'} and $method = $callbacks->{'DTDHandler'}->can('entity_decl') ) { my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('entity_decl') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'entity_decl'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DTDHandler'} and $callbacks->{'DTDHandler'}->can('AUTOLOAD') and $callbacks->{'DTDHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DTDHandler'}->entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DTDHandler'}; $self->{Methods}->{'entity_decl'} = sub { $handler->entity_decl(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->entity_decl(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'entity_decl'} = sub { $handler->entity_decl(@_) }; } return $res; } else { $self->{Methods}->{'entity_decl'} = sub { }; } } } sub start_prefix_mapping { my $self = shift; if (defined $self->{Methods}->{'start_prefix_mapping'}) { $self->{Methods}->{'start_prefix_mapping'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('start_prefix_mapping') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'start_prefix_mapping'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_prefix_mapping') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_prefix_mapping'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->start_prefix_mapping(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'start_prefix_mapping'} = sub { $handler->start_prefix_mapping(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->start_prefix_mapping(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_prefix_mapping'} = sub { $handler->start_prefix_mapping(@_) }; } return $res; } else { $self->{Methods}->{'start_prefix_mapping'} = sub { }; } } } sub end_cdata { my $self = shift; if (defined $self->{Methods}->{'end_cdata'}) { $self->{Methods}->{'end_cdata'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_cdata') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('end_cdata') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_cdata') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_cdata'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->end_cdata(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) }; } return $res; } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->end_cdata(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->end_cdata(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_cdata'} = sub { $handler->end_cdata(@_) }; } return $res; } else { $self->{Methods}->{'end_cdata'} = sub { }; } } } sub processing_instruction { my $self = shift; if (defined $self->{Methods}->{'processing_instruction'}) { $self->{Methods}->{'processing_instruction'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('processing_instruction') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('processing_instruction') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('processing_instruction') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'processing_instruction'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->processing_instruction(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->processing_instruction(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->processing_instruction(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'processing_instruction'} = sub { $handler->processing_instruction(@_) }; } return $res; } else { $self->{Methods}->{'processing_instruction'} = sub { }; } } } sub end_element { my $self = shift; if (defined $self->{Methods}->{'end_element'}) { $self->{Methods}->{'end_element'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'ContentHandler'} and $method = $callbacks->{'ContentHandler'}->can('end_element') ) { my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('end_element') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('end_element') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_element'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'ContentHandler'} and $callbacks->{'ContentHandler'}->can('AUTOLOAD') and $callbacks->{'ContentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'ContentHandler'}->end_element(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'ContentHandler'}; $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) }; } return $res; } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->end_element(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->end_element(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'end_element'} = sub { $handler->end_element(@_) }; } return $res; } else { $self->{Methods}->{'end_element'} = sub { }; } } } sub start_cdata { my $self = shift; if (defined $self->{Methods}->{'start_cdata'}) { $self->{Methods}->{'start_cdata'}->(@_); } else { my $method; my $callbacks; if (exists $self->{ParseOptions}) { $callbacks = $self->{ParseOptions}; } else { $callbacks = $self; } if (0) { # dummy to make elsif's below compile } elsif (defined $callbacks->{'DocumentHandler'} and $method = $callbacks->{'DocumentHandler'}->can('start_cdata') ) { my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'LexicalHandler'} and $method = $callbacks->{'LexicalHandler'}->can('start_cdata') ) { my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'Handler'} and $method = $callbacks->{'Handler'}->can('start_cdata') ) { my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_cdata'} = sub { $method->($handler, @_) }; return $method->($handler, @_); } elsif (defined $callbacks->{'DocumentHandler'} and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') and $callbacks->{'DocumentHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'DocumentHandler'}->start_cdata(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'DocumentHandler'}; $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) }; } return $res; } elsif (defined $callbacks->{'LexicalHandler'} and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') and $callbacks->{'LexicalHandler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'LexicalHandler'}->start_cdata(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'LexicalHandler'}; $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) }; } return $res; } elsif (defined $callbacks->{'Handler'} and $callbacks->{'Handler'}->can('AUTOLOAD') and $callbacks->{'Handler'}->can('AUTOLOAD') ne (UNIVERSAL->can('AUTOLOAD') || '') ) { my $res = eval { $callbacks->{'Handler'}->start_cdata(@_) }; if ($@) { die $@; } else { # I think there's a buggette here... # if the first call throws an exception, we don't set it up right. # Not fatal, but we might want to address it. my $handler = $callbacks->{'Handler'}; $self->{Methods}->{'start_cdata'} = sub { $handler->start_cdata(@_) }; } return $res; } else { $self->{Methods}->{'start_cdata'} = sub { }; } } } #-------------------------------------------------------------------# # Class->new(%options) #-------------------------------------------------------------------# sub new { my $proto = shift; my $class = ref($proto) || $proto; my $options = ($#_ == 0) ? shift : { @_ }; unless ( defined( $options->{Handler} ) or defined( $options->{ContentHandler} ) or defined( $options->{DTDHandler} ) or defined( $options->{DocumentHandler} ) or defined( $options->{LexicalHandler} ) or defined( $options->{ErrorHandler} ) or defined( $options->{DeclHandler} ) ) { $options->{Handler} = XML::SAX::Base::NoHandler->new; } my $self = bless $options, $class; # turn NS processing on by default $self->set_feature('http://xml.org/sax/features/namespaces', 1); return $self; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse(%options) #-------------------------------------------------------------------# sub parse { my $self = shift; my $parse_options = $self->get_options(@_); local $self->{ParseOptions} = $parse_options; if ($self->{Parent}) { # calling parse on a filter for some reason return $self->{Parent}->parse($parse_options); } else { my $method; if (defined $parse_options->{Source}{CharacterStream} and $method = $self->can('_parse_characterstream')) { warn("parse charstream???\n"); return $method->($self, $parse_options->{Source}{CharacterStream}); } elsif (defined $parse_options->{Source}{ByteStream} and $method = $self->can('_parse_bytestream')) { return $method->($self, $parse_options->{Source}{ByteStream}); } elsif (defined $parse_options->{Source}{String} and $method = $self->can('_parse_string')) { return $method->($self, $parse_options->{Source}{String}); } elsif (defined $parse_options->{Source}{SystemId} and $method = $self->can('_parse_systemid')) { return $method->($self, $parse_options->{Source}{SystemId}); } else { die "No _parse_* routine defined on this driver (If it is a filter, remember to set the Parent property. If you call the parse() method, make sure to set a Source. You may want to call parse_uri, parse_string or parse_file instead.) [$self]"; } } } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse_file(%options) #-------------------------------------------------------------------# sub parse_file { my $self = shift; my $file = shift; return $self->parse_uri($file, @_) if ref(\$file) eq 'SCALAR'; my $parse_options = $self->get_options(@_); $parse_options->{Source}{ByteStream} = $file; return $self->parse($parse_options); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse_uri(%options) #-------------------------------------------------------------------# sub parse_uri { my $self = shift; my $file = shift; my $parse_options = $self->get_options(@_); $parse_options->{Source}{SystemId} = $file; return $self->parse($parse_options); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->parse_string(%options) #-------------------------------------------------------------------# sub parse_string { my $self = shift; my $string = shift; my $parse_options = $self->get_options(@_); $parse_options->{Source}{String} = $string; return $self->parse($parse_options); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_options #-------------------------------------------------------------------# sub get_options { my $self = shift; if (@_ == 1) { return { %$self, %{$_[0]} }; } else { return { %$self, @_ }; } } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_features #-------------------------------------------------------------------# sub get_features { return ( 'http://xml.org/sax/features/external-general-entities' => undef, 'http://xml.org/sax/features/external-parameter-entities' => undef, 'http://xml.org/sax/features/is-standalone' => undef, 'http://xml.org/sax/features/lexical-handler' => undef, 'http://xml.org/sax/features/parameter-entities' => undef, 'http://xml.org/sax/features/namespaces' => 1, 'http://xml.org/sax/features/namespace-prefixes' => 0, 'http://xml.org/sax/features/string-interning' => undef, 'http://xml.org/sax/features/use-attributes2' => undef, 'http://xml.org/sax/features/use-locator2' => undef, 'http://xml.org/sax/features/validation' => undef, 'http://xml.org/sax/properties/dom-node' => undef, 'http://xml.org/sax/properties/xml-string' => undef, ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_feature #-------------------------------------------------------------------# sub get_feature { my $self = shift; my $feat = shift; # check %FEATURES to see if it's there, and return it if so # throw XML::SAX::Exception::NotRecognized if it's not there # throw XML::SAX::Exception::NotSupported if it's there but we # don't support it my %features = $self->get_features(); if (exists $features{$feat}) { my %supported = map { $_ => 1 } $self->supported_features(); if ($supported{$feat}) { return $self->{__PACKAGE__ . "::Features"}{$feat}; } throw XML::SAX::Exception::NotSupported( Message => "The feature '$feat' is not supported by " . ref($self), Exception => undef, ); } throw XML::SAX::Exception::NotRecognized( Message => "The feature '$feat' is not recognized by " . ref($self), Exception => undef, ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # set_feature #-------------------------------------------------------------------# sub set_feature { my $self = shift; my $feat = shift; my $value = shift; # check %FEATURES to see if it's there, and set it if so # throw XML::SAX::Exception::NotRecognized if it's not there # throw XML::SAX::Exception::NotSupported if it's there but we # don't support it my %features = $self->get_features(); if (exists $features{$feat}) { my %supported = map { $_ => 1 } $self->supported_features(); if ($supported{$feat}) { return $self->{__PACKAGE__ . "::Features"}{$feat} = $value; } throw XML::SAX::Exception::NotSupported( Message => "The feature '$feat' is not supported by " . ref($self), Exception => undef, ); } throw XML::SAX::Exception::NotRecognized( Message => "The feature '$feat' is not recognized by " . ref($self), Exception => undef, ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # get_handler and friends #-------------------------------------------------------------------# sub get_handler { my $self = shift; my $handler_type = shift; $handler_type ||= 'Handler'; return defined( $self->{$handler_type} ) ? $self->{$handler_type} : undef; } sub get_document_handler { my $self = shift; return $self->get_handler('DocumentHandler', @_); } sub get_content_handler { my $self = shift; return $self->get_handler('ContentHandler', @_); } sub get_dtd_handler { my $self = shift; return $self->get_handler('DTDHandler', @_); } sub get_lexical_handler { my $self = shift; return $self->get_handler('LexicalHandler', @_); } sub get_decl_handler { my $self = shift; return $self->get_handler('DeclHandler', @_); } sub get_error_handler { my $self = shift; return $self->get_handler('ErrorHandler', @_); } sub get_entity_resolver { my $self = shift; return $self->get_handler('EntityResolver', @_); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # set_handler and friends #-------------------------------------------------------------------# sub set_handler { my $self = shift; my ($new_handler, $handler_type) = reverse @_; $handler_type ||= 'Handler'; $self->{Methods} = {} if $self->{Methods}; $self->{$handler_type} = $new_handler; $self->{ParseOptions}->{$handler_type} = $new_handler; return 1; } sub set_document_handler { my $self = shift; return $self->set_handler('DocumentHandler', @_); } sub set_content_handler { my $self = shift; return $self->set_handler('ContentHandler', @_); } sub set_dtd_handler { my $self = shift; return $self->set_handler('DTDHandler', @_); } sub set_lexical_handler { my $self = shift; return $self->set_handler('LexicalHandler', @_); } sub set_decl_handler { my $self = shift; return $self->set_handler('DeclHandler', @_); } sub set_error_handler { my $self = shift; return $self->set_handler('ErrorHandler', @_); } sub set_entity_resolver { my $self = shift; return $self->set_handler('EntityResolver', @_); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # supported_features #-------------------------------------------------------------------# sub supported_features { my $self = shift; # Only namespaces are required by all parsers return ( 'http://xml.org/sax/features/namespaces', ); } #-------------------------------------------------------------------# sub no_op { # this space intentionally blank } package XML::SAX::Base::NoHandler; $XML::SAX::Base::NoHandler::VERSION = '1.09'; # we need a fake handler that doesn't implement anything, this # simplifies the code a lot (though given the recent changes, # it may be better to do without) sub new { #warn "no handler called\n"; return bless {}; } 1; __END__ =head1 NAME XML::SAX::Base - Base class SAX Drivers and Filters =head1 SYNOPSIS package MyFilter; use XML::SAX::Base; @ISA = ('XML::SAX::Base'); =head1 DESCRIPTION This module has a very simple task - to be a base class for PerlSAX drivers and filters. It's default behaviour is to pass the input directly to the output unchanged. It can be useful to use this module as a base class so you don't have to, for example, implement the characters() callback. The main advantages that it provides are easy dispatching of events the right way (ie it takes care for you of checking that the handler has implemented that method, or has defined an AUTOLOAD), and the guarantee that filters will pass along events that they aren't implementing to handlers downstream that might nevertheless be interested in them. =head1 WRITING SAX DRIVERS AND FILTERS The Perl Sax API Reference is at L<http://perl-xml.sourceforge.net/perl-sax/>. Writing SAX Filters is tremendously easy: all you need to do is inherit from this module, and define the events you want to handle. A more detailed explanation can be found at http://www.xml.com/pub/a/2001/10/10/sax-filters.html. Writing Drivers is equally simple. The one thing you need to pay attention to is B<NOT> to call events yourself (this applies to Filters as well). For instance: package MyFilter; use base qw(XML::SAX::Base); sub start_element { my $self = shift; my $data = shift; # do something $self->{Handler}->start_element($data); # BAD } The above example works well as precisely that: an example. But it has several faults: 1) it doesn't test to see whether the handler defines start_element. Perhaps it doesn't want to see that event, in which case you shouldn't throw it (otherwise it'll die). 2) it doesn't check ContentHandler and then Handler (ie it doesn't look to see that the user hasn't requested events on a specific handler, and if not on the default one), 3) if it did check all that, not only would the code be cumbersome (see this module's source to get an idea) but it would also probably have to check for a DocumentHandler (in case this were SAX1) and for AUTOLOADs potentially defined in all these packages. As you can tell, that would be fairly painful. Instead of going through that, simply remember to use code similar to the following instead: package MyFilter; use base qw(XML::SAX::Base); sub start_element { my $self = shift; my $data = shift; # do something to filter $self->SUPER::start_element($data); # GOOD (and easy) ! } This way, once you've done your job you hand the ball back to XML::SAX::Base and it takes care of all those problems for you! Note that the above example doesn't apply to filters only, drivers will benefit from the exact same feature. =head1 METHODS A number of methods are defined within this class for the purpose of inheritance. Some probably don't need to be overridden (eg parse_file) but some clearly should be (eg parse). Options for these methods are described in the PerlSAX2 specification available from http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/~checkout~/perl-xml/libxml-perl/doc/sax-2.0.html?rev=HEAD&content-type=text/html. =over 4 =item * parse The parse method is the main entry point to parsing documents. Internally the parse method will detect what type of "thing" you are parsing, and call the appropriate method in your implementation class. Here is the mapping table of what is in the Source options (see the Perl SAX 2.0 specification for the meaning of these values): Source Contains parse() calls =============== ============= CharacterStream (*) _parse_characterstream($stream, $options) ByteStream _parse_bytestream($stream, $options) String _parse_string($string, $options) SystemId _parse_systemid($string, $options) However note that these methods may not be sensible if your driver class is not for parsing XML. An example might be a DBI driver that generates XML/SAX from a database table. If that is the case, you likely want to write your own parse() method. Also note that the Source may contain both a PublicId entry, and an Encoding entry. To get at these, examine $options->{Source} as passed to your method. (*) A CharacterStream is a filehandle that does not need any encoding translation done on it. This is implemented as a regular filehandle and only works under Perl 5.7.2 or higher using PerlIO. To get a single character, or number of characters from it, use the perl core read() function. To get a single byte from it (or number of bytes), you can use sysread(). The encoding of the stream should be in the Encoding entry for the Source. =item * parse_file, parse_uri, parse_string These are all convenience variations on parse(), and in fact simply set up the options before calling it. You probably don't need to override these. =item * get_options This is a convenience method to get options in SAX2 style, or more generically either as hashes or as hashrefs (it returns a hashref). You will probably want to use this method in your own implementations of parse() and of new(). =item * get_feature, set_feature These simply get and set features, and throw the appropriate exceptions defined in the specification if need be. If your subclass defines features not defined in this one, then you should override these methods in such a way that they check for your features first, and then call the base class's methods for features not defined by your class. An example would be: sub get_feature { my $self = shift; my $feat = shift; if (exists $MY_FEATURES{$feat}) { # handle the feature in various ways } else { return $self->SUPER::get_feature($feat); } } Currently this part is unimplemented. =item * set_handler This method takes a handler type (Handler, ContentHandler, etc.) and a handler object as arguments, and changes the current handler for that handler type, while taking care of resetting the internal state that needs to be reset. This allows one to change a handler during parse without running into problems (changing it on the parser object directly will most likely cause trouble). =item * set_document_handler, set_content_handler, set_dtd_handler, set_lexical_handler, set_decl_handler, set_error_handler, set_entity_resolver These are just simple wrappers around the former method, and take a handler object as their argument. Internally they simply call set_handler with the correct arguments. =item * get_handler The inverse of set_handler, this method takes a an optional string containing a handler type (DTDHandler, ContentHandler, etc. 'Handler' is used if no type is passed). It returns a reference to the object that implements that class, or undef if that handler type is not set for the current driver/filter. =item * get_document_handler, get_content_handler, get_dtd_handler, get_lexical_handler, get_decl_handler, get_error_handler, get_entity_resolver These are just simple wrappers around the get_handler() method, and take no arguments. Internally they simply call get_handler with the correct handler type name. =back It would be rather useless to describe all the methods that this module implements here. They are all the methods supported in SAX1 and SAX2. In case your memory is a little short, here is a list. The apparent duplicates are there so that both versions of SAX can be supported. =over 4 =item * start_document =item * end_document =item * start_element =item * start_document =item * end_document =item * start_element =item * end_element =item * characters =item * processing_instruction =item * ignorable_whitespace =item * set_document_locator =item * start_prefix_mapping =item * end_prefix_mapping =item * skipped_entity =item * start_cdata =item * end_cdata =item * comment =item * entity_reference =item * notation_decl =item * unparsed_entity_decl =item * element_decl =item * attlist_decl =item * doctype_decl =item * xml_decl =item * entity_decl =item * attribute_decl =item * internal_entity_decl =item * external_entity_decl =item * resolve_entity =item * start_dtd =item * end_dtd =item * start_entity =item * end_entity =item * warning =item * error =item * fatal_error =back =head1 TODO - more tests - conform to the "SAX Filters" and "Java and DOM compatibility" sections of the SAX2 document. =head1 AUTHOR Kip Hampton (khampton@totalcinema.com) did most of the work, after porting it from XML::Filter::Base. Robin Berjon (robin@knowscape.com) pitched in with patches to make it usable as a base for drivers as well as filters, along with other patches. Matt Sergeant (matt@sergeant.org) wrote the original XML::Filter::Base, and patched a few things here and there, and imported it into the XML::SAX distribution. =head1 SEE ALSO L<XML::SAX> =cut perl5/XML/SAX/DocumentLocator.pm 0000444 00000005502 14711217564 0012336 0 ustar 00 # $Id$ package XML::SAX::DocumentLocator; use strict; sub new { my $class = shift; my %object; tie %object, $class, @_; return bless \%object, $class; } sub TIEHASH { my $class = shift; my ($pubmeth, $sysmeth, $linemeth, $colmeth, $encmeth, $xmlvmeth) = @_; return bless { pubmeth => $pubmeth, sysmeth => $sysmeth, linemeth => $linemeth, colmeth => $colmeth, encmeth => $encmeth, xmlvmeth => $xmlvmeth, }, $class; } sub FETCH { my ($self, $key) = @_; my $method; if ($key eq 'PublicId') { $method = $self->{pubmeth}; } elsif ($key eq 'SystemId') { $method = $self->{sysmeth}; } elsif ($key eq 'LineNumber') { $method = $self->{linemeth}; } elsif ($key eq 'ColumnNumber') { $method = $self->{colmeth}; } elsif ($key eq 'Encoding') { $method = $self->{encmeth}; } elsif ($key eq 'XMLVersion') { $method = $self->{xmlvmeth}; } if ($method) { my $value = $method->($key); return $value; } return undef; } sub EXISTS { my ($self, $key) = @_; if ($key =~ /^(PublicId|SystemId|LineNumber|ColumnNumber|Encoding|XMLVersion)$/) { return 1; } return 0; } sub STORE { my ($self, $key, $value) = @_; } sub DELETE { my ($self, $key) = @_; } sub CLEAR { my ($self) = @_; } sub FIRSTKEY { my ($self) = @_; # assignment resets. $self->{keys} = { PublicId => 1, SystemId => 1, LineNumber => 1, ColumnNumber => 1, Encoding => 1, XMLVersion => 1, }; return each %{$self->{keys}}; } sub NEXTKEY { my ($self, $lastkey) = @_; return each %{$self->{keys}}; } 1; __END__ =head1 NAME XML::SAX::DocumentLocator - Helper class for document locators =head1 SYNOPSIS my $locator = XML::SAX::DocumentLocator->new( sub { $object->get_public_id }, sub { $object->get_system_id }, sub { $reader->current_line }, sub { $reader->current_column }, sub { $reader->get_encoding }, sub { $reader->get_xml_version }, ); =head1 DESCRIPTION This module gives you a tied hash reference that calls the specified closures when asked for PublicId, SystemId, LineNumber and ColumnNumber. It is useful for writing SAX Parsers so that you don't have to constantly update the line numbers in a hash reference on the object you pass to set_document_locator(). See the source code for XML::SAX::PurePerl for a usage example. =head1 API There is only 1 method: C<new>. Simply pass it a list of closures that when called will return the PublicId, the SystemId, the LineNumber, the ColumnNumber, the Encoding and the XMLVersion respectively. The closures are passed a single parameter, the key being requested. But you're free to ignore that. =cut perl5/XML/SAX/PurePerl/Productions.pm 0000444 00000014737 14711217565 0013316 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Productions; use Exporter; @ISA = ('Exporter'); @EXPORT_OK = qw($S $Char $VersionNum $BaseChar $Ideographic $Extender $Digit $CombiningChar $EncNameStart $EncNameEnd $NameChar $CharMinusDash $PubidChar $Any $SingleChar); ### WARNING!!! All productions here must *only* match a *single* character!!! ### BEGIN { $S = qr/[\x20\x09\x0D\x0A]/; $CharMinusDash = qr/[^-]/x; $Any = qr/ . /xms; $VersionNum = qr/ [a-zA-Z0-9_.:-]+ /x; $EncNameStart = qr/ [A-Za-z] /x; $EncNameEnd = qr/ [A-Za-z0-9\._-] /x; $PubidChar = qr/ [\x20\x0D\x0Aa-zA-Z0-9'()\+,.\/:=\?;!*\#@\$_\%-] /x; if ($] < 5.006) { eval <<' PERL'; $Char = qr/^ [\x09\x0A\x0D\x20-\x7F]|([\xC0-\xFD][\x80-\xBF]+) $/x; $SingleChar = qr/^$Char$/; $BaseChar = qr/ [\x41-\x5A\x61-\x7A]|([\xC0-\xFD][\x80-\xBF]+) /x; $Extender = qr/ \xB7 /x; $Digit = qr/ [\x30-\x39] /x; # can't do this one without unicode # $CombiningChar = qr/^$/msx; $NameChar = qr/^ (?: $BaseChar | $Digit | [._:-] | $Extender )+ $/x; PERL die $@ if $@; } else { eval <<' PERL'; use utf8; # for 5.6 $Char = qr/^ [\x09\x0A\x0D\x{0020}-\x{D7FF}\x{E000}-\x{FFFD}\x{10000}-\x{10FFFF}] $/x; $SingleChar = qr/^$Char$/; $BaseChar = qr/ [\x{0041}-\x{005A}\x{0061}-\x{007A}\x{00C0}-\x{00D6}\x{00D8}-\x{00F6}] | [\x{00F8}-\x{00FF}\x{0100}-\x{0131}\x{0134}-\x{013E}\x{0141}-\x{0148}] | [\x{014A}-\x{017E}\x{0180}-\x{01C3}\x{01CD}-\x{01F0}\x{01F4}-\x{01F5}] | [\x{01FA}-\x{0217}\x{0250}-\x{02A8}\x{02BB}-\x{02C1}\x{0386}\x{0388}-\x{038A}] | [\x{038C}\x{038E}-\x{03A1}\x{03A3}-\x{03CE}\x{03D0}-\x{03D6}\x{03DA}] | [\x{03DC}\x{03DE}\x{03E0}\x{03E2}-\x{03F3}\x{0401}-\x{040C}\x{040E}-\x{044F}] | [\x{0451}-\x{045C}\x{045E}-\x{0481}\x{0490}-\x{04C4}\x{04C7}-\x{04C8}] | [\x{04CB}-\x{04CC}\x{04D0}-\x{04EB}\x{04EE}-\x{04F5}\x{04F8}-\x{04F9}] | [\x{0531}-\x{0556}\x{0559}\x{0561}-\x{0586}\x{05D0}-\x{05EA}\x{05F0}-\x{05F2}] | [\x{0621}-\x{063A}\x{0641}-\x{064A}\x{0671}-\x{06B7}\x{06BA}-\x{06BE}] | [\x{06C0}-\x{06CE}\x{06D0}-\x{06D3}\x{06D5}\x{06E5}-\x{06E6}\x{0905}-\x{0939}] | [\x{093D}\x{0958}-\x{0961}\x{0985}-\x{098C}\x{098F}-\x{0990}] | [\x{0993}-\x{09A8}\x{09AA}-\x{09B0}\x{09B2}\x{09B6}-\x{09B9}\x{09DC}-\x{09DD}] | [\x{09DF}-\x{09E1}\x{09F0}-\x{09F1}\x{0A05}-\x{0A0A}\x{0A0F}-\x{0A10}] | [\x{0A13}-\x{0A28}\x{0A2A}-\x{0A30}\x{0A32}-\x{0A33}\x{0A35}-\x{0A36}] | [\x{0A38}-\x{0A39}\x{0A59}-\x{0A5C}\x{0A5E}\x{0A72}-\x{0A74}\x{0A85}-\x{0A8B}] | [\x{0A8D}\x{0A8F}-\x{0A91}\x{0A93}-\x{0AA8}\x{0AAA}-\x{0AB0}] | [\x{0AB2}-\x{0AB3}\x{0AB5}-\x{0AB9}\x{0ABD}\x{0AE0}\x{0B05}-\x{0B0C}] | [\x{0B0F}-\x{0B10}\x{0B13}-\x{0B28}\x{0B2A}-\x{0B30}\x{0B32}-\x{0B33}] | [\x{0B36}-\x{0B39}\x{0B3D}\x{0B5C}-\x{0B5D}\x{0B5F}-\x{0B61}\x{0B85}-\x{0B8A}] | [\x{0B8E}-\x{0B90}\x{0B92}-\x{0B95}\x{0B99}-\x{0B9A}\x{0B9C}] | [\x{0B9E}-\x{0B9F}\x{0BA3}-\x{0BA4}\x{0BA8}-\x{0BAA}\x{0BAE}-\x{0BB5}] | [\x{0BB7}-\x{0BB9}\x{0C05}-\x{0C0C}\x{0C0E}-\x{0C10}\x{0C12}-\x{0C28}] | [\x{0C2A}-\x{0C33}\x{0C35}-\x{0C39}\x{0C60}-\x{0C61}\x{0C85}-\x{0C8C}] | [\x{0C8E}-\x{0C90}\x{0C92}-\x{0CA8}\x{0CAA}-\x{0CB3}\x{0CB5}-\x{0CB9}\x{0CDE}] | [\x{0CE0}-\x{0CE1}\x{0D05}-\x{0D0C}\x{0D0E}-\x{0D10}\x{0D12}-\x{0D28}] | [\x{0D2A}-\x{0D39}\x{0D60}-\x{0D61}\x{0E01}-\x{0E2E}\x{0E30}\x{0E32}-\x{0E33}] | [\x{0E40}-\x{0E45}\x{0E81}-\x{0E82}\x{0E84}\x{0E87}-\x{0E88}\x{0E8A}] | [\x{0E8D}\x{0E94}-\x{0E97}\x{0E99}-\x{0E9F}\x{0EA1}-\x{0EA3}\x{0EA5}\x{0EA7}] | [\x{0EAA}-\x{0EAB}\x{0EAD}-\x{0EAE}\x{0EB0}\x{0EB2}-\x{0EB3}\x{0EBD}] | [\x{0EC0}-\x{0EC4}\x{0F40}-\x{0F47}\x{0F49}-\x{0F69}\x{10A0}-\x{10C5}] | [\x{10D0}-\x{10F6}\x{1100}\x{1102}-\x{1103}\x{1105}-\x{1107}\x{1109}] | [\x{110B}-\x{110C}\x{110E}-\x{1112}\x{113C}\x{113E}\x{1140}\x{114C}\x{114E}] | [\x{1150}\x{1154}-\x{1155}\x{1159}\x{115F}-\x{1161}\x{1163}\x{1165}] | [\x{1167}\x{1169}\x{116D}-\x{116E}\x{1172}-\x{1173}\x{1175}\x{119E}\x{11A8}] | [\x{11AB}\x{11AE}-\x{11AF}\x{11B7}-\x{11B8}\x{11BA}\x{11BC}-\x{11C2}] | [\x{11EB}\x{11F0}\x{11F9}\x{1E00}-\x{1E9B}\x{1EA0}-\x{1EF9}\x{1F00}-\x{1F15}] | [\x{1F18}-\x{1F1D}\x{1F20}-\x{1F45}\x{1F48}-\x{1F4D}\x{1F50}-\x{1F57}] | [\x{1F59}\x{1F5B}\x{1F5D}\x{1F5F}-\x{1F7D}\x{1F80}-\x{1FB4}\x{1FB6}-\x{1FBC}] | [\x{1FBE}\x{1FC2}-\x{1FC4}\x{1FC6}-\x{1FCC}\x{1FD0}-\x{1FD3}] | [\x{1FD6}-\x{1FDB}\x{1FE0}-\x{1FEC}\x{1FF2}-\x{1FF4}\x{1FF6}-\x{1FFC}] | [\x{2126}\x{212A}-\x{212B}\x{212E}\x{2180}-\x{2182}\x{3041}-\x{3094}] | [\x{30A1}-\x{30FA}\x{3105}-\x{312C}\x{AC00}-\x{D7A3}] /x; $Extender = qr/ [\x{00B7}\x{02D0}\x{02D1}\x{0387}\x{0640}\x{0E46}\x{0EC6}\x{3005}\x{3031}-\x{3035}\x{309D}-\x{309E}\x{30FC}-\x{30FE}] /x; $Digit = qr/ [\x{0030}-\x{0039}\x{0660}-\x{0669}\x{06F0}-\x{06F9}\x{0966}-\x{096F}] | [\x{09E6}-\x{09EF}\x{0A66}-\x{0A6F}\x{0AE6}-\x{0AEF}\x{0B66}-\x{0B6F}] | [\x{0BE7}-\x{0BEF}\x{0C66}-\x{0C6F}\x{0CE6}-\x{0CEF}\x{0D66}-\x{0D6F}] | [\x{0E50}-\x{0E59}\x{0ED0}-\x{0ED9}\x{0F20}-\x{0F29}] /x; $CombiningChar = qr/ [\x{0300}-\x{0345}\x{0360}-\x{0361}\x{0483}-\x{0486}\x{0591}-\x{05A1}] | [\x{05A3}-\x{05B9}\x{05BB}-\x{05BD}\x{05BF}\x{05C1}-\x{05C2}\x{05C4}] | [\x{064B}-\x{0652}\x{0670}\x{06D6}-\x{06DC}\x{06DD}-\x{06DF}\x{06E0}-\x{06E4}] | [\x{06E7}-\x{06E8}\x{06EA}-\x{06ED}\x{0901}-\x{0903}\x{093C}] | [\x{093E}-\x{094C}\x{094D}\x{0951}-\x{0954}\x{0962}-\x{0963}\x{0981}-\x{0983}] | [\x{09BC}\x{09BE}\x{09BF}\x{09C0}-\x{09C4}\x{09C7}-\x{09C8}] | [\x{09CB}-\x{09CD}\x{09D7}\x{09E2}-\x{09E3}\x{0A02}\x{0A3C}\x{0A3E}\x{0A3F}] | [\x{0A40}-\x{0A42}\x{0A47}-\x{0A48}\x{0A4B}-\x{0A4D}\x{0A70}-\x{0A71}] | [\x{0A81}-\x{0A83}\x{0ABC}\x{0ABE}-\x{0AC5}\x{0AC7}-\x{0AC9}\x{0ACB}-\x{0ACD}] | [\x{0B01}-\x{0B03}\x{0B3C}\x{0B3E}-\x{0B43}\x{0B47}-\x{0B48}] | [\x{0B4B}-\x{0B4D}\x{0B56}-\x{0B57}\x{0B82}-\x{0B83}\x{0BBE}-\x{0BC2}] | [\x{0BC6}-\x{0BC8}\x{0BCA}-\x{0BCD}\x{0BD7}\x{0C01}-\x{0C03}\x{0C3E}-\x{0C44}] | [\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}-\x{0C56}\x{0C82}-\x{0C83}] | [\x{0CBE}-\x{0CC4}\x{0CC6}-\x{0CC8}\x{0CCA}-\x{0CCD}\x{0CD5}-\x{0CD6}] | [\x{0D02}-\x{0D03}\x{0D3E}-\x{0D43}\x{0D46}-\x{0D48}\x{0D4A}-\x{0D4D}\x{0D57}] | [\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}] | [\x{0EBB}-\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}-\x{0F19}\x{0F35}\x{0F37}\x{0F39}] | [\x{0F3E}\x{0F3F}\x{0F71}-\x{0F84}\x{0F86}-\x{0F8B}\x{0F90}-\x{0F95}] | [\x{0F97}\x{0F99}-\x{0FAD}\x{0FB1}-\x{0FB7}\x{0FB9}\x{20D0}-\x{20DC}\x{20E1}] | [\x{302A}-\x{302F}\x{3099}\x{309A}] /x; $Ideographic = qr/ [\x{4E00}-\x{9FA5}\x{3007}\x{3021}-\x{3029}] /x; $NameChar = qr/^ (?: $BaseChar | $Ideographic | $Digit | [._:-] | $CombiningChar | $Extender )+ $/x; PERL die $@ if $@; } } 1; perl5/XML/SAX/PurePerl/Exception.pm 0000444 00000003253 14711217565 0012732 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Exception; use strict; use overload '""' => "stringify"; use vars qw/$StackTrace/; $StackTrace = $ENV{XML_DEBUG} || 0; sub throw { my $class = shift; die $class->new(@_); } sub new { my $class = shift; my %opts = @_; die "Invalid options" unless exists $opts{Message}; if ($opts{reader}) { return bless { Message => $opts{Message}, Exception => undef, # not sure what this is for!!! ColumnNumber => $opts{reader}->column, LineNumber => $opts{reader}->line, PublicId => $opts{reader}->public_id, SystemId => $opts{reader}->system_id, $StackTrace ? (StackTrace => stacktrace()) : (), }, $class; } return bless { Message => $opts{Message}, Exception => undef, # not sure what this is for!!! }, $class; } sub stringify { my $self = shift; local $^W; return $self->{Message} . " [Ln: " . $self->{LineNumber} . ", Col: " . $self->{ColumnNumber} . "]" . ($StackTrace ? stackstring($self->{StackTrace}) : "") . "\n"; } sub stacktrace { my $i = 2; my @fulltrace; while (my @trace = caller($i++)) { my %hash; @hash{qw(Package Filename Line)} = @trace[0..2]; push @fulltrace, \%hash; } return \@fulltrace; } sub stackstring { my $stacktrace = shift; my $string = "\nFrom:\n"; foreach my $current (@$stacktrace) { $string .= $current->{Filename} . " Line: " . $current->{Line} . "\n"; } return $string; } 1; perl5/XML/SAX/PurePerl/NoUnicodeExt.pm 0000444 00000001164 14711217565 0013337 0 ustar 00 # $Id$ package XML::SAX::PurePerl; use strict; sub chr_ref { my $n = shift; if ($n < 0x80) { return chr ($n); } elsif ($n < 0x800) { return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80)); } elsif ($n < 0x10000) { return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80)); } elsif ($n < 0x110000) { return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80), ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80)); } else { return undef; } } 1; perl5/XML/SAX/PurePerl/DTDDecls.pm 0000444 00000041140 14711217566 0012360 0 ustar 00 # $Id$ package XML::SAX::PurePerl; use strict; use XML::SAX::PurePerl::Productions qw($SingleChar); sub elementdecl { my ($self, $reader) = @_; my $data = $reader->data(9); return 0 unless $data =~ /^<!ELEMENT/; $reader->move_along(9); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after ELEMENT declaration", $reader); my $name = $self->Name($reader); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after ELEMENT's name", $reader); $self->contentspec($reader, $name); $self->skip_whitespace($reader); $reader->match('>') or $self->parser_error("Closing angle bracket not found on ELEMENT declaration", $reader); return 1; } sub contentspec { my ($self, $reader, $name) = @_; my $data = $reader->data(5); my $model; if ($data =~ /^EMPTY/) { $reader->move_along(5); $model = 'EMPTY'; } elsif ($data =~ /^ANY/) { $reader->move_along(3); $model = 'ANY'; } else { $model = $self->Mixed_or_children($reader); } if ($model) { # call SAX callback now. $self->element_decl({Name => $name, Model => $model}); return 1; } $self->parser_error("contentspec not found in ELEMENT declaration", $reader); } sub Mixed_or_children { my ($self, $reader) = @_; my $data = $reader->data(8); $data =~ /^\(/ or return; # $self->parser_error("No opening bracket in Mixed or children", $reader); if ($data =~ /^\(\s*\#PCDATA/) { $reader->match('('); $self->skip_whitespace($reader); $reader->move_along(7); my $model = $self->Mixed($reader); return $model; } # not matched - must be Children return $self->children($reader); } # Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' '*' ) # | ( '(' S* PCDATA S* ')' ) sub Mixed { my ($self, $reader) = @_; # Mixed_or_children already matched '(' S* '#PCDATA' my $model = '(#PCDATA'; $self->skip_whitespace($reader); my %seen; while (1) { last unless $reader->match('|'); $self->skip_whitespace($reader); my $name = $self->Name($reader) || $self->parser_error("No 'Name' after Mixed content '|'", $reader); if ($seen{$name}) { $self->parser_error("Element '$name' has already appeared in this group", $reader); } $seen{$name}++; $model .= "|$name"; $self->skip_whitespace($reader); } $reader->match(')') || $self->parser_error("no closing bracket on mixed content", $reader); $model .= ")"; if ($reader->match('*')) { $model .= "*"; } return $model; } # [[47]] Children ::= ChoiceOrSeq Cardinality? # [[48]] Cp ::= ( QName | ChoiceOrSeq ) Cardinality? # ChoiceOrSeq ::= '(' S* Cp ( Choice | Seq )? S* ')' # [[49]] Choice ::= ( S* '|' S* Cp )+ # [[50]] Seq ::= ( S* ',' S* Cp )+ # // Children ::= (Choice | Seq) Cardinality? # // Cp ::= ( QName | Choice | Seq) Cardinality? # // Choice ::= '(' S* Cp ( S* '|' S* Cp )+ S* ')' # // Seq ::= '(' S* Cp ( S* ',' S* Cp )* S* ')' # [[51]] Mixed ::= ( '(' S* PCDATA ( S* '|' S* QName )* S* ')' MixedCardinality ) # | ( '(' S* PCDATA S* ')' ) # Cardinality ::= '?' | '+' | '*' # MixedCardinality ::= '*' sub children { my ($self, $reader) = @_; return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader); } sub ChoiceOrSeq { my ($self, $reader) = @_; $reader->match('(') or $self->parser_error("choice/seq contains no opening bracket", $reader); my $model = '('; $self->skip_whitespace($reader); $model .= $self->Cp($reader); if (my $choice = $self->Choice($reader)) { $model .= $choice; } else { $model .= $self->Seq($reader); } $self->skip_whitespace($reader); $reader->match(')') or $self->parser_error("choice/seq contains no closing bracket", $reader); $model .= ')'; return $model; } sub Cardinality { my ($self, $reader) = @_; # cardinality is always optional my $data = $reader->data; if ($data =~ /^([\?\+\*])/) { $reader->move_along(1); return $1; } return ''; } sub Cp { my ($self, $reader) = @_; my $model; my $name = eval { if (my $name = $self->Name($reader)) { return $name . $self->Cardinality($reader); } }; return $name if defined $name; return $self->ChoiceOrSeq($reader) . $self->Cardinality($reader); } sub Choice { my ($self, $reader) = @_; my $model = ''; $self->skip_whitespace($reader); while ($reader->match('|')) { $self->skip_whitespace($reader); $model .= '|'; $model .= $self->Cp($reader); $self->skip_whitespace($reader); } return $model; } sub Seq { my ($self, $reader) = @_; my $model = ''; $self->skip_whitespace($reader); while ($reader->match(',')) { $self->skip_whitespace($reader); my $cp = $self->Cp($reader); if ($cp) { $model .= ','; $model .= $cp; } $self->skip_whitespace($reader); } return $model; } sub AttlistDecl { my ($self, $reader) = @_; my $data = $reader->data(9); if ($data =~ /^<!ATTLIST/) { # It's an attlist $reader->move_along(9); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after ATTLIST declaration", $reader); my $name = $self->Name($reader); $self->AttDefList($reader, $name); $self->skip_whitespace($reader); $reader->match('>') or $self->parser_error("Closing angle bracket not found on ATTLIST declaration", $reader); return 1; } return 0; } sub AttDefList { my ($self, $reader, $name) = @_; 1 while $self->AttDef($reader, $name); } sub AttDef { my ($self, $reader, $el_name) = @_; $self->skip_whitespace($reader) || return 0; my $att_name = $self->Name($reader) || return 0; $self->skip_whitespace($reader) || $self->parser_error("No whitespace after Name in attribute definition", $reader); my $att_type = $self->AttType($reader); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after AttType in attribute definition", $reader); my ($mode, $value) = $self->DefaultDecl($reader); # fire SAX event here! $self->attribute_decl({ eName => $el_name, aName => $att_name, Type => $att_type, Mode => $mode, Value => $value, }); return 1; } sub AttType { my ($self, $reader) = @_; return $self->StringType($reader) || $self->TokenizedType($reader) || $self->EnumeratedType($reader) || $self->parser_error("Can't match AttType", $reader); } sub StringType { my ($self, $reader) = @_; my $data = $reader->data(5); return unless $data =~ /^CDATA/; $reader->move_along(5); return 'CDATA'; } sub TokenizedType { my ($self, $reader) = @_; my $data = $reader->data(8); if ($data =~ /^(IDREFS?|ID|ENTITIES|ENTITY|NMTOKENS?)/) { $reader->move_along(length($1)); return $1; } return; } sub EnumeratedType { my ($self, $reader) = @_; return $self->NotationType($reader) || $self->Enumeration($reader); } sub NotationType { my ($self, $reader) = @_; my $data = $reader->data(8); return unless $data =~ /^NOTATION/; $reader->move_along(8); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after NOTATION", $reader); $reader->match('(') or $self->parser_error("No opening bracket in notation section", $reader); $self->skip_whitespace($reader); my $model = 'NOTATION ('; my $name = $self->Name($reader) || $self->parser_error("No name in notation section", $reader); $model .= $name; $self->skip_whitespace($reader); $data = $reader->data; while ($data =~ /^\|/) { $reader->move_along(1); $model .= '|'; $self->skip_whitespace($reader); my $name = $self->Name($reader) || $self->parser_error("No name in notation section", $reader); $model .= $name; $self->skip_whitespace($reader); $data = $reader->data; } $data =~ /^\)/ or $self->parser_error("No closing bracket in notation section", $reader); $reader->move_along(1); $model .= ')'; return $model; } sub Enumeration { my ($self, $reader) = @_; return unless $reader->match('('); $self->skip_whitespace($reader); my $model = '('; my $nmtoken = $self->Nmtoken($reader) || $self->parser_error("No Nmtoken in enumerated declaration", $reader); $model .= $nmtoken; $self->skip_whitespace($reader); my $data = $reader->data; while ($data =~ /^\|/) { $model .= '|'; $reader->move_along(1); $self->skip_whitespace($reader); my $nmtoken = $self->Nmtoken($reader) || $self->parser_error("No Nmtoken in enumerated declaration", $reader); $model .= $nmtoken; $self->skip_whitespace($reader); $data = $reader->data; } $data =~ /^\)/ or $self->parser_error("No closing bracket in enumerated declaration", $reader); $reader->move_along(1); $model .= ')'; return $model; } sub Nmtoken { my ($self, $reader) = @_; return $self->Name($reader); } sub DefaultDecl { my ($self, $reader) = @_; my $data = $reader->data(9); if ($data =~ /^(\#REQUIRED|\#IMPLIED)/) { $reader->move_along(length($1)); return $1; } my $model = ''; if ($data =~ /^\#FIXED/) { $reader->move_along(6); $self->skip_whitespace($reader) || $self->parser_error( "no whitespace after FIXED specifier", $reader); my $value = $self->AttValue($reader); return "#FIXED", $value; } my $value = $self->AttValue($reader); return undef, $value; } sub EntityDecl { my ($self, $reader) = @_; my $data = $reader->data(8); return 0 unless $data =~ /^<!ENTITY/; $reader->move_along(8); $self->skip_whitespace($reader) || $self->parser_error( "No whitespace after ENTITY declaration", $reader); $self->PEDecl($reader) || $self->GEDecl($reader); $self->skip_whitespace($reader); $reader->match('>') or $self->parser_error("No closing '>' in entity definition", $reader); return 1; } sub GEDecl { my ($self, $reader) = @_; my $name = $self->Name($reader) || $self->parser_error("No entity name given", $reader); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after entity name", $reader); # TODO: ExternalID calls lexhandler method. Wrong place for it. my $value; if ($value = $self->ExternalID($reader)) { $value .= $self->NDataDecl($reader); } else { $value = $self->EntityValue($reader); } if ($self->{ParseOptions}{entities}{$name}) { warn("entity $name already exists\n"); } else { $self->{ParseOptions}{entities}{$name} = 1; $self->{ParseOptions}{expanded_entity}{$name} = $value; # ??? } # do callback? return 1; } sub PEDecl { my ($self, $reader) = @_; return 0 unless $reader->match('%'); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity marker", $reader); my $name = $self->Name($reader) || $self->parser_error("No parameter entity name given", $reader); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after parameter entity name", $reader); my $value = $self->ExternalID($reader) || $self->EntityValue($reader) || $self->parser_error("PE is not a value or an external resource", $reader); # do callback? return 1; } my $quotre = qr/[^%&\"]/; my $aposre = qr/[^%&\']/; sub EntityValue { my ($self, $reader) = @_; my $data = $reader->data; my $quote = '"'; my $re = $quotre; if ($data !~ /^"/) { $data =~ /^'/ or $self->parser_error("Not a quote character", $reader); $quote = "'"; $re = $aposre; } $reader->move_along(1); my $value = ''; while (1) { my $data = $reader->data; $self->parser_error("EOF found while reading entity value", $reader) unless length($data); if ($data =~ /^($re+)/) { my $match = $1; $value .= $match; $reader->move_along(length($match)); } elsif ($reader->match('&')) { # if it's a char ref, expand now: if ($reader->match('#')) { my $char; my $ref = ''; if ($reader->match('x')) { my $data = $reader->data; while (1) { $self->parser_error("EOF looking for reference end", $reader) unless length($data); if ($data !~ /^([0-9a-fA-F]*)/) { last; } $ref .= $1; $reader->move_along(length($1)); if (length($1) == length($data)) { $data = $reader->data; } else { last; } } $char = chr_ref(hex($ref)); $ref = "x$ref"; } else { my $data = $reader->data; while (1) { $self->parser_error("EOF looking for reference end", $reader) unless length($data); if ($data !~ /^([0-9]*)/) { last; } $ref .= $1; $reader->move_along(length($1)); if (length($1) == length($data)) { $data = $reader->data; } else { last; } } $char = chr($ref); } $reader->match(';') || $self->parser_error("No semi-colon found after character reference", $reader); if ($char !~ $SingleChar) { # match a single character $self->parser_error("Character reference '&#$ref;' refers to an illegal XML character ($char)", $reader); } $value .= $char; } else { # entity refs in entities get expanded later, so don't parse now. $value .= '&'; } } elsif ($reader->match('%')) { $value .= $self->PEReference($reader); } elsif ($reader->match($quote)) { # end of attrib last; } else { $self->parser_error("Invalid character in attribute value: " . substr($reader->data, 0, 1), $reader); } } return $value; } sub NDataDecl { my ($self, $reader) = @_; $self->skip_whitespace($reader) || return ''; my $data = $reader->data(5); return '' unless $data =~ /^NDATA/; $reader->move_along(5); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after NDATA declaration", $reader); my $name = $self->Name($reader) || $self->parser_error("NDATA declaration lacks a proper Name", $reader); return " NDATA $name"; } sub NotationDecl { my ($self, $reader) = @_; my $data = $reader->data(10); return 0 unless $data =~ /^<!NOTATION/; $reader->move_along(10); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after NOTATION declaration", $reader); $data = $reader->data; my $value = ''; while(1) { $self->parser_error("EOF found while looking for end of NotationDecl", $reader) unless length($data); if ($data =~ /^([^>]*)>/) { $value .= $1; $reader->move_along(length($1) + 1); $self->notation_decl({Name => "FIXME", SystemId => "FIXME", PublicId => "FIXME" }); last; } else { $value .= $data; $reader->move_along(length($data)); $data = $reader->data; } } return 1; } 1; perl5/XML/SAX/PurePerl/EncodingDetect.pm 0000444 00000005104 14711217566 0013651 0 ustar 00 # $Id$ package XML::SAX::PurePerl; # NB, not ::EncodingDetect! use strict; sub encoding_detect { my ($parser, $reader) = @_; my $error = "Invalid byte sequence at start of file"; my $data = $reader->data; if ($data =~ /^\x00\x00\xFE\xFF/) { # BO-UCS4-be $reader->move_along(4); $reader->set_encoding('UCS-4BE'); return; } elsif ($data =~ /^\x00\x00\xFF\xFE/) { # BO-UCS-4-2143 $reader->move_along(4); $reader->set_encoding('UCS-4-2143'); return; } elsif ($data =~ /^\x00\x00\x00\x3C/) { $reader->set_encoding('UCS-4BE'); return; } elsif ($data =~ /^\x00\x00\x3C\x00/) { $reader->set_encoding('UCS-4-2143'); return; } elsif ($data =~ /^\x00\x3C\x00\x00/) { $reader->set_encoding('UCS-4-3412'); return; } elsif ($data =~ /^\x00\x3C\x00\x3F/) { $reader->set_encoding('UTF-16BE'); return; } elsif ($data =~ /^\xFF\xFE\x00\x00/) { # BO-UCS-4LE $reader->move_along(4); $reader->set_encoding('UCS-4LE'); return; } elsif ($data =~ /^\xFF\xFE/) { $reader->move_along(2); $reader->set_encoding('UTF-16LE'); return; } elsif ($data =~ /^\xFE\xFF\x00\x00/) { $reader->move_along(4); $reader->set_encoding('UCS-4-3412'); return; } elsif ($data =~ /^\xFE\xFF/) { $reader->move_along(2); $reader->set_encoding('UTF-16BE'); return; } elsif ($data =~ /^\xEF\xBB\xBF/) { # UTF-8 BOM $reader->move_along(3); $reader->set_encoding('UTF-8'); return; } elsif ($data =~ /^\x3C\x00\x00\x00/) { $reader->set_encoding('UCS-4LE'); return; } elsif ($data =~ /^\x3C\x00\x3F\x00/) { $reader->set_encoding('UTF-16LE'); return; } elsif ($data =~ /^\x3C\x3F\x78\x6D/) { # $reader->set_encoding('UTF-8'); return; } elsif ($data =~ /^\x3C\x3F\x78/) { # $reader->set_encoding('UTF-8'); return; } elsif ($data =~ /^\x3C\x3F/) { # $reader->set_encoding('UTF-8'); return; } elsif ($data =~ /^\x3C/) { # $reader->set_encoding('UTF-8'); return; } elsif ($data =~ /^[\x20\x09\x0A\x0D]+\x3C[^\x3F]/) { # $reader->set_encoding('UTF-8'); return; } elsif ($data =~ /^\x4C\x6F\xA7\x94/) { $reader->set_encoding('EBCDIC'); return; } warn("Unable to recognise encoding of this document"); return; } 1; perl5/XML/SAX/PurePerl/Reader.pm 0000444 00000004755 14711217566 0012207 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Reader; use strict; use XML::SAX::PurePerl::Reader::URI; use Exporter (); use vars qw(@ISA @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw( EOF BUFFER LINE COLUMN ENCODING XML_VERSION ); use constant EOF => 0; use constant BUFFER => 1; use constant LINE => 2; use constant COLUMN => 3; use constant ENCODING => 4; use constant SYSTEM_ID => 5; use constant PUBLIC_ID => 6; use constant XML_VERSION => 7; require XML::SAX::PurePerl::Reader::Stream; require XML::SAX::PurePerl::Reader::String; if ($] >= 5.007002) { require XML::SAX::PurePerl::Reader::UnicodeExt; } else { require XML::SAX::PurePerl::Reader::NoUnicodeExt; } sub new { my $class = shift; my $thing = shift; # try to figure if this $thing is a handle of some sort if (ref($thing) && UNIVERSAL::isa($thing, 'IO::Handle')) { return XML::SAX::PurePerl::Reader::Stream->new($thing)->init; } my $ioref; if (tied($thing)) { my $class = ref($thing); no strict 'refs'; $ioref = $thing if defined &{"${class}::TIEHANDLE"}; } else { eval { $ioref = *{$thing}{IO}; }; undef $@; } if ($ioref) { return XML::SAX::PurePerl::Reader::Stream->new($thing)->init; } if ($thing =~ /</) { # assume it's a string return XML::SAX::PurePerl::Reader::String->new($thing)->init; } # assume it is a uri return XML::SAX::PurePerl::Reader::URI->new($thing)->init; } sub init { my $self = shift; $self->[LINE] = 1; $self->[COLUMN] = 1; $self->read_more; return $self; } sub data { my ($self, $min_length) = (@_, 1); if (length($self->[BUFFER]) < $min_length) { $self->read_more; } return $self->[BUFFER]; } sub match { my ($self, $char) = @_; my $data = $self->data; if (substr($data, 0, 1) eq $char) { $self->move_along(1); return 1; } return 0; } sub public_id { my $self = shift; @_ and $self->[PUBLIC_ID] = shift; $self->[PUBLIC_ID]; } sub system_id { my $self = shift; @_ and $self->[SYSTEM_ID] = shift; $self->[SYSTEM_ID]; } sub line { shift->[LINE]; } sub column { shift->[COLUMN]; } sub get_encoding { my $self = shift; return $self->[ENCODING]; } sub get_xml_version { my $self = shift; return $self->[XML_VERSION]; } 1; __END__ =head1 NAME XML::Parser::PurePerl::Reader - Abstract Reader factory class =cut perl5/XML/SAX/PurePerl/DebugHandler.pm 0000444 00000003527 14711217567 0013326 0 ustar 00 # $Id$ package XML::SAX::PurePerl::DebugHandler; use strict; sub new { my $class = shift; my %opts = @_; return bless \%opts, $class; } # DocumentHandler sub set_document_locator { my $self = shift; print "set_document_locator\n" if $ENV{DEBUG_XML}; $self->{seen}{set_document_locator}++; } sub start_document { my $self = shift; print "start_document\n" if $ENV{DEBUG_XML}; $self->{seen}{start_document}++; } sub end_document { my $self = shift; print "end_document\n" if $ENV{DEBUG_XML}; $self->{seen}{end_document}++; } sub start_element { my $self = shift; print "start_element\n" if $ENV{DEBUG_XML}; $self->{seen}{start_element}++; } sub end_element { my $self = shift; print "end_element\n" if $ENV{DEBUG_XML}; $self->{seen}{end_element}++; } sub characters { my $self = shift; print "characters\n" if $ENV{DEBUG_XML}; # warn "Char: ", $_[0]->{Data}, "\n"; $self->{seen}{characters}++; } sub processing_instruction { my $self = shift; print "processing_instruction\n" if $ENV{DEBUG_XML}; $self->{seen}{processing_instruction}++; } sub ignorable_whitespace { my $self = shift; print "ignorable_whitespace\n" if $ENV{DEBUG_XML}; $self->{seen}{ignorable_whitespace}++; } # LexHandler sub comment { my $self = shift; print "comment\n" if $ENV{DEBUG_XML}; $self->{seen}{comment}++; } # DTDHandler sub notation_decl { my $self = shift; print "notation_decl\n" if $ENV{DEBUG_XML}; $self->{seen}{notation_decl}++; } sub unparsed_entity_decl { my $self = shift; print "unparsed_entity_decl\n" if $ENV{DEBUG_XML}; $self->{seen}{entity_decl}++; } # EntityResolver sub resolve_entity { my $self = shift; print "resolve_entity\n" if $ENV{DEBUG_XML}; $self->{seen}{resolve_entity}++; return ''; } 1; perl5/XML/SAX/PurePerl/DocType.pm 0000444 00000011062 14711217567 0012342 0 ustar 00 # $Id$ package XML::SAX::PurePerl; use strict; use XML::SAX::PurePerl::Productions qw($PubidChar); sub doctypedecl { my ($self, $reader) = @_; my $data = $reader->data(9); if ($data =~ /^<!DOCTYPE/) { $reader->move_along(9); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after doctype declaration", $reader); my $root_name = $self->Name($reader) || $self->parser_error("Doctype declaration has no root element name", $reader); if ($self->skip_whitespace($reader)) { # might be externalid... my %dtd = $self->ExternalID($reader); # TODO: Call SAX event } $self->skip_whitespace($reader); $self->InternalSubset($reader); $reader->match('>') or $self->parser_error("Doctype not closed", $reader); return 1; } return 0; } sub ExternalID { my ($self, $reader) = @_; my $data = $reader->data(6); if ($data =~ /^SYSTEM/) { $reader->move_along(6); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after SYSTEM identifier", $reader); return (SYSTEM => $self->SystemLiteral($reader)); } elsif ($data =~ /^PUBLIC/) { $reader->move_along(6); $self->skip_whitespace($reader) || $self->parser_error("No whitespace after PUBLIC identifier", $reader); my $quote = $self->quote($reader) || $self->parser_error("Not a quote character in PUBLIC identifier", $reader); my $data = $reader->data; my $pubid = ''; while(1) { $self->parser_error("EOF while looking for end of PUBLIC identifiier", $reader) unless length($data); if ($data =~ /^([^$quote]*)$quote/) { $pubid .= $1; $reader->move_along(length($1) + 1); last; } else { $pubid .= $data; $reader->move_along(length($data)); $data = $reader->data; } } if ($pubid !~ /^($PubidChar)+$/) { $self->parser_error("Invalid characters in PUBLIC identifier", $reader); } $self->skip_whitespace($reader) || $self->parser_error("Not whitespace after PUBLIC ID in DOCTYPE", $reader); return (PUBLIC => $pubid, SYSTEM => $self->SystemLiteral($reader)); } else { return; } return 1; } sub SystemLiteral { my ($self, $reader) = @_; my $quote = $self->quote($reader); my $data = $reader->data; my $systemid = ''; while (1) { $self->parser_error("EOF found while looking for end of System Literal", $reader) unless length($data); if ($data =~ /^([^$quote]*)$quote/) { $systemid .= $1; $reader->move_along(length($1) + 1); return $systemid; } else { $systemid .= $data; $reader->move_along(length($data)); $data = $reader->data; } } } sub InternalSubset { my ($self, $reader) = @_; return 0 unless $reader->match('['); 1 while $self->IntSubsetDecl($reader); $reader->match(']') or $self->parser_error("No close bracket on internal subset (found: " . $reader->data, $reader); $self->skip_whitespace($reader); return 1; } sub IntSubsetDecl { my ($self, $reader) = @_; return $self->DeclSep($reader) || $self->markupdecl($reader); } sub DeclSep { my ($self, $reader) = @_; if ($self->skip_whitespace($reader)) { return 1; } if ($self->PEReference($reader)) { return 1; } # if ($self->ParsedExtSubset($reader)) { # return 1; # } return 0; } sub PEReference { my ($self, $reader) = @_; return 0 unless $reader->match('%'); my $peref = $self->Name($reader) || $self->parser_error("PEReference did not find a Name", $reader); # TODO - load/parse the peref $reader->match(';') or $self->parser_error("Invalid token in PEReference", $reader); return 1; } sub markupdecl { my ($self, $reader) = @_; if ($self->elementdecl($reader) || $self->AttlistDecl($reader) || $self->EntityDecl($reader) || $self->NotationDecl($reader) || $self->PI($reader) || $self->Comment($reader)) { return 1; } return 0; } 1; perl5/XML/SAX/PurePerl/Reader/URI.pm 0000444 00000002666 14711217570 0012640 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Reader::URI; use strict; use XML::SAX::PurePerl::Reader; use File::Temp qw(tempfile); use Symbol; ## NOTE: This is *not* a subclass of Reader. It just returns Stream or String ## Reader objects depending on what it's capabilities are. sub new { my $class = shift; my $uri = shift; # request the URI if (-e $uri && -f _) { my $fh = gensym; open($fh, $uri) || die "Cannot open file $uri : $!"; return XML::SAX::PurePerl::Reader::Stream->new($fh); } elsif ($uri =~ /^file:(.*)$/ && -e $1 && -f _) { my $file = $1; my $fh = gensym; open($fh, $file) || die "Cannot open file $file : $!"; return XML::SAX::PurePerl::Reader::Stream->new($fh); } else { # request URI, return String reader require LWP::UserAgent; my $ua = LWP::UserAgent->new; $ua->agent("Perl/XML/SAX/PurePerl/1.0 " . $ua->agent); my $req = HTTP::Request->new(GET => $uri); my $fh = tempfile(); my $callback = sub { my ($data, $response, $protocol) = @_; print $fh $data; }; my $res = $ua->request($req, $callback, 4096); if ($res->is_success) { seek($fh, 0, 0); return XML::SAX::PurePerl::Reader::Stream->new($fh); } else { die "LWP Request Failed"; } } } 1; perl5/XML/SAX/PurePerl/Reader/NoUnicodeExt.pm 0000444 00000001113 14711217570 0014527 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Reader; use strict; sub set_raw_stream { # no-op } sub switch_encoding_stream { my ($fh, $encoding) = @_; throw XML::SAX::Exception::Parse ( Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding", ) if $encoding !~ /(ASCII|UTF\-?8)/i; } sub switch_encoding_string { my (undef, $encoding) = @_; throw XML::SAX::Exception::Parse ( Message => "Only ASCII encoding allowed without perl 5.7.2 or higher. You tried: $encoding", ) if $encoding !~ /(ASCII|UTF\-?8)/i; } 1; perl5/XML/SAX/PurePerl/Reader/Stream.pm 0000444 00000003411 14711217571 0013422 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Reader::Stream; use strict; use vars qw(@ISA); use XML::SAX::PurePerl::Reader qw( EOF BUFFER LINE COLUMN ENCODING XML_VERSION ); use XML::SAX::Exception; @ISA = ('XML::SAX::PurePerl::Reader'); # subclassed by adding 1 to last element use constant FH => 8; use constant BUFFER_SIZE => 4096; sub new { my $class = shift; my $ioref = shift; XML::SAX::PurePerl::Reader::set_raw_stream($ioref); my @parts; @parts[FH, LINE, COLUMN, BUFFER, EOF, XML_VERSION] = ($ioref, 1, 0, '', 0, '1.0'); return bless \@parts, $class; } sub read_more { my $self = shift; my $buf; my $bytesread = read($self->[FH], $buf, BUFFER_SIZE); if ($bytesread) { $self->[BUFFER] .= $buf; return 1; } elsif (defined($bytesread)) { $self->[EOF]++; return 0; } else { throw XML::SAX::Exception::Parse( Message => "Error reading from filehandle: $!", ); } } sub move_along { my $self = shift; my $discarded = substr($self->[BUFFER], 0, $_[0], ''); # Wish I could skip this lot - tells us where we are in the file my $lines = $discarded =~ tr/\n//; $self->[LINE] += $lines; if ($lines) { $discarded =~ /\n([^\n]*)$/; $self->[COLUMN] = length($1); } else { $self->[COLUMN] += $_[0]; } } sub set_encoding { my $self = shift; my ($encoding) = @_; # warn("set encoding to: $encoding\n"); XML::SAX::PurePerl::Reader::switch_encoding_stream($self->[FH], $encoding); XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding); $self->[ENCODING] = $encoding; } sub bytepos { my $self = shift; tell($self->[FH]); } 1; perl5/XML/SAX/PurePerl/Reader/String.pm 0000444 00000003233 14711217572 0013440 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Reader::String; use strict; use vars qw(@ISA); use XML::SAX::PurePerl::Reader qw( LINE COLUMN BUFFER ENCODING EOF ); @ISA = ('XML::SAX::PurePerl::Reader'); use constant DISCARDED => 8; use constant STRING => 9; use constant USED => 10; use constant CHUNK_SIZE => 2048; sub new { my $class = shift; my $string = shift; my @parts; @parts[BUFFER, EOF, LINE, COLUMN, DISCARDED, STRING, USED] = ('', 0, 1, 0, 0, $string, 0); return bless \@parts, $class; } sub read_more () { my $self = shift; if ($self->[USED] >= length($self->[STRING])) { $self->[EOF]++; return 0; } my $bytes = CHUNK_SIZE; if ($bytes > (length($self->[STRING]) - $self->[USED])) { $bytes = (length($self->[STRING]) - $self->[USED]); } $self->[BUFFER] .= substr($self->[STRING], $self->[USED], $bytes); $self->[USED] += $bytes; return 1; } sub move_along { my($self, $bytes) = @_; my $discarded = substr($self->[BUFFER], 0, $bytes, ''); $self->[DISCARDED] += length($discarded); # Wish I could skip this lot - tells us where we are in the file my $lines = $discarded =~ tr/\n//; $self->[LINE] += $lines; if ($lines) { $discarded =~ /\n([^\n]*)$/; $self->[COLUMN] = length($1); } else { $self->[COLUMN] += $_[0]; } } sub set_encoding { my $self = shift; my ($encoding) = @_; XML::SAX::PurePerl::Reader::switch_encoding_string($self->[BUFFER], $encoding, "utf-8"); $self->[ENCODING] = $encoding; } sub bytepos { my $self = shift; $self->[DISCARDED]; } 1; perl5/XML/SAX/PurePerl/Reader/UnicodeExt.pm 0000444 00000000506 14711217572 0014241 0 ustar 00 # $Id$ package XML::SAX::PurePerl::Reader; use strict; use Encode (); sub set_raw_stream { my ($fh) = @_; binmode($fh, ":bytes"); } sub switch_encoding_stream { my ($fh, $encoding) = @_; binmode($fh, ":encoding($encoding)"); } sub switch_encoding_string { $_[0] = Encode::decode($_[1], $_[0]); } 1; perl5/XML/SAX/PurePerl/UnicodeExt.pm 0000444 00000000561 14711217573 0013041 0 ustar 00 # $Id$ package XML::SAX::PurePerl; use strict; no warnings 'utf8'; sub chr_ref { return chr(shift); } if ($] >= 5.007002) { require Encode; Encode::define_alias( "UTF-16" => "UCS-2" ); Encode::define_alias( "UTF-16BE" => "UCS-2" ); Encode::define_alias( "UTF-16LE" => "ucs-2le" ); Encode::define_alias( "UTF16LE" => "ucs-2le" ); } 1; perl5/XML/SAX/PurePerl/XMLDecl.pm 0000444 00000006475 14711217574 0012235 0 ustar 00 # $Id$ package XML::SAX::PurePerl; use strict; use XML::SAX::PurePerl::Productions qw($S $VersionNum $EncNameStart $EncNameEnd); sub XMLDecl { my ($self, $reader) = @_; my $data = $reader->data(5); # warn("Looking for xmldecl in: $data"); if ($data =~ /^<\?xml$S/o) { $reader->move_along(5); $self->skip_whitespace($reader); # get version attribute $self->VersionInfo($reader) || $self->parser_error("XML Declaration lacks required version attribute, or version attribute does not match XML specification", $reader); if (!$self->skip_whitespace($reader)) { my $data = $reader->data(2); $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); $reader->move_along(2); return; } if ($self->EncodingDecl($reader)) { if (!$self->skip_whitespace($reader)) { my $data = $reader->data(2); $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); $reader->move_along(2); return; } } $self->SDDecl($reader); $self->skip_whitespace($reader); my $data = $reader->data(2); $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); $reader->move_along(2); } else { # warn("first 5 bytes: ", join(',', unpack("CCCCC", $data)), "\n"); # no xml decl if (!$reader->get_encoding) { $reader->set_encoding("UTF-8"); } } } sub VersionInfo { my ($self, $reader) = @_; my $data = $reader->data(11); # warn("Looking for version in $data"); $data =~ /^(version$S*=$S*(["'])($VersionNum)\2)/o or return 0; $reader->move_along(length($1)); my $vernum = $3; if ($vernum ne "1.0") { $self->parser_error("Only XML version 1.0 supported. Saw: '$vernum'", $reader); } return 1; } sub SDDecl { my ($self, $reader) = @_; my $data = $reader->data(15); $data =~ /^(standalone$S*=$S*(["'])(yes|no)\2)/o or return 0; $reader->move_along(length($1)); my $yesno = $3; if ($yesno eq 'yes') { $self->{standalone} = 1; } else { $self->{standalone} = 0; } return 1; } sub EncodingDecl { my ($self, $reader) = @_; my $data = $reader->data(12); $data =~ /^(encoding$S*=$S*(["'])($EncNameStart$EncNameEnd*)\2)/o or return 0; $reader->move_along(length($1)); my $encoding = $3; $reader->set_encoding($encoding); return 1; } sub TextDecl { my ($self, $reader) = @_; my $data = $reader->data(6); $data =~ /^<\?xml$S+/ or return; $reader->move_along(5); $self->skip_whitespace($reader); if ($self->VersionInfo($reader)) { $self->skip_whitespace($reader) || $self->parser_error("Lack of whitespace after version attribute in text declaration", $reader); } $self->EncodingDecl($reader) || $self->parser_error("Encoding declaration missing from external entity text declaration", $reader); $self->skip_whitespace($reader); $data = $reader->data(2); $data =~ /^\?>/ or $self->parser_error("Syntax error", $reader); return 1; } 1; perl5/XML/SAX/Expat.pm 0000555 00000046305 14711217575 0010330 0 ustar 00 ### # XML::SAX::Expat - SAX2 Driver for Expat (XML::Parser) # Originally by Robin Berjon ### package XML::SAX::Expat; use strict; use base qw(XML::SAX::Base); use XML::NamespaceSupport qw(); use XML::Parser qw(); use vars qw($VERSION); $VERSION = '0.51'; #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Variations on parse `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# #-------------------------------------------------------------------# # CharacterStream #-------------------------------------------------------------------# sub _parse_characterstream { my $p = shift; my $xml = shift; my $opt = shift; my $expat = $p->_create_parser($opt); my $result = $expat->parse($xml); $p->_cleanup; return $result; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # ByteStream #-------------------------------------------------------------------# sub _parse_bytestream { my $p = shift; my $xml = shift; my $opt = shift; my $expat = $p->_create_parser($opt); my $result = $expat->parse($xml); $p->_cleanup; return $result; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # String #-------------------------------------------------------------------# sub _parse_string { my $p = shift; my $xml = shift; my $opt = shift; my $expat = $p->_create_parser($opt); my $result = $expat->parse($xml); $p->_cleanup; return $result; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # SystemId #-------------------------------------------------------------------# sub _parse_systemid { my $p = shift; my $xml = shift; my $opt = shift; my $expat = $p->_create_parser($opt); my $result = $expat->parsefile($xml); $p->_cleanup; return $result; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->_create_parser(\%options) #-------------------------------------------------------------------# sub _create_parser { my $self = shift; my $opt = shift; die "ParserReference: parser instance ($self) already parsing\n" if $self->{_InParse}; my $featUri = 'http://xml.org/sax/features/'; my $ppe = ($self->get_feature($featUri . 'external-general-entities') or $self->get_feature($featUri . 'external-parameter-entities') ) ? 1 : 0; my $expat = XML::Parser->new( ParseParamEnt => $ppe ); $expat->{__XSE} = $self; $expat->setHandlers( Init => \&_handle_init, Final => \&_handle_final, Start => \&_handle_start, End => \&_handle_end, Char => \&_handle_char, Comment => \&_handle_comment, Proc => \&_handle_proc, CdataStart => \&_handle_start_cdata, CdataEnd => \&_handle_end_cdata, Unparsed => \&_handle_unparsed_entity, Notation => \&_handle_notation_decl, #ExternEnt #ExternEntFin Entity => \&_handle_entity_decl, Element => \&_handle_element_decl, Attlist => \&_handle_attr_decl, Doctype => \&_handle_start_doctype, DoctypeFin => \&_handle_end_doctype, XMLDecl => \&_handle_xml_decl, ); $self->{_InParse} = 1; $self->{_NodeStack} = []; $self->{_NSStack} = []; $self->{_NSHelper} = XML::NamespaceSupport->new({xmlns => 1}); $self->{_started} = 0; return $expat; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # $p->_cleanup #-------------------------------------------------------------------# sub _cleanup { my $self = shift; $self->{_InParse} = 0; delete $self->{_NodeStack}; } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Expat Handlers ,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# #-------------------------------------------------------------------# # _handle_init #-------------------------------------------------------------------# sub _handle_init { #my $self = shift()->{__XSE}; #my $document = {}; #push @{$self->{_NodeStack}}, $document; #$self->SUPER::start_document($document); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_final #-------------------------------------------------------------------# sub _handle_final { my $self = shift()->{__XSE}; #my $document = pop @{$self->{_NodeStack}}; return $self->SUPER::end_document({}); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_start #-------------------------------------------------------------------# sub _handle_start { my $self = shift()->{__XSE}; my $e_name = shift; my %attr = @_; # start_document data $self->_handle_start_document({}) unless $self->{_started}; # take care of namespaces my $nsh = $self->{_NSHelper}; $nsh->push_context; my @new_ns; for my $k (grep !index($_, 'xmlns'), keys %attr) { $k =~ m/^xmlns(:(.*))?$/; my $prefix = $2 || ''; $nsh->declare_prefix($prefix, $attr{$k}); my $ns = { Prefix => $prefix, NamespaceURI => $attr{$k}, }; push @new_ns, $ns; $self->SUPER::start_prefix_mapping($ns); } push @{$self->{_NSStack}}, \@new_ns; # create the attributes my %saxattr; map { my ($ns,$prefix,$lname) = $nsh->process_attribute_name($_); $saxattr{'{' . ($ns || '') . '}' . $lname} = { Name => $_, LocalName => $lname || '', Prefix => $prefix || '', Value => $attr{$_}, NamespaceURI => $ns || '', }; } keys %attr; # now the element my ($ns,$prefix,$lname) = $nsh->process_element_name($e_name); my $element = { Name => $e_name, LocalName => $lname || '', Prefix => $prefix || '', NamespaceURI => $ns || '', Attributes => \%saxattr, }; push @{$self->{_NodeStack}}, $element; $self->SUPER::start_element($element); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_end #-------------------------------------------------------------------# sub _handle_end { my $self = shift()->{__XSE}; my %element = %{pop @{$self->{_NodeStack}}}; delete $element{Attributes}; $self->SUPER::end_element(\%element); my $prev_ns = pop @{$self->{_NSStack}}; for my $ns (@$prev_ns) { $self->SUPER::end_prefix_mapping( { %$ns } ); } $self->{_NSHelper}->pop_context; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_char #-------------------------------------------------------------------# sub _handle_char { $_[0]->{__XSE}->_handle_start_document({}) unless $_[0]->{__XSE}->{_started}; $_[0]->{__XSE}->SUPER::characters({ Data => $_[1] }); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_comment #-------------------------------------------------------------------# sub _handle_comment { $_[0]->{__XSE}->_handle_start_document({}) unless $_[0]->{__XSE}->{_started}; $_[0]->{__XSE}->SUPER::comment({ Data => $_[1] }); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_proc #-------------------------------------------------------------------# sub _handle_proc { $_[0]->{__XSE}->_handle_start_document({}) unless $_[0]->{__XSE}->{_started}; $_[0]->{__XSE}->SUPER::processing_instruction({ Target => $_[1], Data => $_[2] }); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_start_cdata #-------------------------------------------------------------------# sub _handle_start_cdata { $_[0]->{__XSE}->SUPER::start_cdata( {} ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_end_cdata #-------------------------------------------------------------------# sub _handle_end_cdata { $_[0]->{__XSE}->SUPER::end_cdata( {} ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_xml_decl #-------------------------------------------------------------------# sub _handle_xml_decl { my $self = shift()->{__XSE}; my $version = shift; my $encoding = shift; my $standalone = shift; if (not defined $standalone) { $standalone = ''; } elsif ($standalone) { $standalone = 'yes'; } else { $standalone = 'no'; } my $xd = { Version => $version, Encoding => $encoding, Standalone => $standalone, }; #$self->SUPER::xml_decl($xd); $self->_handle_start_document($xd); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_notation_decl #-------------------------------------------------------------------# sub _handle_notation_decl { my $self = shift()->{__XSE}; my $notation = shift; shift; my $system = shift; my $public = shift; my $not = { Name => $notation, PublicId => $public, SystemId => $system, }; $self->SUPER::notation_decl($not); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_unparsed_entity #-------------------------------------------------------------------# sub _handle_unparsed_entity { my $self = shift()->{__XSE}; my $name = shift; my $system = shift; my $public = shift; my $notation = shift; my $ue = { Name => $name, PublicId => $public, SystemId => $system, Notation => $notation, }; $self->SUPER::unparsed_entity_decl($ue); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_element_decl #-------------------------------------------------------------------# sub _handle_element_decl { $_[0]->{__XSE}->SUPER::element_decl({ Name => $_[1], Model => "$_[2]" }); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_attr_decl #-------------------------------------------------------------------# sub _handle_attr_decl { my $self = shift()->{__XSE}; my $ename = shift; my $aname = shift; my $type = shift; my $default = shift; my $fixed = shift; my ($vd, $value); if ($fixed) { $vd = '#FIXED'; $default =~ s/^(?:"|')//; #" $default =~ s/(?:"|')$//; #" $value = $default; } else { if ($default =~ m/^#/) { $vd = $default; $value = ''; } else { $vd = ''; # maybe there's a default ? $default =~ s/^(?:"|')//; #" $default =~ s/(?:"|')$//; #" $value = $default; } } my $at = { eName => $ename, aName => $aname, Type => $type, ValueDefault => $vd, Value => $value, }; $self->SUPER::attribute_decl($at); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_entity_decl #-------------------------------------------------------------------# sub _handle_entity_decl { my $self = shift()->{__XSE}; my $name = shift; my $val = shift; my $sys = shift; my $pub = shift; my $ndata = shift; my $isprm = shift; # deal with param ents if ($isprm) { $name = '%' . $name; } # int vs ext if ($val) { my $ent = { Name => $name, Value => $val, }; $self->SUPER::internal_entity_decl($ent); } else { my $ent = { Name => $name, PublicId => $pub || '', SystemId => $sys, }; $self->SUPER::external_entity_decl($ent); } } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_start_doctype #-------------------------------------------------------------------# sub _handle_start_doctype { my $self = shift()->{__XSE}; my $name = shift; my $sys = shift; my $pub = shift; $self->_handle_start_document({}) unless $self->{_started}; my $dtd = { Name => $name, SystemId => $sys, PublicId => $pub, }; $self->SUPER::start_dtd($dtd); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_end_doctype #-------------------------------------------------------------------# sub _handle_end_doctype { $_[0]->{__XSE}->SUPER::end_dtd( {} ); } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # _handle_start_document #-------------------------------------------------------------------# sub _handle_start_document { $_[0]->SUPER::start_document($_[1]); $_[0]->{_started} = 1; } #-------------------------------------------------------------------# #-------------------------------------------------------------------# # supported_features #-------------------------------------------------------------------# sub supported_features { return ( $_[0]->SUPER::supported_features, 'http://xml.org/sax/features/external-general-entities', 'http://xml.org/sax/features/external-parameter-entities', ); } #-------------------------------------------------------------------# #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Private Helpers `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# #-------------------------------------------------------------------# # _create_node #-------------------------------------------------------------------# #sub _create_node { # shift; # # this may check for a factory later # return {@_}; #} #-------------------------------------------------------------------# 1; #,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,# #`,`, Documentation `,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,`,# #```````````````````````````````````````````````````````````````````# =pod =head1 NAME XML::SAX::Expat - SAX2 Driver for Expat (XML::Parser) =head1 SYNOPSIS use XML::SAX::Expat; use XML::SAX::MyFooHandler; my $h = XML::SAX::MyFooHandler->new; my $p = XML::SAX::Expat->new(Handler => $h); $p->parse_file('/path/to/foo.xml'); =head1 DESCRIPTION This is an implementation of a SAX2 driver sitting on top of Expat (XML::Parser) which Ken MacLeod posted to perl-xml and which I have updated. It is still incomplete, though most of the basic SAX2 events should be available. The SAX2 spec is currently available from L<http://perl-xml.sourceforge.net/perl-sax/>. A more friendly URL as well as a PODification of the spec are in the works. =head1 METHODS The methods defined in this class correspond to those listed in the PerlSAX2 specification, available above. =head1 FEATURES AND CAVEATS =over 2 =item supported_features Returns: * http://xml.org/sax/features/external-general-entities * http://xml.org/sax/features/external-parameter-entities * [ Features supported by ancestors ] Turning one of the first two on also turns the other on (this maps to the XML::Parser ParseParamEnts option). This may be fixed in the future, so don't rely on this behaviour. =back =head1 MISSING PARTS XML::Parser has no listed callbacks for the following events, which are therefore not presently generated (ways may be found in the future): * ignorable_whitespace * skipped_entity * start_entity / end_entity * resolve_entity Ways of signalling them are welcome. In addition to those, set_document_locator is not yet called. =head1 TODO - reuse Ken's tests and add more =head1 AUTHOR Robin Berjon; stolen from Ken Macleod, ken@bitsko.slc.ut.us, and with suggestions and feedback from perl-xml. Currently maintained by Bjoern Hoehrmann, L<http://bjoern.hoehrmann.de/>. =head1 COPYRIGHT AND LICENSE Copyright (c) 2001-2008 Robin Berjon. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO XML::Parser::PerlSAX =cut perl5/XML/SAX/Intro.pod 0000444 00000034741 14711217577 0010510 0 ustar 00 =head1 NAME XML::SAX::Intro - An Introduction to SAX Parsing with Perl =head1 Introduction XML::SAX is a new way to work with XML Parsers in Perl. In this article we'll discuss why you should be using SAX, why you should be using XML::SAX, and we'll see some of the finer implementation details. The text below assumes some familiarity with callback, or push based parsing, but if you are unfamiliar with these techniques then a good place to start is Kip Hampton's excellent series of articles on XML.com. =head1 Replacing XML::Parser The de-facto way of parsing XML under perl is to use Larry Wall and Clark Cooper's XML::Parser. This module is a Perl and XS wrapper around the expat XML parser library by James Clark. It has been a hugely successful project, but suffers from a couple of rather major flaws. Firstly it is a proprietary API, designed before the SAX API was conceived, which means that it is not easily replaceable by other streaming parsers. Secondly it's callbacks are subrefs. This doesn't sound like much of an issue, but unfortunately leads to code like: sub handle_start { my ($e, $el, %attrs) = @_; if ($el eq 'foo') { $e->{inside_foo}++; # BAD! $e is an XML::Parser::Expat object. } } As you can see, we're using the $e object to hold our state information, which is a bad idea because we don't own that object - we didn't create it. It's an internal object of XML::Parser, that happens to be a hashref. We could all too easily overwrite XML::Parser internal state variables by using this, or Clark could change it to an array ref (not that he would, because it would break so much code, but he could). The only way currently with XML::Parser to safely maintain state is to use a closure: my $state = MyState->new(); $parser->setHandlers(Start => sub { handle_start($state, @_) }); This closure traps the $state variable, which now gets passed as the first parameter to your callback. Unfortunately very few people use this technique, as it is not documented in the XML::Parser POD files. Another reason you might not want to use XML::Parser is because you need some feature that it doesn't provide (such as validation), or you might need to use a library that doesn't use expat, due to it not being installed on your system, or due to having a restrictive ISP. Using SAX allows you to work around these restrictions. =head1 Introducing SAX SAX stands for the Simple API for XML. And simple it really is. Constructing a SAX parser and passing events to handlers is done as simply as: use XML::SAX; use MySAXHandler; my $parser = XML::SAX::ParserFactory->parser( Handler => MySAXHandler->new ); $parser->parse_uri("foo.xml"); The important concept to grasp here is that SAX uses a factory class called XML::SAX::ParserFactory to create a new parser instance. The reason for this is so that you can support other underlying parser implementations for different feature sets. This is one thing that XML::Parser has always sorely lacked. In the code above we see the parse_uri method used, but we could have equally well called parse_file, parse_string, or parse(). Please see XML::SAX::Base for what these methods take as parameters, but don't be fooled into believing parse_file takes a filename. No, it takes a file handle, a glob, or a subclass of IO::Handle. Beware. SAX works very similarly to XML::Parser's default callback method, except it has one major difference: rather than setting individual callbacks, you create a new class in which to receive the callbacks. Each callback is called as a method call on an instance of that handler class. An example will best demonstrate this: package MySAXHandler; use base qw(XML::SAX::Base); sub start_document { my ($self, $doc) = @_; # process document start event } sub start_element { my ($self, $el) = @_; # process element start event } Now, when we instantiate this as above, and parse some XML with this as the handler, the methods start_document and start_element will be called as method calls, so this would be the equivalent of directly calling: $object->start_element($el); Notice how this is different to XML::Parser's calling style, which calls: start_element($e, $name, %attribs); It's the difference between function calling and method calling which allows you to subclass SAX handlers which contributes to SAX being a powerful solution. As you can see, unlike XML::Parser, we have to define a new package in which to do our processing (there are hacks you can do to make this uneccessary, but I'll leave figuring those out to the experts). The biggest benefit of this is that you maintain your own state variable ($self in the above example) thus freeing you of the concerns listed above. It is also an improvement in maintainability - you can place the code in a separate file if you wish to, and your callback methods are always called the same thing, rather than having to choose a suitable name for them as you had to with XML::Parser. This is an obvious win. SAX parsers are also very flexible in how you pass a handler to them. You can use a constructor parameter as we saw above, or we can pass the handler directly in the call to one of the parse methods: $parser->parse(Handler => $handler, Source => { SystemId => "foo.xml" }); # or... $parser->parse_file($fh, Handler => $handler); This flexibility allows for one parser to be used in many different scenarios throughout your script (though one shouldn't feel pressure to use this method, as parser construction is generally not a time consuming process). =head1 Callback Parameters The only other thing you need to know to understand basic SAX is the structure of the parameters passed to each of the callbacks. In XML::Parser, all parameters are passed as multiple options to the callbacks, so for example the Start callback would be called as my_start($e, $name, %attributes), and the PI callback would be called as my_processing_instruction($e, $target, $data). In SAX, every callback is passed a hash reference, containing entries that define our "node". The key callbacks and the structures they receive are: =head2 start_element The start_element handler is called whenever a parser sees an opening tag. It is passed an element structure consisting of: =over 4 =item LocalName The name of the element minus any namespace prefix it may have come with in the document. =item NamespaceURI The URI of the namespace associated with this element, or the empty string for none. =item Attributes A set of attributes as described below. =item Name The name of the element as it was seen in the document (i.e. including any prefix associated with it) =item Prefix The prefix used to qualify this element's namespace, or the empty string if none. =back The B<Attributes> are a hash reference, keyed by what we have called "James Clark" notation. This means that the attribute name has been expanded to include any associated namespace URI, and put together as {ns}name, where "ns" is the expanded namespace URI of the attribute if and only if the attribute had a prefix, and "name" is the LocalName of the attribute. The value of each entry in the attributes hash is another hash structure consisting of: =over 4 =item LocalName The name of the attribute minus any namespace prefix it may have come with in the document. =item NamespaceURI The URI of the namespace associated with this attribute. If the attribute had no prefix, then this consists of just the empty string. =item Name The attribute's name as it appeared in the document, including any namespace prefix. =item Prefix The prefix used to qualify this attribute's namepace, or the empty string if none. =item Value The value of the attribute. =back So a full example, as output by Data::Dumper might be: .... =head2 end_element The end_element handler is called either when a parser sees a closing tag, or after start_element has been called for an empty element (do note however that a parser may if it is so inclined call characters with an empty string when it sees an empty element. There is no simple way in SAX to determine if the parser in fact saw an empty element, a start and end element with no content.. The end_element handler receives exactly the same structure as start_element, minus the Attributes entry. One must note though that it should not be a reference to the same data as start_element receives, so you may change the values in start_element but this will not affect the values later seen by end_element. =head2 characters The characters callback may be called in serveral circumstances. The most obvious one is when seeing ordinary character data in the markup. But it is also called for text in a CDATA section, and is also called in other situations. A SAX parser has to make no guarantees whatsoever about how many times it may call characters for a stretch of text in an XML document - it may call once, or it may call once for every character in the text. In order to work around this it is often important for the SAX developer to use a bundling technique, where text is gathered up and processed in one of the other callbacks. This is not always necessary, but it is a worthwhile technique to learn, which we will cover in XML::SAX::Advanced (when I get around to writing it). The characters handler is called with a very simple structure - a hash reference consisting of just one entry: =over 4 =item Data The text data that was received. =back =head2 comment The comment callback is called for comment text. Unlike with C<characters()>, the comment callback *must* be invoked just once for an entire comment string. It receives a single simple structure - a hash reference containing just one entry: =over 4 =item Data The text of the comment. =back =head2 processing_instruction The processing instruction handler is called for all processing instructions in the document. Note that these processing instructions may appear before the document root element, or after it, or anywhere where text and elements would normally appear within the document, according to the XML specification. The handler is passed a structure containing just two entries: =over 4 =item Target The target of the processing instrcution =item Data The text data in the processing instruction. Can be an empty string for a processing instruction that has no data element. For example E<lt>?wiggle?E<gt> is a perfectly valid processing instruction. =back =head1 Tip of the iceberg What we have discussed above is really the tip of the SAX iceberg. And so far it looks like there's not much of interest to SAX beyond what we have seen with XML::Parser. But it does go much further than that, I promise. People who hate Object Oriented code for the sake of it may be thinking here that creating a new package just to parse something is a waste when they've been parsing things just fine up to now using procedural code. But there's reason to all this madness. And that reason is SAX Filters. As you saw right at the very start, to let the parser know about our class, we pass it an instance of our class as the Handler to the parser. But now imagine what would happen if our class could also take a Handler option, and simply do some processing and pass on our data further down the line? That in a nutshell is how SAX filters work. It's Unix pipes for the 21st century! There are two downsides to this. Number 1 - writing SAX filters can be tricky. If you look into the future and read the advanced tutorial I'm writing, you'll see that Handler can come in several shapes and sizes. So making sure your filter does the right thing can be tricky. Secondly, constructing complex filter chains can be difficult, and simple thinking tells us that we only get one pass at our document, when often we'll need more than that. Luckily though, those downsides have been fixed by the release of two very cool modules. What's even better is that I didn't write either of them! The first module is XML::SAX::Base. This is a VITAL SAX module that acts as a base class for all SAX parsers and filters. It provides an abstraction away from calling the handler methods, that makes sure your filter or parser does the right thing, and it does it FAST. So, if you ever need to write a SAX filter, which if you're processing XML -> XML, or XML -> HTML, then you probably do, then you need to be writing it as a subclass of XML::SAX::Base. Really - this is advice not to ignore lightly. I will not go into the details of writing a SAX filter here. Kip Hampton, the author of XML::SAX::Base has covered this nicely in his article on XML.com here <URI>. To construct SAX pipelines, Barrie Slaymaker, a long time Perl hacker whose modules you will probably have heard of or used, wrote a very clever module called XML::SAX::Machines. This combines some really clever SAX filter-type modules, with a construction toolkit for filters that makes building pipelines easy. But before we see how it makes things easy, first lets see how tricky it looks to build complex SAX filter pipelines. use XML::SAX::ParserFactory; use XML::Filter::Filter1; use XML::Filter::Filter2; use XML::SAX::Writer; my $output_string; my $writer = XML::SAX::Writer->new(Output => \$output_string); my $filter2 = XML::SAX::Filter2->new(Handler => $writer); my $filter1 = XML::SAX::Filter1->new(Handler => $filter2); my $parser = XML::SAX::ParserFactory->parser(Handler => $filter1); $parser->parse_uri("foo.xml"); This is a lot easier with XML::SAX::Machines: use XML::SAX::Machines qw(Pipeline); my $output_string; my $parser = Pipeline( XML::SAX::Filter1 => XML::SAX::Filter2 => \$output_string ); $parser->parse_uri("foo.xml"); One of the main benefits of XML::SAX::Machines is that the pipelines are constructed in natural order, rather than the reverse order we saw with manual pipeline construction. XML::SAX::Machines takes care of all the internals of pipe construction, providing you at the end with just a parser you can use (and you can re-use the same parser as many times as you need to). Just a final tip. If you ever get stuck and are confused about what is being passed from one SAX filter or parser to the next, then Devel::TraceSAX will come to your rescue. This perl debugger plugin will allow you to dump the SAX stream of events as it goes by. Usage is really very simple just call your perl script that uses SAX as follows: $ perl -d:TraceSAX <scriptname> And preferably pipe the output to a pager of some sort, such as more or less. The output is extremely verbose, but should help clear some issues up. =head1 AUTHOR Matt Sergeant, matt@sergeant.org $Id$ =cut perl5/XML/Simple/FAQ.pod 0000444 00000050660 14711217577 0010620 0 ustar 00 =head1 NAME XML::Simple::FAQ - Frequently Asked Questions about XML::Simple =head1 Basics =head2 What should I use XML::Simple for? Nothing! It's as simple as that. Choose a better module. See L<Perl XML::LibXML by Example|http://grantm.github.io/perl-libxml-by-example/> for a gentle introduction to L<XML::LibXML> with lots of examples. =head2 What was XML::Simple designed to be used for? XML::Simple is a Perl module that was originally developed as a tool for reading and writing configuration data in XML format. You could use it for other purposes that involve storing and retrieving structured data in XML but it's likely to be a frustrating experience. =head2 Why store configuration data in XML anyway? It seemed like a good idea at the time. Now, I use and recommend L<Config::General> which uses a format similar to that used by the Apache web server. This is easier to read than XML while still allowing advanced concepts such as nested sections. At the time XML::Simple was written, the advantages of using XML format for configuration data were thought to include: =over 4 =item * Using existing XML parsing tools requires less development time, is easier and more robust than developing your own config file parsing code =item * XML can represent relationships between pieces of data, such as nesting of sections to arbitrary levels (not easily done with .INI files for example) =item * XML is basically just text, so you can easily edit a config file (easier than editing a Win32 registry) =item * XML provides standard solutions for handling character sets and encoding beyond basic ASCII (important for internationalization) =item * If it becomes necessary to change your configuration file format, there are many tools available for performing transformations on XML files =item * XML is an open standard (the world does not need more proprietary binary file formats) =item * Taking the extra step of developing a DTD allows the format of configuration files to be validated before your program reads them (not directly supported by XML::Simple) =item * Combining a DTD with a good XML editor can give you a GUI config editor for minimal coding effort =back =head2 What isn't XML::Simple good for? The main limitation of XML::Simple is that it does not work with 'mixed content' (see the next question). If you consider your XML files contain marked up text rather than structured data, you should probably use another module. If your source XML documents change regularly, it's likely that you will experience intermittent failures. In particular, failure to properly use the ForceArray and KeyAttr options will produce code that works when you get a list of elements with the same name, but fails when there's only one item in the list. These types of problems can be avoided by not using XML::Simple in the first place. If you are working with very large XML files, XML::Simple's approach of representing the whole file in memory as a 'tree' data structure may not be suitable. =head2 What is mixed content? Consider this example XML: <document> <para>This is <em>mixed</em> content.</para> </document> This is said to be mixed content, because the E<lt>paraE<gt> element contains both character data (text content) and nested elements. Here's some more XML: <person> <first_name>Joe</first_name> <last_name>Bloggs</last_name> <dob>25-April-1969</dob> </person> This second example is not generally considered to be mixed content. The E<lt>first_nameE<gt>, E<lt>last_nameE<gt> and E<lt>dobE<gt> elements contain only character data and the E<lt>personE<gt> element contains only nested elements. (Note: Strictly speaking, the whitespace between the nested elements is character data, but it is ignored by XML::Simple). =head2 Why doesn't XML::Simple handle mixed content? Because if it did, it would no longer be simple :-) Seriously though, there are plenty of excellent modules that allow you to work with mixed content in a variety of ways. Handling mixed content correctly is not easy and by ignoring these issues, XML::Simple is able to present an API without a steep learning curve. =head2 Which Perl modules do handle mixed content? Every one of them except XML::Simple :-) If you're looking for a recommendation, I'd suggest you look at the Perl-XML FAQ at: http://perl-xml.sourceforge.net/faq/ =head1 Installation =head2 How do I install XML::Simple? If you're running ActiveState Perl, or L<Strawberry Perl|http://strawberryperl.com/> you've probably already got XML::Simple and therefore do not need to install it at all. But you probably also have L<XML::LibXML>, which is a much better module, so just use that. If you do need to install XML::Simple, you'll need to install an XML parser module first. Install either XML::Parser (which you may have already) or XML::SAX. If you install both, XML::SAX will be used by default. Once you have a parser installed ... On Unix systems, try: perl -MCPAN -e 'install XML::Simple' If that doesn't work, download the latest distribution from ftp://ftp.cpan.org/pub/CPAN/authors/id/G/GR/GRANTM , unpack it and run these commands: perl Makefile.PL make make test make install On Win32, if you have a recent build of ActiveState Perl (618 or better) try this command: ppm install XML::Simple If that doesn't work, you really only need the Simple.pm file, so extract it from the .tar.gz file (eg: using WinZIP) and save it in the \site\lib\XML directory under your Perl installation (typically C:\Perl). =head2 I'm trying to install XML::Simple and 'make test' fails Is the directory where you've unpacked XML::Simple mounted from a file server using NFS, SMB or some other network file sharing? If so, that may cause errors in the following test scripts: 3_Storable.t 4_MemShare.t 5_MemCopy.t The test suite is designed to exercise the boundary conditions of all XML::Simple's functionality and these three scripts exercise the caching functions. If XML::Simple is asked to parse a file for which it has a cached copy of a previous parse, then it compares the timestamp on the XML file with the timestamp on the cached copy. If the cached copy is *newer* then it will be used. If the cached copy is older or the same age then the file is re-parsed. The test scripts will get confused by networked filesystems if the workstation and server system clocks are not synchronised (to the second). If you get an error in one of these three test scripts but you don't plan to use the caching options (they're not enabled by default), then go right ahead and run 'make install'. If you do plan to use caching, then try unpacking the distribution on local disk and doing the build/test there. It's probably not a good idea to use the caching options with networked filesystems in production. If the file server's clock is ahead of the local clock, XML::Simple will re-parse files when it could have used the cached copy. However if the local clock is ahead of the file server clock and a file is changed immediately after it is cached, the old cached copy will be used. Is one of the three test scripts (above) failing but you're not running on a network filesystem? Are you running Win32? If so, you may be seeing a bug in Win32 where writes to a file do not affect its modification timestamp. If none of these scenarios match your situation, please confirm you're running the latest version of XML::Simple and then email the output of 'make test' to me at grantm@cpan.org =head2 Why is XML::Simple so slow? If you find that XML::Simple is very slow reading XML, the most likely reason is that you have XML::SAX installed but no additional SAX parser module. The XML::SAX distribution includes an XML parser written entirely in Perl. This is very portable but not very fast. For better performance install either XML::SAX::Expat or XML::LibXML. =head1 Usage =head2 How do I use XML::Simple? If you don't know how to use XML::Simple then the best approach is to L<learn to use XML::LibXML|http://grantm.github.io/perl-libxml-by-example/> instead. Stop reading this document and use that one instead. If you are determined to use XML::Simple, it come with copious documentation, so L<read that|XML::Simple>. =head2 There are so many options, which ones do I really need to know about? Although you can get by without using any options, you shouldn't even consider using XML::Simple in production until you know what these two options do: =over 4 =item * forcearray =item * keyattr =back The reason you really need to read about them is because the default values for these options will trip you up if you don't. Although everyone agrees that these defaults are not ideal, there is not wide agreement on what they should be changed to. The answer therefore is to read about them (see below) and select values which are right for you. =head2 What is the forcearray option all about? Consider this XML in a file called ./person.xml: <person> <first_name>Joe</first_name> <last_name>Bloggs</last_name> <hobbie>bungy jumping</hobbie> <hobbie>sky diving</hobbie> <hobbie>knitting</hobbie> </person> You could read it in with this line: my $person = XMLin('./person.xml'); Which would give you a data structure like this: $person = { 'first_name' => 'Joe', 'last_name' => 'Bloggs', 'hobbie' => [ 'bungy jumping', 'sky diving', 'knitting' ] }; The E<lt>first_nameE<gt> and E<lt>last_nameE<gt> elements are represented as simple scalar values which you could refer to like this: print "$person->{first_name} $person->{last_name}\n"; The E<lt>hobbieE<gt> elements are represented as an array - since there is more than one. You could refer to the first one like this: print $person->{hobbie}->[0], "\n"; Or the whole lot like this: print join(', ', @{$person->{hobbie}} ), "\n"; The catch is, that these last two lines of code will only work for people who have more than one hobbie. If there is only one E<lt>hobbieE<gt> element, it will be represented as a simple scalar (just like E<lt>first_nameE<gt> and E<lt>last_nameE<gt>). Which might lead you to write code like this: if(ref($person->{hobbie})) { print join(', ', @{$person->{hobbie}} ), "\n"; } else { print $person->{hobbie}, "\n"; } Don't do that. One alternative approach is to set the forcearray option to a true value: my $person = XMLin('./person.xml', forcearray => 1); Which will give you a data structure like this: $person = { 'first_name' => [ 'Joe' ], 'last_name' => [ 'Bloggs' ], 'hobbie' => [ 'bungy jumping', 'sky diving', 'knitting' ] }; Then you can use this line to refer to all the list of hobbies even if there was only one: print join(', ', @{$person->{hobbie}} ), "\n"; The downside of this approach is that the E<lt>first_nameE<gt> and E<lt>last_nameE<gt> elements will also always be represented as arrays even though there will never be more than one: print "$person->{first_name}->[0] $person->{last_name}->[0]\n"; This might be OK if you change the XML to use attributes for things that will always be singular and nested elements for things that may be plural: <person first_name="Jane" last_name="Bloggs"> <hobbie>motorcycle maintenance</hobbie> </person> On the other hand, if you prefer not to use attributes, then you could specify that any E<lt>hobbieE<gt> elements should always be represented as arrays and all other nested elements should be simple scalar values unless there is more than one: my $person = XMLin('./person.xml', forcearray => [ 'hobbie' ]); The forcearray option accepts a list of element names which should always be forced to an array representation: forcearray => [ qw(hobbie qualification childs_name) ] See the XML::Simple manual page for more information. =head2 What is the keyattr option all about? Consider this sample XML: <catalog> <part partnum="1842334" desc="High pressure flange" price="24.50" /> <part partnum="9344675" desc="Threaded gasket" price="9.25" /> <part partnum="5634896" desc="Low voltage washer" price="12.00" /> </catalog> You could slurp it in with this code: my $catalog = XMLin('./catalog.xml'); Which would return a data structure like this: $catalog = { 'part' => [ { 'partnum' => '1842334', 'desc' => 'High pressure flange', 'price' => '24.50' }, { 'partnum' => '9344675', 'desc' => 'Threaded gasket', 'price' => '9.25' }, { 'partnum' => '5634896', 'desc' => 'Low voltage washer', 'price' => '12.00' } ] }; Then you could access the description of the first part in the catalog with this code: print $catalog->{part}->[0]->{desc}, "\n"; However, if you wanted to access the description of the part with the part number of "9344675" then you'd have to code a loop like this: foreach my $part (@{$catalog->{part}}) { if($part->{partnum} eq '9344675') { print $part->{desc}, "\n"; last; } } The knowledge that each E<lt>partE<gt> element has a unique partnum attribute allows you to eliminate this search. You can pass this knowledge on to XML::Simple like this: my $catalog = XMLin($xml, keyattr => ['partnum']); Which will return a data structure like this: $catalog = { 'part' => { '5634896' => { 'desc' => 'Low voltage washer', 'price' => '12.00' }, '1842334' => { 'desc' => 'High pressure flange', 'price' => '24.50' }, '9344675' => { 'desc' => 'Threaded gasket', 'price' => '9.25' } } }; XML::Simple has been able to transform $catalog->{part} from an arrayref to a hashref (keyed on partnum). This transformation is called 'array folding'. Through the use of array folding, you can now index directly to the description of the part you want: print $catalog->{part}->{9344675}->{desc}, "\n"; The 'keyattr' option also enables array folding when the unique key is in a nested element rather than an attribute. eg: <catalog> <part> <partnum>1842334</partnum> <desc>High pressure flange</desc> <price>24.50</price> </part> <part> <partnum>9344675</partnum> <desc>Threaded gasket</desc> <price>9.25</price> </part> <part> <partnum>5634896</partnum> <desc>Low voltage washer</desc> <price>12.00</price> </part> </catalog> See the XML::Simple manual page for more information. =head2 So what's the catch with 'keyattr'? One thing to watch out for is that you might get array folding even if you don't supply the keyattr option. The default value for this option is: [ 'name', 'key', 'id'] Which means if your XML elements have a 'name', 'key' or 'id' attribute (or nested element) then they may get folded on those values. This means that you can take advantage of array folding simply through careful choice of attribute names. On the hand, if you really don't want array folding at all, you'll need to set 'key attr to an empty list: my $ref = XMLin($xml, keyattr => []); A second 'gotcha' is that array folding only works on arrays. That might seem obvious, but if there's only one record in your XML and you didn't set the 'forcearray' option then it won't be represented as an array and consequently won't get folded into a hash. The moral is that if you're using array folding, you should always turn on the forcearray option. You probably want to be as specific as you can be too. For instance, the safest way to parse the E<lt>catalogE<gt> example above would be: my $catalog = XMLin($xml, keyattr => { part => 'partnum'}, forcearray => ['part']); By using the hashref for keyattr, you can specify that only E<lt>partE<gt> elements should be folded on the 'partnum' attribute (and that the E<lt>partE<gt> elements should not be folded on any other attribute). By supplying a list of element names for forcearray, you're ensuring that folding will work even if there's only one E<lt>partE<gt>. You're also ensuring that if the 'partnum' unique key is supplied in a nested element then that element won't get forced to an array too. =head2 How do I know what my data structure should look like? The rules are fairly straightforward: =over 4 =item * each element gets represented as a hash =item * unless it contains only text, in which case it'll be a simple scalar value =item * or unless there's more than one element with the same name, in which case they'll be represented as an array =item * unless you've got array folding enabled, in which case they'll be folded into a hash =item * empty elements (no text contents B<and> no attributes) will either be represented as an empty hash, an empty string or undef - depending on the value of the 'suppressempty' option. =back If you're in any doubt, use Data::Dumper, eg: use XML::Simple; use Data::Dumper; my $ref = XMLin($xml); print Dumper($ref); =head2 I'm getting 'Use of uninitialized value' warnings You're probably trying to index into a non-existant hash key - try Data::Dumper. =head2 I'm getting a 'Not an ARRAY reference' error Something that you expect to be an array is not. The two most likely causes are that you forgot to use 'forcearray' or that the array got folded into a hash - try Data::Dumper. =head2 I'm getting a 'No such array field' error Something that you expect to be a hash is actually an array. Perhaps array folding failed because one element was missing the key attribute - try Data::Dumper. =head2 I'm getting an 'Out of memory' error Something in the data structure is not as you expect and Perl may be trying unsuccessfully to autovivify things - try Data::Dumper. If you're already using Data::Dumper, try calling Dumper() immediately after XMLin() - ie: before you attempt to access anything in the data structure. =head2 My element order is getting jumbled up If you read an XML file with XMLin() and then write it back out with XMLout(), the order of the elements will likely be different. (However, if you read the file back in with XMLin() you'll get the same Perl data structure). The reordering happens because XML::Simple uses hashrefs to store your data and Perl hashes do not really have any order. It is possible that a future version of XML::Simple will use Tie::IxHash to store the data in hashrefs which do retain the order. However this will not fix all cases of element order being lost. If your application really is sensitive to element order, don't use XML::Simple (and don't put order-sensitive values in attributes). =head2 XML::Simple turns nested elements into attributes If you read an XML file with XMLin() and then write it back out with XMLout(), some data which was originally stored in nested elements may end up in attributes. (However, if you read the file back in with XMLin() you'll get the same Perl data structure). There are a number of ways you might handle this: =over 4 =item * use the 'forcearray' option with XMLin() =item * use the 'noattr' option with XMLout() =item * live with it =item * don't use XML::Simple =back =head2 Why does XMLout() insert E<lt>nameE<gt> elements (or attributes)? Try setting keyattr => []. When you call XMLin() to read XML, the 'keyattr' option controls whether arrays get 'folded' into hashes. Similarly, when you call XMLout(), the 'keyattr' option controls whether hashes get 'unfolded' into arrays. As described above, 'keyattr' is enabled by default. =head2 Why are empty elements represented as empty hashes? An element is always represented as a hash unless it contains only text, in which case it is represented as a scalar string. If you would prefer empty elements to be represented as empty strings or the undefined value, set the 'suppressempty' option to '' or undef respectively. =head2 Why is ParserOpts deprecated? The C<ParserOpts> option is a remnant of the time when XML::Simple only worked with the XML::Parser API. Its value is completely ignored if you're using a SAX parser, so writing code which relied on it would bar you from taking advantage of SAX. Even if you are using XML::Parser, it is seldom necessary to pass options to the parser object. A number of people have written to say they use this option to set XML::Parser's C<ProtocolEncoding> option. Don't do that, it's wrong, Wrong, WRONG! Fix the XML document so that it's well-formed and you won't have a problem. Having said all of that, as long as XML::Simple continues to support the XML::Parser API, this option will not be removed. There are currently no plans to remove support for the XML::Parser API. =cut perl5/XML/NamespaceSupport.pm 0000444 00000046752 14711217602 0012077 0 ustar 00 package XML::NamespaceSupport; use strict; our $VERSION = '1.12'; # VERSION # ABSTRACT: A simple generic namespace processor use constant FATALS => 0; # root object use constant NSMAP => 1; use constant UNKNOWN_PREF => 2; use constant AUTO_PREFIX => 3; use constant XMLNS_11 => 4; use constant DEFAULT => 0; # maps use constant PREFIX_MAP => 1; use constant DECLARATIONS => 2; use vars qw($NS_XMLNS $NS_XML); $NS_XMLNS = 'http://www.w3.org/2000/xmlns/'; $NS_XML = 'http://www.w3.org/XML/1998/namespace'; # add the ns stuff that baud wants based on Java's xml-writer #-------------------------------------------------------------------# # constructor #-------------------------------------------------------------------# sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $options = shift; my $self = [ 1, # FATALS [[ # NSMAP undef, # DEFAULT { xml => $NS_XML }, # PREFIX_MAP undef, # DECLARATIONS ]], 'aaa', # UNKNOWN_PREF 0, # AUTO_PREFIX 1, # XML_11 ]; $self->[NSMAP]->[0]->[PREFIX_MAP]->{xmlns} = $NS_XMLNS if $options->{xmlns}; $self->[FATALS] = $options->{fatal_errors} if defined $options->{fatal_errors}; $self->[AUTO_PREFIX] = $options->{auto_prefix} if defined $options->{auto_prefix}; $self->[XMLNS_11] = $options->{xmlns_11} if defined $options->{xmlns_11}; return bless $self, $class; } #-------------------------------------------------------------------# # reset() - return to the original state (for reuse) #-------------------------------------------------------------------# sub reset { my $self = shift; $#{$self->[NSMAP]} = 0; } #-------------------------------------------------------------------# # push_context() - add a new empty context to the stack #-------------------------------------------------------------------# sub push_context { my $self = shift; push @{$self->[NSMAP]}, [ $self->[NSMAP]->[-1]->[DEFAULT], { %{$self->[NSMAP]->[-1]->[PREFIX_MAP]} }, [], ]; } #-------------------------------------------------------------------# # pop_context() - remove the topmost context from the stack #-------------------------------------------------------------------# sub pop_context { my $self = shift; die 'Trying to pop context without push context' unless @{$self->[NSMAP]} > 1; pop @{$self->[NSMAP]}; } #-------------------------------------------------------------------# # declare_prefix() - declare a prefix in the current scope #-------------------------------------------------------------------# sub declare_prefix { my $self = shift; my $prefix = shift; my $value = shift; warn <<' EOWARN' unless defined $prefix or $self->[AUTO_PREFIX]; Prefix was undefined. If you wish to set the default namespace, use the empty string ''. If you wish to autogenerate prefixes, set the auto_prefix option to a true value. EOWARN no warnings 'uninitialized'; if ($prefix eq 'xml' and $value ne $NS_XML) { die "The xml prefix can only be bound to the $NS_XML namespace." } elsif ($value eq $NS_XML and $prefix ne 'xml') { die "the $NS_XML namespace can only be bound to the xml prefix."; } elsif ($value eq $NS_XML and $prefix eq 'xml') { return 1; } return 0 if index(lc($prefix), 'xml') == 0; use warnings 'uninitialized'; if (defined $prefix and $prefix eq '') { $self->[NSMAP]->[-1]->[DEFAULT] = $value; } else { die "Cannot declare prefix $prefix" if $value eq '' and not $self->[XMLNS_11]; if (not defined $prefix and $self->[AUTO_PREFIX]) { while (1) { $prefix = $self->[UNKNOWN_PREF]++; last if not exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; } } elsif (not defined $prefix and not $self->[AUTO_PREFIX]) { return 0; } $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix} = $value; } push @{$self->[NSMAP]->[-1]->[DECLARATIONS]}, $prefix; return 1; } #-------------------------------------------------------------------# # declare_prefixes() - declare several prefixes in the current scope #-------------------------------------------------------------------# sub declare_prefixes { my $self = shift; my %prefixes = @_; while (my ($k,$v) = each %prefixes) { $self->declare_prefix($k,$v); } } #-------------------------------------------------------------------# # undeclare_prefix #-------------------------------------------------------------------# sub undeclare_prefix { my $self = shift; my $prefix = shift; return if not defined($prefix); return unless exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; my ( $tfix ) = grep { $_ eq $prefix } @{$self->[NSMAP]->[-1]->[DECLARATIONS]}; if ( not defined $tfix ) { die "prefix $prefix not declared in this context\n"; } @{$self->[NSMAP]->[-1]->[DECLARATIONS]} = grep { $_ ne $prefix } @{$self->[NSMAP]->[-1]->[DECLARATIONS]}; delete $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; } #-------------------------------------------------------------------# # get_prefix() - get a (random) prefix for a given URI #-------------------------------------------------------------------# sub get_prefix { my $self = shift; my $uri = shift; # we have to iterate over the whole hash here because if we don't # the iterator isn't reset and the next pass will fail my $pref; while (my ($k, $v) = each %{$self->[NSMAP]->[-1]->[PREFIX_MAP]}) { $pref = $k if $v eq $uri; } return $pref; } #-------------------------------------------------------------------# # get_prefixes() - get all the prefixes for a given URI #-------------------------------------------------------------------# sub get_prefixes { my $self = shift; my $uri = shift; return keys %{$self->[NSMAP]->[-1]->[PREFIX_MAP]} unless defined $uri; return grep { $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$_} eq $uri } keys %{$self->[NSMAP]->[-1]->[PREFIX_MAP]}; } #-------------------------------------------------------------------# # get_declared_prefixes() - get all prefixes declared in the last context #-------------------------------------------------------------------# sub get_declared_prefixes { my $declarations = $_[0]->[NSMAP]->[-1]->[DECLARATIONS]; die "At least one context must be pushed onto stack with push_context()\n", "before calling get_declared_prefixes()" if not defined $declarations; return @{$_[0]->[NSMAP]->[-1]->[DECLARATIONS]}; } #-------------------------------------------------------------------# # get_uri() - get a URI given a prefix #-------------------------------------------------------------------# sub get_uri { my $self = shift; my $prefix = shift; warn "Prefix must not be undef in get_uri(). The emtpy prefix must be ''" unless defined $prefix; return $self->[NSMAP]->[-1]->[DEFAULT] if $prefix eq ''; return $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix} if exists $self->[NSMAP]->[-1]->[PREFIX_MAP]->{$prefix}; return undef; } #-------------------------------------------------------------------# # process_name() - provide details on a name #-------------------------------------------------------------------# sub process_name { my $self = shift; my $qname = shift; my $aflag = shift; if ($self->[FATALS]) { return( ($self->_get_ns_details($qname, $aflag))[0,2], $qname ); } else { eval { return( ($self->_get_ns_details($qname, $aflag))[0,2], $qname ); } } } #-------------------------------------------------------------------# # process_element_name() - provide details on a element's name #-------------------------------------------------------------------# sub process_element_name { my $self = shift; my $qname = shift; if ($self->[FATALS]) { return $self->_get_ns_details($qname, 0); } else { eval { return $self->_get_ns_details($qname, 0); } } } #-------------------------------------------------------------------# # process_attribute_name() - provide details on a attribute's name #-------------------------------------------------------------------# sub process_attribute_name { my $self = shift; my $qname = shift; if ($self->[FATALS]) { return $self->_get_ns_details($qname, 1); } else { eval { return $self->_get_ns_details($qname, 1); } } } #-------------------------------------------------------------------# # ($ns, $prefix, $lname) = $self->_get_ns_details($qname, $f_attr) # returns ns, prefix, and lname for a given attribute name # >> the $f_attr flag, if set to one, will work for an attribute #-------------------------------------------------------------------# sub _get_ns_details { my $self = shift; my $qname = shift; my $aflag = shift; my ($ns, $prefix, $lname); (my ($tmp_prefix, $tmp_lname) = split /:/, $qname, 3) < 3 or die "Invalid QName: $qname"; # no prefix my $cur_map = $self->[NSMAP]->[-1]; if (not defined($tmp_lname)) { $prefix = undef; $lname = $qname; # attr don't have a default namespace $ns = ($aflag) ? undef : $cur_map->[DEFAULT]; } # prefix else { if (exists $cur_map->[PREFIX_MAP]->{$tmp_prefix}) { $prefix = $tmp_prefix; $lname = $tmp_lname; $ns = $cur_map->[PREFIX_MAP]->{$prefix} } else { # no ns -> lname == name, all rest undef die "Undeclared prefix: $tmp_prefix"; } } return ($ns, $prefix, $lname); } #-------------------------------------------------------------------# # parse_jclark_notation() - parse the Clarkian notation #-------------------------------------------------------------------# sub parse_jclark_notation { shift; my $jc = shift; $jc =~ m/^\{(.*)\}([^}]+)$/; return $1, $2; } #-------------------------------------------------------------------# # Java names mapping #-------------------------------------------------------------------# *XML::NamespaceSupport::pushContext = \&push_context; *XML::NamespaceSupport::popContext = \&pop_context; *XML::NamespaceSupport::declarePrefix = \&declare_prefix; *XML::NamespaceSupport::declarePrefixes = \&declare_prefixes; *XML::NamespaceSupport::getPrefix = \&get_prefix; *XML::NamespaceSupport::getPrefixes = \&get_prefixes; *XML::NamespaceSupport::getDeclaredPrefixes = \&get_declared_prefixes; *XML::NamespaceSupport::getURI = \&get_uri; *XML::NamespaceSupport::processName = \&process_name; *XML::NamespaceSupport::processElementName = \&process_element_name; *XML::NamespaceSupport::processAttributeName = \&process_attribute_name; *XML::NamespaceSupport::parseJClarkNotation = \&parse_jclark_notation; *XML::NamespaceSupport::undeclarePrefix = \&undeclare_prefix; 1; __END__ =pod =encoding UTF-8 =head1 NAME XML::NamespaceSupport - A simple generic namespace processor =head1 VERSION version 1.12 =head1 SYNOPSIS use XML::NamespaceSupport; my $nsup = XML::NamespaceSupport->new; # add a new empty context $nsup->push_context; # declare a few prefixes $nsup->declare_prefix($prefix1, $uri1); $nsup->declare_prefix($prefix2, $uri2); # the same shorter $nsup->declare_prefixes($prefix1 => $uri1, $prefix2 => $uri2); # get a single prefix for a URI (randomly) $prefix = $nsup->get_prefix($uri); # get all prefixes for a URI (probably better) @prefixes = $nsup->get_prefixes($uri); # get all prefixes in scope @prefixes = $nsup->get_prefixes(); # get all prefixes that were declared for the current scope @prefixes = $nsup->get_declared_prefixes; # get a URI for a given prefix $uri = $nsup->get_uri($prefix); # get info on a qname (java-ish way, it's a bit weird) ($ns_uri, $local_name, $qname) = $nsup->process_name($qname, $is_attr); # the same, more perlish ($ns_uri, $prefix, $local_name) = $nsup->process_element_name($qname); ($ns_uri, $prefix, $local_name) = $nsup->process_attribute_name($qname); # remove the current context $nsup->pop_context; # reset the object for reuse in another document $nsup->reset; # a simple helper to process Clarkian Notation my ($ns, $lname) = $nsup->parse_jclark_notation('{http://foo}bar'); # or (given that it doesn't care about the object my ($ns, $lname) = XML::NamespaceSupport->parse_jclark_notation('{http://foo}bar'); =head1 DESCRIPTION This module offers a simple to process namespaced XML names (unames) from within any application that may need them. It also helps maintain a prefix to namespace URI map, and provides a number of basic checks. The model for this module is SAX2's NamespaceSupport class, readable at http://www.saxproject.org/namespaces.html It adds a few perlisations where we thought it appropriate. =head1 NAME XML::NamespaceSupport - a simple generic namespace support class =head1 METHODS =over 4 =item * XML::NamespaceSupport->new(\%options) A simple constructor. The options are C<xmlns>, C<fatal_errors>, and C<auto_prefix> If C<xmlns> is turned on (it is off by default) the mapping from the xmlns prefix to the URI defined for it in DOM level 2 is added to the list of predefined mappings (which normally only contains the xml prefix mapping). If C<fatal_errors> is turned off (it is on by default) a number of validity errors will simply be flagged as failures, instead of die()ing. If C<auto_prefix> is turned on (it is off by default) when one provides a prefix of C<undef> to C<declare_prefix> it will generate a random prefix mapped to that namespace. Otherwise an undef prefix will trigger a warning (you should probably know what you're doing if you turn this option on). If C<xmlns_11> us turned off, it becomes illegal to undeclare namespace prefixes. It is on by default. This behaviour is compliant with Namespaces in XML 1.1, turning it off reverts you to version 1.0. =item * $nsup->push_context Adds a new empty context to the stack. You can then populate it with new prefixes defined at this level. =item * $nsup->pop_context Removes the topmost context in the stack and reverts to the previous one. It will die() if you try to pop more than you have pushed. =item * $nsup->declare_prefix($prefix, $uri) Declares a mapping of $prefix to $uri, at the current level. Note that with C<auto_prefix> turned on, if you declare a prefix mapping in which $prefix is undef(), you will get an automatic prefix selected for you. If it is off you will get a warning. This is useful when you deal with code that hasn't kept prefixes around and need to reserialize the nodes. It also means that if you want to set the default namespace (i.e. with an empty prefix) you must use the empty string instead of undef. This behaviour is consistent with the SAX 2.0 specification. =item * $nsup->declare_prefixes(%prefixes2uris) Declares a mapping of several prefixes to URIs, at the current level. =item * $nsup->get_prefix($uri) Returns a prefix given a URI. Note that as several prefixes may be mapped to the same URI, it returns an arbitrary one. It'll return undef on failure. =item * $nsup->get_prefixes($uri) Returns an array of prefixes given a URI. It'll return all the prefixes if the uri is undef. =item * $nsup->get_declared_prefixes Returns an array of all the prefixes that have been declared within this context, ie those that were declared on the last element, not those that were declared above and are simply in scope. Note that at least one context must be added to the stack via C<push_context> before this method can be called. =item * $nsup->get_uri($prefix) Returns a URI for a given prefix. Returns undef on failure. =item * $nsup->process_name($qname, $is_attr) Given a qualified name and a boolean indicating whether this is an attribute or another type of name (those are differently affected by default namespaces), it returns a namespace URI, local name, qualified name tuple. I know that that is a rather abnormal list to return, but it is so for compatibility with the Java spec. See below for more Perlish alternatives. If the prefix is not declared, or if the name is not valid, it'll either die or return undef depending on the current setting of C<fatal_errors>. =item * $nsup->undeclare_prefix($prefix); Removes a namespace prefix from the current context. This function may be used in SAX's end_prefix_mapping when there is fear that a namespace declaration might be available outside their scope (which shouldn't normally happen, but you never know ;) ). This may be needed in order to properly support Namespace 1.1. =item * $nsup->process_element_name($qname) Given a qualified name, it returns a namespace URI, prefix, and local name tuple. This method applies to element names. If the prefix is not declared, or if the name is not valid, it'll either die or return undef depending on the current setting of C<fatal_errors>. =item * $nsup->process_attribute_name($qname) Given a qualified name, it returns a namespace URI, prefix, and local name tuple. This method applies to attribute names. If the prefix is not declared, or if the name is not valid, it'll either die or return undef depending on the current setting of C<fatal_errors>. =item * $nsup->reset Resets the object so that it can be reused on another document. =back All methods of the interface have an alias that is the name used in the original Java specification. You can use either name interchangeably. Here is the mapping: Java name Perl name --------------------------------------------------- pushContext push_context popContext pop_context declarePrefix declare_prefix declarePrefixes declare_prefixes getPrefix get_prefix getPrefixes get_prefixes getDeclaredPrefixes get_declared_prefixes getURI get_uri processName process_name processElementName process_element_name processAttributeName process_attribute_name parseJClarkNotation parse_jclark_notation undeclarePrefix undeclare_prefix =head1 VARIABLES Two global variables are made available to you. They used to be constants but simple scalars are easier to use in a number of contexts. They are not exported but can easily be accessed from any package, or copied into it. =over 4 =item * C<$NS_XMLNS> The namespace for xmlns prefixes, http://www.w3.org/2000/xmlns/. =item * C<$NS_XML> The namespace for xml prefixes, http://www.w3.org/XML/1998/namespace. =back =head1 TODO - add more tests - optimise here and there =head1 SEE ALSO XML::Parser::PerlSAX =head1 AUTHORS =over 4 =item * Robin Berjon <robin@knowscape.com> =item * Chris Prather <chris@prather.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Robin Berjon. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 CONTRIBUTORS =for stopwords Chris Prather David Steinbrunner Paul Cochrane Paulo Custodio =over 4 =item * Chris Prather <cprather@hdpublishing.com> =item * David Steinbrunner <dsteinbrunner@pobox.com> =item * Paul Cochrane <paul@liekut.de> =item * Paulo Custodio <pauloscustodio@gmail.com> =back =cut perl5/JSON/PP/Boolean.pm 0000444 00000000651 14711217605 0010604 0 ustar 00 =head1 NAME JSON::PP::Boolean - dummy module providing JSON::PP::Boolean =head1 SYNOPSIS # do not "use" yourself =head1 DESCRIPTION This module exists only to provide overload resolution for Storable and similar modules. See L<JSON::PP> for more info about this class. =cut use JSON::PP (); use strict; 1; =head1 AUTHOR This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de> =cut perl5/JSON/PP.pm 0000444 00000240115 14711217606 0007227 0 ustar 00 package JSON::PP; # JSON-2.0 use 5.005; use strict; use base qw(Exporter); use overload (); use Carp (); use B (); #use Devel::Peek; $JSON::PP::VERSION = '2.27203'; @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); # instead of hash-access, i tried index-access for speed. # but this method is not faster than what i expected. so it will be changed. use constant P_ASCII => 0; use constant P_LATIN1 => 1; use constant P_UTF8 => 2; use constant P_INDENT => 3; use constant P_CANONICAL => 4; use constant P_SPACE_BEFORE => 5; use constant P_SPACE_AFTER => 6; use constant P_ALLOW_NONREF => 7; use constant P_SHRINK => 8; use constant P_ALLOW_BLESSED => 9; use constant P_CONVERT_BLESSED => 10; use constant P_RELAXED => 11; use constant P_LOOSE => 12; use constant P_ALLOW_BIGNUM => 13; use constant P_ALLOW_BAREKEY => 14; use constant P_ALLOW_SINGLEQUOTE => 15; use constant P_ESCAPE_SLASH => 16; use constant P_AS_NONBLESSED => 17; use constant P_ALLOW_UNKNOWN => 18; use constant OLD_PERL => $] < 5.008 ? 1 : 0; BEGIN { my @xs_compati_bit_properties = qw( latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown ); my @pp_bit_properties = qw( allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed ); # Perl version check, Unicode handling is enable? # Helper module sets @JSON::PP::_properties. if ($] < 5.008 ) { my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; eval qq| require $helper |; if ($@) { Carp::croak $@; } } for my $name (@xs_compati_bit_properties, @pp_bit_properties) { my $flag_name = 'P_' . uc($name); eval qq/ sub $name { my \$enable = defined \$_[1] ? \$_[1] : 1; if (\$enable) { \$_[0]->{PROPS}->[$flag_name] = 1; } else { \$_[0]->{PROPS}->[$flag_name] = 0; } \$_[0]; } sub get_$name { \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; } /; } } # Functions my %encode_allow_method = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash allow_blessed convert_blessed indent indent_length allow_bignum as_nonblessed /; my %decode_allow_method = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum allow_barekey max_size relaxed/; my $JSON; # cache sub encode_json ($) { # encode ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); } sub decode_json { # decode ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); } # Obsoleted sub to_json($) { Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); } sub from_json($) { Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); } # Methods sub new { my $class = shift; my $self = { max_depth => 512, max_size => 0, indent => 0, FLAGS => 0, fallback => sub { encode_error('Invalid value. JSON can only reference.') }, indent_length => 3, }; bless $self, $class; } sub encode { return $_[0]->PP_encode_json($_[1]); } sub decode { return $_[0]->PP_decode_json($_[1], 0x00000000); } sub decode_prefix { return $_[0]->PP_decode_json($_[1], 0x00000001); } # accessor # pretty printing sub pretty { my ($self, $v) = @_; my $enable = defined $v ? $v : 1; if ($enable) { # indent_length(3) for JSON::XS compatibility $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); } else { $self->indent(0)->space_before(0)->space_after(0); } $self; } # etc sub max_depth { my $max = defined $_[1] ? $_[1] : 0x80000000; $_[0]->{max_depth} = $max; $_[0]; } sub get_max_depth { $_[0]->{max_depth}; } sub max_size { my $max = defined $_[1] ? $_[1] : 0; $_[0]->{max_size} = $max; $_[0]; } sub get_max_size { $_[0]->{max_size}; } sub filter_json_object { $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; $_[0]; } sub filter_json_single_key_object { if (@_ > 1) { $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; } $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; $_[0]; } sub indent_length { if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { Carp::carp "The acceptable range of indent_length() is 0 to 15."; } else { $_[0]->{indent_length} = $_[1]; } $_[0]; } sub get_indent_length { $_[0]->{indent_length}; } sub sort_by { $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; $_[0]; } sub allow_bigint { Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); } ############################### ### ### Perl => JSON ### { # Convert my $max_depth; my $indent; my $ascii; my $latin1; my $utf8; my $space_before; my $space_after; my $canonical; my $allow_blessed; my $convert_blessed; my $indent_length; my $escape_slash; my $bignum; my $as_nonblessed; my $depth; my $indent_count; my $keysort; sub PP_encode_json { my $self = shift; my $obj = shift; $indent_count = 0; $depth = 0; my $idx = $self->{PROPS}; ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, $convert_blessed, $escape_slash, $bignum, $as_nonblessed) = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; $keysort = $canonical ? sub { $a cmp $b } : undef; if ($self->{sort_by}) { $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} : sub { $a cmp $b }; } encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); my $str = $self->object_to_json($obj); $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible unless ($ascii or $latin1 or $utf8) { utf8::upgrade($str); } if ($idx->[ P_SHRINK ]) { utf8::downgrade($str, 1); } return $str; } sub object_to_json { my ($self, $obj) = @_; my $type = ref($obj); if($type eq 'HASH'){ return $self->hash_to_json($obj); } elsif($type eq 'ARRAY'){ return $self->array_to_json($obj); } elsif ($type) { # blessed object? if (blessed($obj)) { return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); if ( $convert_blessed and $obj->can('TO_JSON') ) { my $result = $obj->TO_JSON(); if ( defined $result and ref( $result ) ) { if ( refaddr( $obj ) eq refaddr( $result ) ) { encode_error( sprintf( "%s::TO_JSON method returned same object as was passed instead of a new one", ref $obj ) ); } } return $self->object_to_json( $result ); } return "$obj" if ( $bignum and _is_bignum($obj) ); return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. encode_error( sprintf("encountered object '%s', but neither allow_blessed " . "nor convert_blessed settings are enabled", $obj) ) unless ($allow_blessed); return 'null'; } else { return $self->value_to_json($obj); } } else{ return $self->value_to_json($obj); } } sub hash_to_json { my ($self, $obj) = @_; my @res; encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") if (++$depth > $max_depth); my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); for my $k ( _sort( $obj ) ) { if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized push @res, string_to_json( $self, $k ) . $del . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); } --$depth; $self->_down_indent() if ($indent); return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; } sub array_to_json { my ($self, $obj) = @_; my @res; encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") if (++$depth > $max_depth); my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); for my $v (@$obj){ push @res, $self->object_to_json($v) || $self->value_to_json($v); } --$depth; $self->_down_indent() if ($indent); return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; } sub value_to_json { my ($self, $value) = @_; return 'null' if(!defined $value); my $b_obj = B::svref_2object(\$value); # for round trip problem my $flags = $b_obj->FLAGS; return $value # as is if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? my $type = ref($value); if(!$type){ return string_to_json($self, $value); } elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ return $$value == 1 ? 'true' : 'false'; } elsif ($type) { if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { return $self->value_to_json("$value"); } if ($type eq 'SCALAR' and defined $$value) { return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' : encode_error("cannot encode reference to scalar"); } if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { return 'null'; } else { if ( $type eq 'SCALAR' or $type eq 'REF' ) { encode_error("cannot encode reference to scalar"); } else { encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); } } } else { return $self->{fallback}->($value) if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); return 'null'; } } my %esc = ( "\n" => '\n', "\r" => '\r', "\t" => '\t', "\f" => '\f', "\b" => '\b', "\"" => '\"', "\\" => '\\\\', "\'" => '\\\'', ); sub string_to_json { my ($self, $arg) = @_; $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; $arg =~ s/\//\\\//g if ($escape_slash); $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; if ($ascii) { $arg = JSON_PP_encode_ascii($arg); } if ($latin1) { $arg = JSON_PP_encode_latin1($arg); } if ($utf8) { utf8::encode($arg); } return '"' . $arg . '"'; } sub blessed_to_json { my $reftype = reftype($_[1]) || ''; if ($reftype eq 'HASH') { return $_[0]->hash_to_json($_[1]); } elsif ($reftype eq 'ARRAY') { return $_[0]->array_to_json($_[1]); } else { return 'null'; } } sub encode_error { my $error = shift; Carp::croak "$error"; } sub _sort { defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; } sub _up_indent { my $self = shift; my $space = ' ' x $indent_length; my ($pre,$post) = ('',''); $post = "\n" . $space x $indent_count; $indent_count++; $pre = "\n" . $space x $indent_count; return ($pre,$post); } sub _down_indent { $indent_count--; } sub PP_encode_box { { depth => $depth, indent_count => $indent_count, }; } } # Convert sub _encode_ascii { join('', map { $_ <= 127 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); } unpack('U*', $_[0]) ); } sub _encode_latin1 { join('', map { $_ <= 255 ? chr($_) : $_ <= 65535 ? sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); } unpack('U*', $_[0]) ); } sub _encode_surrogates { # from perlunicode my $uni = $_[0] - 0x10000; return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); } sub _is_bignum { $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); } # # JSON => Perl # my $max_intsize; BEGIN { my $checkint = 1111; for my $d (5..64) { $checkint .= 1; my $int = eval qq| $checkint |; if ($int =~ /[eE]/) { $max_intsize = $d - 1; last; } } } { # PARSE my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> b => "\x8", t => "\x9", n => "\xA", f => "\xC", r => "\xD", '\\' => '\\', '"' => '"', '/' => '/', ); my $text; # json data my $at; # offset my $ch; # 1chracter my $len; # text length (changed according to UTF8 or NON UTF8) # INTERNAL my $depth; # nest counter my $encoding; # json text encoding my $is_valid_utf8; # temp variable my $utf8_len; # utf8 byte length # FLAGS my $utf8; # must be utf8 my $max_depth; # max nest nubmer of objects and arrays my $max_size; my $relaxed; my $cb_object; my $cb_sk_object; my $F_HOOK; my $allow_bigint; # using Math::BigInt my $singlequote; # loosely quoting my $loose; # my $allow_barekey; # bareKey # $opt flag # 0x00000001 .... decode_prefix # 0x10000000 .... incr_parse sub PP_decode_json { my ($self, $opt); # $opt is an effective flag during this decode_json. ($self, $text, $opt) = @_; ($at, $ch, $depth) = (0, '', 0); if ( !defined $text or ref $text ) { decode_error("malformed JSON string, neither array, object, number, string or atom"); } my $idx = $self->{PROPS}; ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; if ( $utf8 ) { utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); } else { utf8::upgrade( $text ); } $len = length $text; ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; if ($max_size > 1) { use bytes; my $bytes = length $text; decode_error( sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" , $bytes, $max_size), 1 ) if ($bytes > $max_size); } # Currently no effect # should use regexp my @octets = unpack('C4', $text); $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' : (!$octets[0] and $octets[1]) ? 'UTF-16BE' : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' : ( $octets[2] ) ? 'UTF-16LE' : (!$octets[2] ) ? 'UTF-32LE' : 'unknown'; white(); # remove head white space my $valid_start = defined $ch; # Is there a first character for JSON structure? my $result = value(); return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { decode_error( 'JSON text must be an object or array (but found number, string, true, false or null,' . ' use allow_nonref to allow this)', 1); } Carp::croak('something wrong.') if $len < $at; # we won't arrive here. my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length white(); # remove tail white space if ( $ch ) { return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix decode_error("garbage after JSON object"); } ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; } sub next_chr { return $ch = undef if($at >= $len); $ch = substr($text, $at++, 1); } sub value { white(); return if(!defined $ch); return object() if($ch eq '{'); return array() if($ch eq '['); return string() if($ch eq '"' or ($singlequote and $ch eq "'")); return number() if($ch =~ /[0-9]/ or $ch eq '-'); return word(); } sub string { my ($i, $s, $t, $u); my $utf16; my $is_utf8; ($is_valid_utf8, $utf8_len) = ('', 0); $s = ''; # basically UTF8 flag on if($ch eq '"' or ($singlequote and $ch eq "'")){ my $boundChar = $ch; OUTER: while( defined(next_chr()) ){ if($ch eq $boundChar){ next_chr(); if ($utf16) { decode_error("missing low surrogate character in surrogate pair"); } utf8::decode($s) if($is_utf8); return $s; } elsif($ch eq '\\'){ next_chr(); if(exists $escapes{$ch}){ $s .= $escapes{$ch}; } elsif($ch eq 'u'){ # UNICODE handling my $u = ''; for(1..4){ $ch = next_chr(); last OUTER if($ch !~ /[0-9a-fA-F]/); $u .= $ch; } # U+D800 - U+DBFF if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? $utf16 = $u; } # U+DC00 - U+DFFF elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? unless (defined $utf16) { decode_error("missing high surrogate character in surrogate pair"); } $is_utf8 = 1; $s .= JSON_PP_decode_surrogates($utf16, $u) || next; $utf16 = undef; } else { if (defined $utf16) { decode_error("surrogate pair expected"); } if ( ( my $hex = hex( $u ) ) > 127 ) { $is_utf8 = 1; $s .= JSON_PP_decode_unicode($u) || next; } else { $s .= chr $hex; } } } else{ unless ($loose) { $at -= 2; decode_error('illegal backslash escape sequence in string'); } $s .= $ch; } } else{ if ( ord $ch > 127 ) { if ( $utf8 ) { unless( $ch = is_valid_utf8($ch) ) { $at -= 1; decode_error("malformed UTF-8 character in JSON string"); } else { $at += $utf8_len - 1; } } else { utf8::encode( $ch ); } $is_utf8 = 1; } if (!$loose) { if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok $at--; decode_error('invalid character encountered while parsing JSON string'); } } $s .= $ch; } } } decode_error("unexpected end of string while parsing JSON string"); } sub white { while( defined $ch ){ if($ch le ' '){ next_chr(); } elsif($ch eq '/'){ next_chr(); if(defined $ch and $ch eq '/'){ 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); } elsif(defined $ch and $ch eq '*'){ next_chr(); while(1){ if(defined $ch){ if($ch eq '*'){ if(defined(next_chr()) and $ch eq '/'){ next_chr(); last; } } else{ next_chr(); } } else{ decode_error("Unterminated comment"); } } next; } else{ $at--; decode_error("malformed JSON string, neither array, object, number, string or atom"); } } else{ if ($relaxed and $ch eq '#') { # correctly? pos($text) = $at; $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; $at = pos($text); next_chr; next; } last; } } } sub array { my $a = $_[0] || []; # you can use this code to use another array ref object. decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') if (++$depth > $max_depth); next_chr(); white(); if(defined $ch and $ch eq ']'){ --$depth; next_chr(); return $a; } else { while(defined($ch)){ push @$a, value(); white(); if (!defined $ch) { last; } if($ch eq ']'){ --$depth; next_chr(); return $a; } if($ch ne ','){ last; } next_chr(); white(); if ($relaxed and $ch eq ']') { --$depth; next_chr(); return $a; } } } decode_error(", or ] expected while parsing array"); } sub object { my $o = $_[0] || {}; # you can use this code to use another hash ref object. my $k; decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') if (++$depth > $max_depth); next_chr(); white(); if(defined $ch and $ch eq '}'){ --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } else { while (defined $ch) { $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); white(); if(!defined $ch or $ch ne ':'){ $at--; decode_error("':' expected"); } next_chr(); $o->{$k} = value(); white(); last if (!defined $ch); if($ch eq '}'){ --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } if($ch ne ','){ last; } next_chr(); white(); if ($relaxed and $ch eq '}') { --$depth; next_chr(); if ($F_HOOK) { return _json_object_hook($o); } return $o; } } } $at--; decode_error(", or } expected while parsing object/hash"); } sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition my $key; while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ $key .= $ch; next_chr(); } return $key; } sub word { my $word = substr($text,$at-1,4); if($word eq 'true'){ $at += 3; next_chr; return $JSON::PP::true; } elsif($word eq 'null'){ $at += 3; next_chr; return undef; } elsif($word eq 'fals'){ $at += 3; if(substr($text,$at,1) eq 'e'){ $at++; next_chr; return $JSON::PP::false; } } $at--; # for decode_error report decode_error("'null' expected") if ($word =~ /^n/); decode_error("'true' expected") if ($word =~ /^t/); decode_error("'false' expected") if ($word =~ /^f/); decode_error("malformed JSON string, neither array, object, number, string or atom"); } sub number { my $n = ''; my $v; # According to RFC4627, hex or oct digts are invalid. if($ch eq '0'){ my $peek = substr($text,$at,1); my $hex = $peek =~ /[xX]/; # 0 or 1 if($hex){ decode_error("malformed number (leading zero must not be followed by another digit)"); ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); } else{ # oct ($n) = ( substr($text, $at) =~ /^([0-7]+)/); if (defined $n and length $n > 1) { decode_error("malformed number (leading zero must not be followed by another digit)"); } } if(defined $n and length($n)){ if (!$hex and length($n) == 1) { decode_error("malformed number (leading zero must not be followed by another digit)"); } $at += length($n) + $hex; next_chr; return $hex ? hex($n) : oct($n); } } if($ch eq '-'){ $n = '-'; next_chr; if (!defined $ch or $ch !~ /\d/) { decode_error("malformed number (no digits after initial minus)"); } } while(defined $ch and $ch =~ /\d/){ $n .= $ch; next_chr; } if(defined $ch and $ch eq '.'){ $n .= '.'; next_chr; if (!defined $ch or $ch !~ /\d/) { decode_error("malformed number (no digits after decimal point)"); } else { $n .= $ch; } while(defined(next_chr) and $ch =~ /\d/){ $n .= $ch; } } if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ $n .= $ch; next_chr; if(defined($ch) and ($ch eq '+' or $ch eq '-')){ $n .= $ch; next_chr; if (!defined $ch or $ch =~ /\D/) { decode_error("malformed number (no digits after exp sign)"); } $n .= $ch; } elsif(defined($ch) and $ch =~ /\d/){ $n .= $ch; } else { decode_error("malformed number (no digits after exp sign)"); } while(defined(next_chr) and $ch =~ /\d/){ $n .= $ch; } } $v .= $n; if ($v !~ /[.eE]/ and length $v > $max_intsize) { if ($allow_bigint) { # from Adam Sussman require Math::BigInt; return Math::BigInt->new($v); } else { return "$v"; } } elsif ($allow_bigint) { require Math::BigFloat; return Math::BigFloat->new($v); } return 0+$v; } sub is_valid_utf8 { $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 : $_[0] =~ /[\xC2-\xDF]/ ? 2 : $_[0] =~ /[\xE0-\xEF]/ ? 3 : $_[0] =~ /[\xF0-\xF4]/ ? 4 : 0 ; return unless $utf8_len; my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); return ( $is_valid_utf8 =~ /^(?: [\x00-\x7F] |[\xC2-\xDF][\x80-\xBF] |[\xE0][\xA0-\xBF][\x80-\xBF] |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] |[\xED][\x80-\x9F][\x80-\xBF] |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] )$/x ) ? $is_valid_utf8 : ''; } sub decode_error { my $error = shift; my $no_rep = shift; my $str = defined $text ? substr($text, $at) : ''; my $mess = ''; my $type = $] >= 5.008 ? 'U*' : $] < 5.006 ? 'C*' : utf8::is_utf8( $str ) ? 'U*' # 5.6 : 'C*' ; for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? $mess .= $c == 0x07 ? '\a' : $c == 0x09 ? '\t' : $c == 0x0a ? '\n' : $c == 0x0d ? '\r' : $c == 0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}', $c) : $c == 0x5c ? '\\\\' : $c < 0x80 ? chr($c) : sprintf('\x{%x}', $c) ; if ( length $mess >= 20 ) { $mess .= '...'; last; } } unless ( length $mess ) { $mess = '(end of string)'; } Carp::croak ( $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" ); } sub _json_object_hook { my $o = $_[0]; my @ks = keys %{$o}; if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); if (@val == 1) { return $val[0]; } } my @val = $cb_object->($o) if ($cb_object); if (@val == 0 or @val > 1) { return $o; } else { return $val[0]; } } sub PP_decode_box { { text => $text, at => $at, ch => $ch, len => $len, depth => $depth, encoding => $encoding, is_valid_utf8 => $is_valid_utf8, }; } } # PARSE sub _decode_surrogates { # from perlunicode my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); my $un = pack('U*', $uni); utf8::encode( $un ); return $un; } sub _decode_unicode { my $un = pack('U', hex shift); utf8::encode( $un ); return $un; } # # Setup for various Perl versions (the code from JSON::PP58) # BEGIN { unless ( defined &utf8::is_utf8 ) { require Encode; *utf8::is_utf8 = *Encode::is_utf8; } if ( $] >= 5.008 ) { *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; } if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. package JSON::PP; require subs; subs->import('join'); eval q| sub join { return '' if (@_ < 2); my $j = shift; my $str = shift; for (@_) { $str .= $j . $_; } return $str; } |; } sub JSON::PP::incr_parse { local $Carp::CarpLevel = 1; ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); } sub JSON::PP::incr_skip { ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; } sub JSON::PP::incr_reset { ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; } eval q{ sub JSON::PP::incr_text : lvalue { $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; if ( $_[0]->{_incr_parser}->{incr_parsing} ) { Carp::croak("incr_text can not be called when the incremental parser already started parsing"); } $_[0]->{_incr_parser}->{incr_text}; } } if ( $] >= 5.006 ); } # Setup for various Perl versions (the code from JSON::PP58) ############################### # Utilities # BEGIN { eval 'require Scalar::Util'; unless($@){ *JSON::PP::blessed = \&Scalar::Util::blessed; *JSON::PP::reftype = \&Scalar::Util::reftype; *JSON::PP::refaddr = \&Scalar::Util::refaddr; } else{ # This code is from Sclar::Util. # warn $@; eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; *JSON::PP::blessed = sub { local($@, $SIG{__DIE__}, $SIG{__WARN__}); ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; }; my %tmap = qw( B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP ); *JSON::PP::reftype = sub { my $r = shift; return undef unless length(ref($r)); my $t = ref(B::svref_2object($r)); return exists $tmap{$t} ? $tmap{$t} : length(ref($$r)) ? 'REF' : 'SCALAR'; }; *JSON::PP::refaddr = sub { return undef unless length(ref($_[0])); my $addr; if(defined(my $pkg = blessed($_[0]))) { $addr .= bless $_[0], 'Scalar::Util::Fake'; bless $_[0], $pkg; } else { $addr .= $_[0] } $addr =~ /0x(\w+)/; local $^W; #no warnings 'portable'; hex($1); } } } # shamely copied and modified from JSON::XS code. $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } sub true { $JSON::PP::true } sub false { $JSON::PP::false } sub null { undef; } ############################### package JSON::PP::Boolean; use overload ( "0+" => sub { ${$_[0]} }, "++" => sub { $_[0] = ${$_[0]} + 1 }, "--" => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1, ); ############################### package JSON::PP::IncrParser; use strict; use constant INCR_M_WS => 0; # initial whitespace skipping use constant INCR_M_STR => 1; # inside string use constant INCR_M_BS => 2; # inside backslash use constant INCR_M_JSON => 3; # outside anything, count nesting use constant INCR_M_C0 => 4; use constant INCR_M_C1 => 5; $JSON::PP::IncrParser::VERSION = '1.01'; my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; sub new { my ( $class ) = @_; bless { incr_nest => 0, incr_text => undef, incr_parsing => 0, incr_p => 0, }, $class; } sub incr_parse { my ( $self, $coder, $text ) = @_; $self->{incr_text} = '' unless ( defined $self->{incr_text} ); if ( defined $text ) { if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { utf8::upgrade( $self->{incr_text} ) ; utf8::decode( $self->{incr_text} ) ; } $self->{incr_text} .= $text; } my $max_size = $coder->get_max_size; if ( defined wantarray ) { $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; if ( wantarray ) { my @ret; $self->{incr_parsing} = 1; do { push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; } } until ( length $self->{incr_text} >= $self->{incr_p} ); $self->{incr_parsing} = 0; return @ret; } else { # in scalar context $self->{incr_parsing} = 1; my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. } } } sub _incr_parse { my ( $self, $coder, $text, $skip ) = @_; my $p = $self->{incr_p}; my $restore = $p; my @obj; my $len = length $text; if ( $self->{incr_mode} == INCR_M_WS ) { while ( $len > $p ) { my $s = substr( $text, $p, 1 ); $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); $self->{incr_mode} = INCR_M_JSON; last; } } while ( $len > $p ) { my $s = substr( $text, $p++, 1 ); if ( $s eq '"' ) { if (substr( $text, $p - 2, 1 ) eq '\\' ) { next; } if ( $self->{incr_mode} != INCR_M_STR ) { $self->{incr_mode} = INCR_M_STR; } else { $self->{incr_mode} = INCR_M_JSON; unless ( $self->{incr_nest} ) { last; } } } if ( $self->{incr_mode} == INCR_M_JSON ) { if ( $s eq '[' or $s eq '{' ) { if ( ++$self->{incr_nest} > $coder->get_max_depth ) { Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); } } elsif ( $s eq ']' or $s eq '}' ) { last if ( --$self->{incr_nest} <= 0 ); } elsif ( $s eq '#' ) { while ( $len > $p ) { last if substr( $text, $p++, 1 ) eq "\n"; } } } } $self->{incr_p} = $p; return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); local $Carp::CarpLevel = 2; $self->{incr_p} = $restore; $self->{incr_c} = $p; my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); $self->{incr_text} = substr( $self->{incr_text}, $p ); $self->{incr_p} = 0; return $obj || ''; } sub incr_text { if ( $_[0]->{incr_parsing} ) { Carp::croak("incr_text can not be called when the incremental parser already started parsing"); } $_[0]->{incr_text}; } sub incr_skip { my $self = shift; $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); $self->{incr_p} = 0; } sub incr_reset { my $self = shift; $self->{incr_text} = undef; $self->{incr_p} = 0; $self->{incr_mode} = 0; $self->{incr_nest} = 0; $self->{incr_parsing} = 0; } ############################### 1; __END__ =pod =head1 NAME JSON::PP - JSON::XS compatible pure-Perl module. =head1 SYNOPSIS use JSON::PP; # exported functions, they croak on error # and expect/generate UTF-8 $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; # OO-interface $coder = JSON::PP->new->ascii->pretty->allow_nonref; $json_text = $json->encode( $perl_scalar ); $perl_scalar = $json->decode( $json_text ); $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing # Note that JSON version 2.0 and above will automatically use # JSON::XS or JSON::PP, so you should be able to just: use JSON; =head1 VERSION 2.27202 L<JSON::XS> 2.27 (~2.30) compatible. =head1 NOTE JSON::PP had been inculded in JSON distribution (CPAN module). It was a perl core module in Perl 5.14. =head1 DESCRIPTION This module is L<JSON::XS> compatible pure Perl module. (Perl 5.8 or later is recommended) JSON::XS is the fastest and most proper JSON module on CPAN. It is written by Marc Lehmann in C, so must be compiled and installed in the used environment. JSON::PP is a pure-Perl module and has compatibility to JSON::XS. =head2 FEATURES =over =item * correct unicode handling This module knows how to handle Unicode (depending on Perl version). See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>. =item * round-trip integrity When you serialise a perl data structure using only data types supported by JSON and Perl, the deserialised data structure is identical on the Perl level. (e.g. the string "2.0" doesn't suddenly become "2" just because it looks like a number). There I<are> minor exceptions to this, read the MAPPING section below to learn about those. =item * strict checking of JSON correctness There is no guessing, no generating of illegal JSON texts by default, and only JSON is accepted as input by default (the latter is a security feature). But when some options are set, loose chcking features are available. =back =head1 FUNCTIONAL INTERFACE Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>. =head2 encode_json $json_text = encode_json $perl_scalar Converts the given Perl data structure to a UTF-8 encoded, binary string. This function call is functionally identical to: $json_text = JSON::PP->new->utf8->encode($perl_scalar) =head2 decode_json $perl_scalar = decode_json $json_text The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries to parse that as an UTF-8 encoded JSON text, returning the resulting reference. This function call is functionally identical to: $perl_scalar = JSON::PP->new->utf8->decode($json_text) =head2 JSON::PP::is_bool $is_boolean = JSON::PP::is_bool($scalar) Returns true if the passed scalar represents either JSON::PP::true or JSON::PP::false, two constants that act like C<1> and C<0> respectively and are also used to represent JSON C<true> and C<false> in Perl strings. =head2 JSON::PP::true Returns JSON true value which is blessed object. It C<isa> JSON::PP::Boolean object. =head2 JSON::PP::false Returns JSON false value which is blessed object. It C<isa> JSON::PP::Boolean object. =head2 JSON::PP::null Returns C<undef>. See L<MAPPING>, below, for more information on how JSON values are mapped to Perl. =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER This section supposes that your perl vresion is 5.8 or later. If you know a JSON text from an outer world - a network, a file content, and so on, is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object with C<utf8> enable. And the decoded result will contain UNICODE characters. # from network my $json = JSON::PP->new->utf8; my $json_text = CGI->new->param( 'json_data' ); my $perl_scalar = $json->decode( $json_text ); # from file content local $/; open( my $fh, '<', 'json.data' ); $json_text = <$fh>; $perl_scalar = decode_json( $json_text ); If an outer data is not encoded in UTF-8, firstly you should C<decode> it. use Encode; local $/; open( my $fh, '<', 'json.data' ); my $encoding = 'cp932'; my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE # or you can write the below code. # # open( my $fh, "<:encoding($encoding)", 'json.data' ); # $unicode_json_text = <$fh>; In this case, C<$unicode_json_text> is of course UNICODE string. So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable. Instead of them, you use C<JSON> module object with C<utf8> disable. $perl_scalar = $json->utf8(0)->decode( $unicode_json_text ); Or C<encode 'utf8'> and C<decode_json>: $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) ); # this way is not efficient. And now, you want to convert your C<$perl_scalar> into JSON data and send it to an outer world - a network or a file content, and so on. Your data usually contains UNICODE strings and you want the converted data to be encoded in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable. print encode_json( $perl_scalar ); # to a network? file? or display? # or print $json->utf8->encode( $perl_scalar ); If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings for some reason, then its characters are regarded as B<latin1> for perl (because it does not concern with your $encoding). You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable. Instead of them, you use C<JSON> module object with C<utf8> disable. Note that the resulted text is a UNICODE string but no problem to print it. # $perl_scalar contains $encoding encoded string values $unicode_json_text = $json->utf8(0)->encode( $perl_scalar ); # $unicode_json_text consists of characters less than 0x100 print $unicode_json_text; Or C<decode $encoding> all string values and C<encode_json>: $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } ); # ... do it to each string values, then encode_json $json_text = encode_json( $perl_scalar ); This method is a proper way but probably not efficient. See to L<Encode>, L<perluniintro>. =head1 METHODS Basically, check to L<JSON> or L<JSON::XS>. =head2 new $json = JSON::PP->new Rturns a new JSON::PP object that can be used to de/encode JSON strings. All boolean flags described below are by default I<disabled>. The mutators for flags all return the JSON object again and thus calls can be chained: my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) => {"a": [1, 2]} =head2 ascii $json = $json->ascii([$enable]) $enabled = $json->get_ascii If $enable is true (or missing), then the encode method will not generate characters outside the code range 0..127. Any Unicode characters outside that range will be escaped using either a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. (See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>). In Perl 5.005, there is no character having high value (more than 255). See to L<UNICODE HANDLING ON PERLS>. If $enable is false, then the encode method will not escape Unicode characters unless required by the JSON syntax or other flags. This results in a faster and more compact format. JSON::PP->new->ascii(1)->encode([chr 0x10401]) => ["\ud801\udc01"] =head2 latin1 $json = $json->latin1([$enable]) $enabled = $json->get_latin1 If $enable is true (or missing), then the encode method will encode the resulting JSON text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. If $enable is false, then the encode method will not escape Unicode characters unless required by the JSON syntax or other flags. JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) See to L<UNICODE HANDLING ON PERLS>. =head2 utf8 $json = $json->utf8([$enable]) $enabled = $json->get_utf8 If $enable is true (or missing), then the encode method will encode the JSON result into UTF-8, as required by many protocols, while the decode method expects to be handled an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any characters outside the range 0..255, they are thus useful for bytewise/binary I/O. (In Perl 5.005, any character outside the range 0..255 does not exist. See to L<UNICODE HANDLING ON PERLS>.) In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 encoding families, as described in RFC4627. If $enable is false, then the encode method will return the JSON string as a (non-encoded) Unicode string, while decode expects thus a Unicode string. Any decoding or encoding (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. Example, output UTF-16BE-encoded JSON: use Encode; $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); Example, decode UTF-32LE-encoded JSON: use Encode; $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); =head2 pretty $json = $json->pretty([$enable]) This enables (or disables) all of the C<indent>, C<space_before> and C<space_after> flags in one call to generate the most readable (or most compact) form possible. Equivalent to: $json->indent->space_before->space_after =head2 indent $json = $json->indent([$enable]) $enabled = $json->get_indent The default indent space length is three. You can use C<indent_length> to change the length. =head2 space_before $json = $json->space_before([$enable]) $enabled = $json->get_space_before If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space before the C<:> separating keys from values in JSON objects. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. Example, space_before enabled, space_after and indent disabled: {"key" :"value"} =head2 space_after $json = $json->space_after([$enable]) $enabled = $json->get_space_after If C<$enable> is true (or missing), then the C<encode> method will add an extra optional space after the C<:> separating keys from values in JSON objects and extra whitespace after the C<,> separating key-value pairs and array members. If C<$enable> is false, then the C<encode> method will not add any extra space at those places. This setting has no effect when decoding JSON texts. Example, space_before and indent disabled, space_after enabled: {"key": "value"} =head2 relaxed $json = $json->relaxed([$enable]) $enabled = $json->get_relaxed If C<$enable> is true (or missing), then C<decode> will accept some extensions to normal JSON syntax (see below). C<encode> will not be affected in anyway. I<Be aware that this option makes you accept invalid JSON texts as if they were valid!>. I suggest only to use this option to parse application-specific files written by humans (configuration files, resource files etc.) If C<$enable> is false (the default), then C<decode> will only accept valid JSON texts. Currently accepted extensions are: =over 4 =item * list items can have an end-comma JSON I<separates> array elements and key-value pairs with commas. This can be annoying if you write JSON texts manually and want to be able to quickly append elements, so this extension accepts comma at the end of such items not just between them: [ 1, 2, <- this comma not normally allowed ] { "k1": "v1", "k2": "v2", <- this comma not normally allowed } =item * shell-style '#'-comments Whenever JSON allows whitespace, shell-style comments are additionally allowed. They are terminated by the first carriage-return or line-feed character, after which more white-space and comments are allowed. [ 1, # this comment not allowed in JSON # neither this one... ] =back =head2 canonical $json = $json->canonical([$enable]) $enabled = $json->get_canonical If C<$enable> is true (or missing), then the C<encode> method will output JSON objects by sorting their keys. This is adding a comparatively high overhead. If C<$enable> is false, then the C<encode> method will output key-value pairs in the order Perl stores them (which will likely change between runs of the same script). This option is useful if you want the same data structure to be encoded as the same JSON text (given the same overall settings). If it is disabled, the same hash might be encoded differently even if contains the same data, as key-value pairs have no inherent ordering in Perl. This setting has no effect when decoding JSON texts. If you want your own sorting routine, you can give a code referece or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>. =head2 allow_nonref $json = $json->allow_nonref([$enable]) $enabled = $json->get_allow_nonref If C<$enable> is true (or missing), then the C<encode> method can convert a non-reference into its corresponding string, number or null JSON value, which is an extension to RFC4627. Likewise, C<decode> will accept those JSON values instead of croaking. If C<$enable> is false, then the C<encode> method will croak if it isn't passed an arrayref or hashref, as JSON texts must either be an object or array. Likewise, C<decode> will croak if given something that is not a JSON object or array. JSON::PP->new->allow_nonref->encode ("Hello, World!") => "Hello, World!" =head2 allow_unknown $json = $json->allow_unknown ([$enable]) $enabled = $json->get_allow_unknown If $enable is true (or missing), then "encode" will *not* throw an exception when it encounters values it cannot represent in JSON (for example, filehandles) but instead will encode a JSON "null" value. Note that blessed objects are not included here and are handled separately by c<allow_nonref>. If $enable is false (the default), then "encode" will throw an exception when it encounters anything it cannot encode as JSON. This option does not affect "decode" in any way, and it is recommended to leave it off unless you know your communications partner. =head2 allow_blessed $json = $json->allow_blessed([$enable]) $enabled = $json->get_allow_blessed If C<$enable> is true (or missing), then the C<encode> method will not barf when it encounters a blessed reference. Instead, the value of the B<convert_blessed> option will decide whether C<null> (C<convert_blessed> disabled or no C<TO_JSON> method found) or a representation of the object (C<convert_blessed> enabled and C<TO_JSON> method found) is being encoded. Has no effect on C<decode>. If C<$enable> is false (the default), then C<encode> will throw an exception when it encounters a blessed object. =head2 convert_blessed $json = $json->convert_blessed([$enable]) $enabled = $json->get_convert_blessed If C<$enable> is true (or missing), then C<encode>, upon encountering a blessed object, will check for the availability of the C<TO_JSON> method on the object's class. If found, it will be called in scalar context and the resulting scalar will be encoded instead of the object. If no C<TO_JSON> method is found, the value of C<allow_blessed> will decide what to do. The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON> returns other blessed objects, those will be handled in the same way. C<TO_JSON> must take care of not causing an endless recursion cycle (== crash) in this case. The name of C<TO_JSON> was chosen because other methods called by the Perl core (== not by the user of the object) are usually in upper case letters and to avoid collisions with the C<to_json> function or method. This setting does not yet influence C<decode> in any way. If C<$enable> is false, then the C<allow_blessed> setting will decide what to do when a blessed object is found. =head2 filter_json_object $json = $json->filter_json_object([$coderef]) When C<$coderef> is specified, it will be called from C<decode> each time it decodes a JSON object. The only argument passed to the coderef is a reference to the newly-created hash. If the code references returns a single scalar (which need not be a reference), this value (i.e. a copy of that scalar to avoid aliasing) is inserted into the deserialised data structure. If it returns an empty list (NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised hash will be inserted. This setting can slow down decoding considerably. When C<$coderef> is omitted or undefined, any existing callback will be removed and C<decode> will not change the deserialised hash in any way. Example, convert all JSON objects into the integer 5: my $js = JSON::PP->new->filter_json_object (sub { 5 }); # returns [5] $js->decode ('[{}]'); # the given subroutine takes a hash reference. # throw an exception because allow_nonref is not enabled # so a lone 5 is not allowed. $js->decode ('{"a":1, "b":2}'); =head2 filter_json_single_key_object $json = $json->filter_json_single_key_object($key [=> $coderef]) Works remotely similar to C<filter_json_object>, but is only called for JSON objects having a single key named C<$key>. This C<$coderef> is called before the one specified via C<filter_json_object>, if any. It gets passed the single value in the JSON object. If it returns a single value, it will be inserted into the data structure. If it returns nothing (not even C<undef> but the empty list), the callback from C<filter_json_object> will be called next, as if no single-key callback were specified. If C<$coderef> is omitted or undefined, the corresponding callback will be disabled. There can only ever be one callback for a given key. As this callback gets called less often then the C<filter_json_object> one, decoding speed will not usually suffer as much. Therefore, single-key objects make excellent targets to serialise Perl objects into, especially as single-key JSON objects are as close to the type-tagged value concept as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not support this in any way, so you need to make sure your data never looks like a serialised Perl hash. Typical names for the single object key are C<__class_whatever__>, or C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even things like C<__class_md5sum(classname)__>, to reduce the risk of clashing with real hashes. Example, decode JSON objects of the form C<< { "__widget__" => <id> } >> into the corresponding C<< $WIDGET{<id>} >> object: # return whatever is in $WIDGET{5}: JSON::PP ->new ->filter_json_single_key_object (__widget__ => sub { $WIDGET{ $_[0] } }) ->decode ('{"__widget__": 5') # this can be used with a TO_JSON method in some "widget" class # for serialisation to json: sub WidgetBase::TO_JSON { my ($self) = @_; unless ($self->{id}) { $self->{id} = ..get..some..id..; $WIDGET{$self->{id}} = $self; } { __widget__ => $self->{id} } } =head2 shrink $json = $json->shrink([$enable]) $enabled = $json->get_shrink In JSON::XS, this flag resizes strings generated by either C<encode> or C<decode> to their minimum size possible. It will also try to downgrade any strings to octet-form if possible. In JSON::PP, it is noop about resizing strings but tries C<utf8::downgrade> to the returned string by C<encode>. See to L<utf8>. See to L<JSON::XS/OBJECT-ORIENTED INTERFACE> =head2 max_depth $json = $json->max_depth([$maximum_nesting_depth]) $max_depth = $json->get_max_depth Sets the maximum nesting level (default C<512>) accepted while encoding or decoding. If a higher nesting level is detected in JSON text or a Perl data structure, then the encoder and decoder will stop and croak at that point. Nesting level is defined by number of hash- or arrayrefs that the encoder needs to traverse to reach a given point or the number of C<{> or C<[> characters without their matching closing parenthesis crossed to reach a given character in a string. If no argument is given, the highest possible setting will be used, which is rarely useful. See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful. When a large value (100 or more) was set and it de/encodes a deep nested object/text, it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase. =head2 max_size $json = $json->max_size([$maximum_string_size]) $max_size = $json->get_max_size Set the maximum length a JSON text may have (in bytes) where decoding is being attempted. The default is C<0>, meaning no limit. When C<decode> is called on a string that is longer then this many bytes, it will not attempt to decode the string but throw an exception. This setting has no effect on C<encode> (yet). If no argument is given, the limit check will be deactivated (same as when C<0> is specified). See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful. =head2 encode $json_text = $json->encode($perl_scalar) Converts the given Perl data structure (a simple scalar or a reference to a hash or array) to its JSON representation. Simple scalars will be converted into JSON string or number sequences, while references to arrays become JSON arrays and references to hashes become JSON objects. Undefined Perl values (e.g. C<undef>) become JSON C<null> values. References to the integers C<0> and C<1> are converted into C<true> and C<false>. =head2 decode $perl_scalar = $json->decode($json_text) The opposite of C<encode>: expects a JSON text and tries to parse it, returning the resulting simple scalar or reference. Croaks on error. JSON numbers and strings become simple Perl scalars. JSON arrays become Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and C<null> becomes C<undef>. =head2 decode_prefix ($perl_scalar, $characters) = $json->decode_prefix($json_text) This works like the C<decode> method, but instead of raising an exception when there is trailing garbage after the first JSON object, it will silently stop parsing there and return the number of characters consumed so far. JSON->new->decode_prefix ("[1] the tail") => ([], 3) =head1 INCREMENTAL PARSING Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>. In some cases, there is the need for incremental parsing of JSON texts. This module does allow you to parse a JSON stream incrementally. It does so by accumulating text until it has a full JSON object, which it then can decode. This process is similar to using C<decode_prefix> to see if a full JSON object is available, but is much more efficient (and can be implemented with a minimum of method calls). This module will only attempt to parse the JSON text once it is sure it has enough text to get a decisive result, using a very simple but truly incremental parser. This means that it sometimes won't stop as early as the full parser, for example, it doesn't detect parenthese mismatches. The only thing it guarantees is that it starts decoding as soon as a syntactically valid JSON text has been seen. This means you need to set resource limits (e.g. C<max_size>) to ensure the parser will stop parsing in the presence if syntax errors. The following methods implement this incremental parser. =head2 incr_parse $json->incr_parse( [$string] ) # void context $obj_or_undef = $json->incr_parse( [$string] ) # scalar context @obj_or_empty = $json->incr_parse( [$string] ) # list context This is the central parsing function. It can both append new text and extract objects from the stream accumulated so far (both of these functions are optional). If C<$string> is given, then this string is appended to the already existing JSON fragment stored in the C<$json> object. After that, if the function is called in void context, it will simply return without doing anything further. This can be used to add more text in as many chunks as you want. If the method is called in scalar context, then it will try to extract exactly I<one> JSON object. If that is successful, it will return this object, otherwise it will return C<undef>. If there is a parse error, this method will croak just as C<decode> would do (one can then use C<incr_skip> to skip the errornous part). This is the most common way of using the method. And finally, in list context, it will try to extract as many objects from the stream as it can find and return them, or the empty list otherwise. For this to work, there must be no separators between the JSON objects or arrays, instead they must be concatenated back-to-back. If an error occurs, an exception will be raised as in the scalar context case. Note that in this case, any previously-parsed JSON texts will be lost. Example: Parse some JSON arrays/objects in a given string and return them. my @objs = JSON->new->incr_parse ("[5][7][1,2]"); =head2 incr_text $lvalue_string = $json->incr_text This method returns the currently stored JSON fragment as an lvalue, that is, you can manipulate it. This I<only> works when a preceding call to C<incr_parse> in I<scalar context> successfully returned an object. Under all other circumstances you must not call this function (I mean it. although in simple tests it might actually work, it I<will> fail under real world conditions). As a special exception, you can also call this method before having parsed anything. This function is useful in two cases: a) finding the trailing text after a JSON object or b) parsing multiple JSON objects separated by non-JSON text (such as commas). $json->incr_text =~ s/\s*,\s*//; In Perl 5.005, C<lvalue> attribute is not available. You must write codes like the below: $string = $json->incr_text; $string =~ s/\s*,\s*//; $json->incr_text( $string ); =head2 incr_skip $json->incr_skip This will reset the state of the incremental parser and will remove the parsed text from the input buffer. This is useful after C<incr_parse> died, in which case the input buffer and incremental parser state is left unchanged, to skip the text parsed so far and to reset the parse state. =head2 incr_reset $json->incr_reset This completely resets the incremental parser, that is, after this call, it will be as if the parser had never parsed anything. This is useful if you want ot repeatedly parse JSON objects and want to ignore any trailing data, which means you have to reset the parser after each successful decode. See to L<JSON::XS/INCREMENTAL PARSING> for examples. =head1 JSON::PP OWN METHODS =head2 allow_singlequote $json = $json->allow_singlequote([$enable]) If C<$enable> is true (or missing), then C<decode> will accept JSON strings quoted by single quotations that are invalid JSON format. $json->allow_singlequote->decode({"foo":'bar'}); $json->allow_singlequote->decode({'foo':"bar"}); $json->allow_singlequote->decode({'foo':'bar'}); As same as the C<relaxed> option, this option may be used to parse application-specific files written by humans. =head2 allow_barekey $json = $json->allow_barekey([$enable]) If C<$enable> is true (or missing), then C<decode> will accept bare keys of JSON object that are invalid JSON format. As same as the C<relaxed> option, this option may be used to parse application-specific files written by humans. $json->allow_barekey->decode('{foo:"bar"}'); =head2 allow_bignum $json = $json->allow_bignum([$enable]) If C<$enable> is true (or missing), then C<decode> will convert the big integer Perl cannot handle as integer into a L<Math::BigInt> object and convert a floating number (any) into a L<Math::BigFloat>. On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat> objects into JSON numbers with C<allow_blessed> enable. $json->allow_nonref->allow_blessed->allow_bignum; $bigfloat = $json->decode('2.000000000000000000000000001'); print $json->encode($bigfloat); # => 2.000000000000000000000000001 See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number. =head2 loose $json = $json->loose([$enable]) The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings and the module doesn't allow to C<decode> to these (except for \x2f). If C<$enable> is true (or missing), then C<decode> will accept these unescaped strings. $json->loose->decode(qq|["abc def"]|); See L<JSON::XS/SSECURITY CONSIDERATIONS>. =head2 escape_slash $json = $json->escape_slash([$enable]) According to JSON Grammar, I<slash> (U+002F) is escaped. But default JSON::PP (as same as JSON::XS) encodes strings without escaping slash. If C<$enable> is true (or missing), then C<encode> will escape slashes. =head2 indent_length $json = $json->indent_length($length) JSON::XS indent space length is 3 and cannot be changed. JSON::PP set the indent space length with the given $length. The default is 3. The acceptable range is 0 to 15. =head2 sort_by $json = $json->sort_by($function_name) $json = $json->sort_by($subroutine_ref) If $function_name or $subroutine_ref are set, its sort routine are used in encoding JSON objects. $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); $js = $pc->sort_by('own_sort')->encode($obj); # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } As the sorting routine runs in the JSON::PP scope, the given subroutine name and the special variables C<$a>, C<$b> will begin 'JSON::PP::'. If $integer is set, then the effect is same as C<canonical> on. =head1 INTERNAL For developers. =over =item PP_encode_box Returns { depth => $depth, indent_count => $indent_count, } =item PP_decode_box Returns { text => $text, at => $at, ch => $ch, len => $len, depth => $depth, encoding => $encoding, is_valid_utf8 => $is_valid_utf8, }; =back =head1 MAPPING This section is copied from JSON::XS and modified to C<JSON::PP>. JSON::XS and JSON::PP mapping mechanisms are almost equivalent. See to L<JSON::XS/MAPPING>. =head2 JSON -> PERL =over 4 =item object A JSON object becomes a reference to a hash in Perl. No ordering of object keys is preserved (JSON does not preserver object key ordering itself). =item array A JSON array becomes a reference to an array in Perl. =item string A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON are represented by the same codepoints in the Perl string, so no manual decoding is necessary. =item number A JSON number becomes either an integer, numeric (floating point) or string scalar in perl, depending on its range and any fractional parts. On the Perl level, there is no difference between those as Perl handles all the conversion details, but an integer may take slightly less memory and might represent more values exactly than floating point numbers. If the number consists of digits only, C<JSON> will try to represent it as an integer value. If that fails, it will try to represent it as a numeric (floating point) value if that is possible without loss of precision. Otherwise it will preserve the number as a string value (in which case you lose roundtripping ability, as the JSON number will be re-encoded toa JSON string). Numbers containing a fractional or exponential part will always be represented as numeric (floating point) values, possibly at a loss of precision (in which case you might lose perfect roundtripping ability, but the JSON number will still be re-encoded as a JSON number). Note that precision is not accuracy - binary floating point values cannot represent most decimal fractions exactly, and when converting from and to floating point, C<JSON> only guarantees precision up to but not including the leats significant bit. When C<allow_bignum> is enable, the big integers and the numeric can be optionally converted into L<Math::BigInt> and L<Math::BigFloat> objects. =item true, false These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>, respectively. They are overloaded to act almost exactly like the numbers C<1> and C<0>. You can check wether a scalar is a JSON boolean by using the C<JSON::is_bool> function. print JSON::PP::true . "\n"; => true print JSON::PP::true + 1; => 1 ok(JSON::true eq '1'); ok(JSON::true == 1); C<JSON> will install these missing overloading features to the backend modules. =item null A JSON null atom becomes C<undef> in Perl. C<JSON::PP::null> returns C<unddef>. =back =head2 PERL -> JSON The mapping from Perl to JSON is slightly more difficult, as Perl is a truly typeless language, so we can only guess which JSON type is meant by a Perl value. =over 4 =item hash references Perl hash references become JSON objects. As there is no inherent ordering in hash keys (or JSON objects), they will usually be encoded in a pseudo-random order that can change between runs of the same program but stays generally the same within a single run of a program. C<JSON> optionally sort the hash keys (determined by the I<canonical> flag), so the same datastructure will serialise to the same JSON text (given same settings and version of JSON::XS), but this incurs a runtime overhead and is only rarely useful, e.g. when you want to compare some JSON text against another for equality. =item array references Perl array references become JSON arrays. =item other references Other unblessed references are generally not allowed and will cause an exception to be thrown, except for references to the integers C<0> and C<1>, which get turned into C<false> and C<true> atoms in JSON. You can also use C<JSON::false> and C<JSON::true> to improve readability. to_json [\0,JSON::PP::true] # yields [false,true] =item JSON::PP::true, JSON::PP::false, JSON::PP::null These special values become JSON true and JSON false values, respectively. You can also use C<\1> and C<\0> directly if you want. JSON::PP::null returns C<undef>. =item blessed objects Blessed objects are not directly representable in JSON. See the C<allow_blessed> and C<convert_blessed> methods on various options on how to deal with this: basically, you can choose between throwing an exception, encoding the reference as if it weren't blessed, or provide your own serialiser method. See to L<convert_blessed>. =item simple scalars Simple Perl scalars (any scalar that is not a reference) are the most difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as JSON C<null> values, scalars that have last been used in a string context before encoding as JSON strings, and anything else as number value: # dump as number encode_json [2] # yields [2] encode_json [-3.0e17] # yields [-3e+17] my $value = 5; encode_json [$value] # yields [5] # used as string, so dump as string print $value; encode_json [$value] # yields ["5"] # undef becomes null encode_json [undef] # yields [null] You can force the type to be a string by stringifying it: my $x = 3.1; # some variable containing a number "$x"; # stringified $x .= ""; # another, more awkward way to stringify print $x; # perl does it for you, too, quite often You can force the type to be a number by numifying it: my $x = "3"; # some variable containing a string $x += 0; # numify it, ensuring it will be dumped as a number $x *= 1; # same thing, the choise is yours. You can not currently force the type in other, less obscure, ways. Note that numerical precision has the same meaning as under Perl (so binary to decimal conversion follows the same rules as in Perl, which can differ to other languages). Also, your perl interpreter might expose extensions to the floating point numbers of your platform, such as infinities or NaN's - these cannot be represented in JSON, and it is an error to pass those in. =item Big Number When C<allow_bignum> is enable, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat> objects into JSON numbers. =back =head1 UNICODE HANDLING ON PERLS If you do not know about Unicode on Perl well, please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>. =head2 Perl 5.8 and later Perl can handle Unicode and the JSON::PP de/encode methods also work properly. $json->allow_nonref->encode(chr hex 3042); $json->allow_nonref->encode(chr hex 12345); Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively. $json->allow_nonref->decode('"\u3042"'); $json->allow_nonref->decode('"\ud808\udf45"'); Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>. Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken, so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions. =head2 Perl 5.6 Perl can handle Unicode and the JSON::PP de/encode methods also work. =head2 Perl 5.005 Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. That means the unicode handling is not available. In encoding, $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats as C<$value % 256>, so the above codes are equivalent to : $json->allow_nonref->encode(chr 66); $json->allow_nonref->encode(chr 69); In decoding, $json->decode('"\u00e3\u0081\u0082"'); The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded japanese character (C<HIRAGANA LETTER A>). And if it is represented in Unicode code point, C<U+3042>. Next, $json->decode('"\u3042"'); We ordinary expect the returned value is a Unicode character C<U+3042>. But here is 5.005 world. This is C<0xE3 0x81 0x82>. $json->decode('"\ud808\udf45"'); This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>. =head1 TODO =over =item speed =item memory saving =back =head1 SEE ALSO Most of the document are copied and modified from JSON::XS doc. L<JSON::XS> RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>) =head1 AUTHOR Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> =head1 COPYRIGHT AND LICENSE Copyright 2007-2013 by Makamaka Hannyaharamitu This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/alienfile.pm 0000444 00000037467 14711217614 0010104 0 ustar 00 package alienfile; use strict; use warnings; use 5.008004; use Alien::Build; use Exporter (); use Path::Tiny (); use Carp (); sub _path { Path::Tiny::path(@_) } # ABSTRACT: Specification for defining an external dependency for CPAN our $VERSION = '2.41'; # VERSION our @EXPORT = qw( requires on plugin probe configure share sys download fetch decode prefer extract patch patch_ffi build build_ffi gather gather_ffi meta_prop ffi log test start_url before after ); sub requires { my($module, $version) = @_; $version ||= 0; my $caller = caller; my $meta = $caller->meta; $meta->add_requires($meta->{phase}, $module, $version); (); } sub plugin { my($name, @args) = @_; my $caller = caller; $caller->meta->apply_plugin($name, @args); return; } sub probe { my($instr) = @_; my $caller = caller; if(my $phase = $caller->meta->{phase}) { Carp::croak "probe must not be in a $phase block" if $phase ne 'any'; } $caller->meta->register_hook(probe => $instr); return; } sub _phase { my($code, $phase) = @_; my $caller = caller(1); my $meta = $caller->meta; local $meta->{phase} = $phase; $code->(); return; } sub configure (&) { _phase($_[0], 'configure'); } sub sys (&) { _phase($_[0], 'system'); } sub share (&) { _phase($_[0], 'share'); } sub _in_phase { my($phase) = @_; my $caller = caller(1); my(undef, undef, undef, $sub) = caller(1); my $meta = $caller->meta; $sub =~ s/^.*:://; Carp::croak "$sub must be in a $phase block" unless $meta->{phase} eq $phase; } sub start_url { my($url) = @_; _in_phase 'share'; my $caller = caller; my $meta = $caller->meta; $meta->prop->{start_url} = $url; $meta->add_requires('configure' => 'Alien::Build' => '1.19'); return; } sub download { my($instr) = @_; _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(download => $instr); return; } sub fetch { my($instr) = @_; _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(fetch => $instr); return; } sub decode { my($instr) = @_; _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(decode => $instr); return; } sub prefer { my($instr) = @_; _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(prefer => $instr); return; } sub extract { my($instr) = @_; _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(extract => $instr); return; } sub patch { my($instr) = @_; _in_phase 'share'; my $caller = caller; my $suffix = $caller->meta->{build_suffix}; $caller->meta->register_hook("patch$suffix" => $instr); return; } sub patch_ffi { my($instr) = @_; Carp::carp("patch_ffi is deprecated, use ffi { patch ... } } instead"); _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(patch_ffi => $instr); return; } sub build { my($instr) = @_; _in_phase 'share'; my $caller = caller; my $suffix = $caller->meta->{build_suffix}; $caller->meta->register_hook("build$suffix" => $instr); return; } sub build_ffi { my($instr) = @_; Carp::carp("build_ffi is deprecated, use ffi { build ... } } instead"); _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(build_ffi => $instr); return; } sub gather { my($instr) = @_; my $caller = caller; my $meta = $caller->meta; my $phase = $meta->{phase}; Carp::croak "gather is not allowed in configure block" if $phase eq 'configure'; my $suffix = $caller->meta->{build_suffix}; if($suffix eq '_ffi') { $meta->register_hook(gather_ffi => $instr) } else { $meta->register_hook(gather_system => $instr) if $phase =~ /^(any|system)$/; $meta->register_hook(gather_share => $instr) if $phase =~ /^(any|share)$/; } return; } sub gather_ffi { my($instr) = @_; Carp::carp("gather_ffi is deprecated, use ffi { gather ... } } instead"); _in_phase 'share'; my $caller = caller; $caller->meta->register_hook(gather_ffi => $instr); return; } sub ffi (&) { my($code) = @_; _in_phase 'share'; my $caller = caller; local $caller->meta->{build_suffix} = '_ffi'; $code->(); return; } sub meta_prop { my $caller = caller; my $meta = $caller->meta; $meta->prop; } sub log { unshift @_, 'Alien::Build'; goto &Alien::Build::log; } sub test { my($instr) = @_; my $caller = caller; my $meta = $caller->meta; my $phase = $meta->{phase}; Carp::croak "test is not allowed in $phase block" if $phase eq 'any' || $phase eq 'configure'; $meta->add_requires('configure' => 'Alien::Build' => '1.14'); if($phase eq 'share') { my $suffix = $caller->meta->{build_suffix} || '_share'; $meta->register_hook( "test$suffix" => $instr, ); } elsif($phase eq 'system') { $meta->register_hook( "test_system" => $instr, ); } else { die "unknown phase: $phase"; } } my %modifiers = ( probe => { any => 'probe' }, download => { share => 'download' }, fetch => { share => 'fetch' }, decode => { share => 'fetch' }, prefer => { share => 'prefer' }, extract => { share => 'extract' }, patch => { share => 'patch$' }, build => { share => 'build$' }, test => { share => 'test$' }, # Note: below special case gather_ffi for the ffi block :P gather => { share => 'gather_share', system => 'gather_system', any => 'gather_share,gather_system' }, ); sub _add_modifier { my($type, $stage, $sub) = @_; my $method = "${type}_hook"; Carp::croak "No such stage $stage" unless defined $modifiers{$stage}; Carp::croak "$type $stage argument must be a code reference" unless defined $sub && ref($sub) eq 'CODE'; my $caller = caller; my $meta = $caller->meta; Carp::croak "$type $stage is not allowed in sys block" unless defined $modifiers{$stage}->{$meta->{phase}}; $meta->add_requires('configure' => 'Alien::Build' => '1.40'); my $suffix = $meta->{build_suffix}; if($suffix eq '_ffi' && $stage eq 'gather') { $meta->$method('gather_ffi' => $sub); } foreach my $hook ( map { split /,/, $_ } # split on , for when multiple hooks must be attachewd (gather in any) map { my $x = $_ ; $x =~ s/\$/$suffix/; $x } # substitute $ at the end for a suffix (_ffi) if any $modifiers{$stage}->{$meta->{phase}}) # get the list of modifiers { $meta->$method($hook => $sub); } return; } sub before { my($stage, $sub) = @_; @_ = ('before', @_); goto &alienfile::_add_modifier; } sub after { my($stage, $sub) = @_; @_ = ('after', @_); goto &alienfile::_add_modifier; } sub import { strict->import; warnings->import; goto &Exporter::import; } 1; __END__ =pod =encoding UTF-8 =head1 NAME alienfile - Specification for defining an external dependency for CPAN =head1 VERSION version 2.41 =head1 SYNOPSIS Do-it-yourself approach: use alienfile; probe [ 'pkg-config --exists libarchive' ]; share { start_url 'http://libarchive.org/downloads/libarchive-3.2.2.tar.gz'; # the first one which succeeds will be used download [ 'wget %{.meta.start_url}' ]; download [ 'curl -o %{.meta.start_url}' ]; extract [ 'tar xf %{.install.download}' ]; build [ # Note: will not work on Windows, better to use Build::Autoconf plugin # if you need windows support './configure --prefix=%{.install.prefix} --disable-shared', '%{make}', '%{make} install', ]; } gather [ [ 'pkg-config', '--modversion', 'libarchive', \'%{.runtime.version}' ], [ 'pkg-config', '--cflags', 'libarchive', \'%{.runtime.cflags}' ], [ 'pkg-config', '--libs', 'libarchive', \'%{.runtime.libs}' ], ]; With plugins (better): use alienfile; plugin 'PkgConfig' => 'libarchive'; share { start_url 'http://libarchive.org/downloads/'; plugin Download => ( filter => qr/^libarchive-.*\.tar\.gz$/, version => qr/([0-9\.]+)/, ); plugin Extract => 'tar.gz'; plugin 'Build::Autoconf'; plugin 'Gather::IsolateDynamic'; build [ '%{configure}', '%{make}', '%{make} install', ]; }; =head1 DESCRIPTION An alienfile is a recipe used by L<Alien::Build> to, probe for system libraries or download from the internet, and build source for those libraries. This document acts as reference for the alienfile system, but if you are starting out writing your own Alien you should read L<Alien::Build::Manual::AlienAuthor>, which will teach you how to write your own complete Alien using alienfile + L<Alien::Build> + L<ExtUtils::MakeMaker>. Special attention should be taken to the section "a note about dynamic vs. static libraries". =head1 DIRECTIVES =head2 requires "any" requirement (either share or system): requires $module; requires $module => $version; configure time requirement: configure { requires $module; requires $module => $version; }; system requirement: sys { requires $module; requires $module => $version; }; share requirement: share { requires $module; requires $module => $version; }; specifies a requirement. L<Alien::Build> takes advantage of dynamic requirements, so only modules that are needed for the specific type of install need to be loaded. Here are the different types of requirements: =over =item configure Configure requirements should already be installed before the alienfile is loaded. =item any "Any" requirements are those that are needed either for the probe stage, or in either the system or share installs. =item share Share requirements are those modules needed when downloading and building from source. =item system System requirements are those modules needed when the system provides the library or tool. =back =head2 plugin plugin $name => (%args); plugin $name => $arg; Load the given plugin. If you prefix the plugin name with an C<=> sign, then it will be assumed to be a fully qualified path name. Otherwise the plugin will be assumed to live in the C<Alien::Build::Plugin> namespace. If there is an appropriate negotiate plugin, that one will be loaded. Examples: # Loads Alien::Build::Plugin::Fetch::Negotiate # which will pick the best Alien::Build::Plugin::Fetch # plugin based on the URL, and system configuration plugin 'Fetch' => 'http://ftp.gnu.org/gnu/gcc'; # loads the plugin with the badly named class! plugin '=Badly::Named::Plugin::Not::In::Alien::Build::Namespace'; # explicitly loads Alien::Build::Plugin::Prefer::SortVersions plugin 'Prefer::SortVersions' => ( filter => qr/^gcc-.*\.tar\.gz$/, version => qr/([0-9\.]+)/, ); =head2 probe probe \&code; probe \@commandlist; Instructions for the probe stage. May be either a code reference, or a command list. =head2 configure configure { ... }; Configure block. The only directive allowed in a configure block is requires. =head2 sys sys { ... }; System block. Allowed directives are: requires and gather. =head2 share share { ... }; System block. Allowed directives are: download, fetch, decode, prefer, extract, build, gather. =head2 start_url share { start_url $url; }; Set the start URL for download. This should be the URL to an index page, or the actual tarball of the source. =head2 download share { download \&code; download \@commandlist; }; Instructions for the download stage. May be either a code reference, or a command list. =head2 fetch share { fetch \&code; fetch \@commandlist; }; Instructions for the fetch stage. May be either a code reference, or a command list. =head2 decode share { decode \&code; decode \@commandlist; }; Instructions for the decode stage. May be either a code reference, or a command list. =head2 prefer share { prefer \&code; prefer \@commandlist; }; Instructions for the prefer stage. May be either a code reference, or a command list. =head2 extract share { extract \&code; extract \@commandlist; }; Instructions for the extract stage. May be either a code reference, or a command list. =head2 patch share { patch \&code; patch \@commandlist; }; Instructions for the patch stage. May be either a code reference, or a command list. =head2 patch_ffi share { patch_ffi \&code; patch_ffi \@commandlist; }; [DEPRECATED] Instructions for the patch_ffi stage. May be either a code reference, or a command list. =head2 build share { build \&code; build \@commandlist; }; Instructions for the build stage. May be either a code reference, or a command list. =head2 build_ffi share { build \&code; build \@commandlist; }; [DEPRECATED] Instructions for the build FFI stage. Builds shared libraries instead of static. This is optional, and is only necessary if a fresh and separate build needs to be done for FFI. =head2 gather gather \&code; gather \@commandlist; share { gather \&code; gather \@commandlist; }; sys { gather \&code; gather \@commandlist; }; Instructions for the gather stage. May be either a code reference, or a command list. In the root block of the alienfile it will trigger in both share and system build. In the share or sys block it will only trigger in the corresponding build. =head2 gather_ffi share { gather_ffi \&code; gather_ffi \@commandlist; } [DEPRECATED] Gather specific to C<build_ffi>. Not usually necessary. =head2 ffi share { ffi { patch \&code; patch \@commandlist; build \&code; build \@commandlist; gather \&code; gather \@commandlist; } } Specify patch, build or gather stages related to FFI. =head2 meta_prop my $hash = meta_prop; Get the meta_prop hash reference. =head2 meta my $meta = meta; Returns the meta object for your L<alienfile>. =head2 log log($message); Prints the given log to stdout. =head2 test share { test \&code; test \@commandlist; }; sys { test \&code; test \@commandlist; }; Run the tests =head2 before before $stage => \&code; Execute the given code before the given stage. Stage should be one of C<probe>, C<download>, C<fetch>, C<decode>, C<prefer>, C<extract>, C<patch>, C<build>, C<test>, and C<gather>. The before directive is only legal in the same blocks as the stage would normally be legal in. For example, you can't do this: use alienfile; sys { before 'build' => sub { ... }; }; Because a C<build> wouldn't be legal inside a C<sys> block. =head2 after after $stage => \&code; Execute the given code after the given stage. Stage should be one of C<probe>, C<download>, C<fetch>, C<decode>, C<prefer>, C<extract>, C<patch>, C<build>, C<test>, and C<gather>. The after directive is only legal in the same blocks as the stage would normally be legal in. For example, you can't do this: use alienfile; sys { after 'build' => sub { ... }; }; Because a C<build> wouldn't be legal inside a C<sys> block. =head1 SEE ALSO =over 4 =item L<Alien> =item L<Alien::Build> =item L<Alien::Build::MM> =item L<Alien::Base> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Tester/Capture.pm 0000444 00000010510 14711217616 0011722 0 ustar 00 use strict; package Test::Tester::Capture; our $VERSION = '1.302186'; use Test::Builder; use vars qw( @ISA ); @ISA = qw( Test::Builder ); # Make Test::Tester::Capture thread-safe for ithreads. BEGIN { use Config; *share = sub { 0 }; *lock = sub { 0 }; } my $Curr_Test = 0; share($Curr_Test); my @Test_Results = (); share(@Test_Results); my $Prem_Diag = {diag => ""}; share($Curr_Test); sub new { # Test::Tester::Capgture::new used to just return __PACKAGE__ # because Test::Builder::new enforced its singleton nature by # return __PACKAGE__. That has since changed, Test::Builder::new now # returns a blessed has and around version 0.78, Test::Builder::todo # started wanting to modify $self. To cope with this, we now return # a blessed hash. This is a short-term hack, the correct thing to do # is to detect which style of Test::Builder we're dealing with and # act appropriately. my $class = shift; return bless {}, $class; } sub ok { my($self, $test, $name) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; lock $Curr_Test; $Curr_Test++; my($pack, $file, $line) = $self->caller; my $todo = $self->todo(); my $result = {}; share($result); unless( $test ) { @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); } else { @$result{ 'ok', 'actual_ok' } = ( 1, $test ); } if( defined $name ) { $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $result->{name} = $name; } else { $result->{name} = ''; } if( $todo ) { my $what_todo = $todo; $result->{reason} = $what_todo; $result->{type} = 'todo'; } else { $result->{reason} = ''; $result->{type} = ''; } $Test_Results[$Curr_Test-1] = $result; unless( $test ) { my $msg = $todo ? "Failed (TODO)" : "Failed"; $result->{fail_diag} = (" $msg test ($file at line $line)\n"); } $result->{diag} = ""; $result->{_level} = $Test::Builder::Level; $result->{_depth} = Test::Tester::find_run_tests(); $ctx->release; return $test ? 1 : 0; } sub skip { my($self, $why) = @_; $why ||= ''; my $ctx = $self->ctx; lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 1, name => '', type => 'skip', reason => $why, diag => "", _level => $Test::Builder::Level, _depth => Test::Tester::find_run_tests(), ); $Test_Results[$Curr_Test-1] = \%result; $ctx->release; return 1; } sub todo_skip { my($self, $why) = @_; $why ||= ''; my $ctx = $self->ctx; lock($Curr_Test); $Curr_Test++; my %result; share(%result); %result = ( 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, diag => "", _level => $Test::Builder::Level, _depth => Test::Tester::find_run_tests(), ); $Test_Results[$Curr_Test-1] = \%result; $ctx->release; return 1; } sub diag { my($self, @msgs) = @_; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; my $ctx = $self->ctx; # Escape each line with a #. foreach (@msgs) { $_ = 'undef' unless defined; } push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; $result->{diag} .= join("", @msgs); $ctx->release; return 0; } sub details { return @Test_Results; } # Stub. Feel free to send me a patch to implement this. sub note { } sub explain { return Test::Builder::explain(@_); } sub premature { return $Prem_Diag->{diag}; } sub current_test { if (@_ > 1) { die "Don't try to change the test number!"; } else { return $Curr_Test; } } sub reset { $Curr_Test = 0; @Test_Results = (); $Prem_Diag = {diag => ""}; } 1; __END__ =head1 NAME Test::Tester::Capture - Help testing test modules built with Test::Builder =head1 DESCRIPTION This is a subclass of Test::Builder that overrides many of the methods so that they don't output anything. It also keeps track of its own set of test results so that you can use Test::Builder based modules to perform tests on other Test::Builder based modules. =head1 AUTHOR Most of the code here was lifted straight from Test::Builder and then had chunks removed by Fergal Daly <fergal@esatclear.ie>. =head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html =cut perl5/Test/Tester/CaptureRunner.pm 0000444 00000002426 14711217617 0013124 0 ustar 00 # $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ use strict; package Test::Tester::CaptureRunner; our $VERSION = '1.302186'; use Test::Tester::Capture; require Exporter; sub new { my $pkg = shift; my $self = bless {}, $pkg; return $self; } sub run_tests { my $self = shift; my $test = shift; capture()->reset; $self->{StartLevel} = $Test::Builder::Level; &$test(); } sub get_results { my $self = shift; my @results = capture()->details; my $start = $self->{StartLevel}; foreach my $res (@results) { next if defined $res->{depth}; my $depth = $res->{_depth} - $res->{_level} - $start - 3; # print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; $res->{depth} = $depth; } return @results; } sub get_premature { return capture()->premature; } sub capture { return Test::Tester::Capture->new; } __END__ =head1 NAME Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder =head1 DESCRIPTION This stuff if needed to allow me to play with other ways of monitoring the test results. =head1 AUTHOR Copyright 2003 by Fergal Daly <fergal@esatclear.ie>. =head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html =cut perl5/Test/Tester/Delegate.pm 0000444 00000001073 14711217620 0012030 0 ustar 00 use strict; use warnings; package Test::Tester::Delegate; our $VERSION = '1.302186'; use Scalar::Util(); use vars '$AUTOLOAD'; sub new { my $pkg = shift; my $obj = shift; my $self = bless {}, $pkg; return $self; } sub AUTOLOAD { my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/; return if $sub eq "DESTROY"; my $obj = $_[0]->{Object}; my $ref = $obj->can($sub); shift(@_); unshift(@_, $obj); goto &$ref; } sub can { my $this = shift; my ($sub) = @_; return $this->{Object}->can($sub) if Scalar::Util::blessed($this); return $this->SUPER::can(@_); } 1; perl5/Test/Simple.pm 0000444 00000014534 14711217621 0010310 0 ustar 00 package Test::Simple; use 5.006; use strict; our $VERSION = '1.302186'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok); my $CLASS = __PACKAGE__; =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B<read L<Test::Tutorial> first!> ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the C<ok()> function (see below). The only other constraint is you must pre-declare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B<ok> ok( $foo eq $bar, $name ); ok( $foo eq $bar ); C<ok()> is given an expression (in this case C<$foo eq $bar>). If it's true, the test passed. If it's false, it didn't. That's about it. C<ok()> prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. It's highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) return $CLASS->builder->ok(@_); } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets L<Test::Harness> know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. This module is by no means trying to be a complete testing system. It's just to get you started. Once you're off the ground its recommended you look at L<Test::More>. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) && ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test 'Rating() get' # in t/film.t at line 14. ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B<explicitly> tested all the way back to perl 5.6.0. Test::Simple is thread-safe in perl 5.8.1 and up. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B<at all>. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 SEE ALSO =over 4 =item L<Test::More> More testing functions! Once you outgrow Test::Simple, look at L<Test::More>. Test::Simple is 100% forward compatible with L<Test::More> (i.e. you can just use L<Test::More> instead of Test::Simple in your programs and things will still work). =back Look in L<Test::More>'s SEE ALSO for more testing modules. =head1 AUTHORS Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> =cut 1; perl5/Test/Tester.pm 0000444 00000043635 14711217622 0010332 0 ustar 00 use strict; package Test::Tester; BEGIN { if (*Test::Builder::new{CODE}) { warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" } } use Test::Builder; use Test::Tester::CaptureRunner; use Test::Tester::Delegate; require Exporter; use vars qw( @ISA @EXPORT ); our $VERSION = '1.302186'; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); my $Test = Test::Builder->new; my $Capture = Test::Tester::Capture->new; my $Delegator = Test::Tester::Delegate->new; $Delegator->{Object} = $Test; my $runner = Test::Tester::CaptureRunner->new; my $want_space = $ENV{TESTTESTERSPACE}; sub show_space { $want_space = 1; } my $colour = ''; my $reset = ''; if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR}) { if (eval { require Term::ANSIColor; 1 }) { eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms my ($f, $b) = split(",", $want_colour); $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); $reset = Term::ANSIColor::color("reset"); } } sub new_new { return $Delegator; } sub capture { return Test::Tester::Capture->new; } sub fh { # experiment with capturing output, I don't like it $runner = Test::Tester::FHRunner->new; return $Test; } sub find_run_tests { my $d = 1; my $found = 0; while ((not $found) and (my ($sub) = (caller($d))[3]) ) { # print "$d: $sub\n"; $found = ($sub eq "Test::Tester::run_tests"); $d++; } # die "Didn't find 'run_tests' in caller stack" unless $found; return $d; } sub run_tests { local($Delegator->{Object}) = $Capture; $runner->run_tests(@_); return ($runner->get_premature, $runner->get_results); } sub check_test { my $test = shift; my $expect = shift; my $name = shift; $name = "" unless defined($name); @_ = ($test, [$expect], $name); goto &check_tests; } sub check_tests { my $test = shift; my $expects = shift; my $name = shift; $name = "" unless defined($name); my ($prem, @results) = eval { run_tests($test, $name) }; $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || $Test->diag("Before any testing anything, your tests said\n$prem"); local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_results(\@results, $expects, $name); return ($prem, @results); } sub cmp_field { my ($result, $expect, $field, $desc) = @_; if (defined $expect->{$field}) { $Test->is_eq($result->{$field}, $expect->{$field}, "$desc compare $field"); } } sub cmp_result { my ($result, $expect, $name) = @_; my $sub_name = $result->{name}; $sub_name = "" unless defined($name); my $desc = "subtest '$sub_name' of '$name'"; { local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_field($result, $expect, "ok", $desc); cmp_field($result, $expect, "actual_ok", $desc); cmp_field($result, $expect, "type", $desc); cmp_field($result, $expect, "reason", $desc); cmp_field($result, $expect, "name", $desc); } # if we got no depth then default to 1 my $depth = 1; if (exists $expect->{depth}) { $depth = $expect->{depth}; } # if depth was explicitly undef then don't test it if (defined $depth) { $Test->is_eq($result->{depth}, $depth, "checking depth") || $Test->diag('You need to change $Test::Builder::Level'); } if (defined(my $exp = $expect->{diag})) { my $got = ''; if (ref $exp eq 'Regexp') { if (not $Test->like($result->{diag}, $exp, "subtest '$sub_name' of '$name' compare diag")) { $got = $result->{diag}; } } else { # if there actually is some diag then put a \n on the end if it's not # there already $exp .= "\n" if (length($exp) and $exp !~ /\n$/); if (not $Test->ok($result->{diag} eq $exp, "subtest '$sub_name' of '$name' compare diag")) { $got = $result->{diag}; } } if ($got) { my $glen = length($got); my $elen = length($exp); for ($got, $exp) { my @lines = split("\n", $_); $_ = join("\n", map { if ($want_space) { $_ = $colour.escape($_).$reset; } else { "'$colour$_$reset'" } } @lines); } $Test->diag(<<EOM); Got diag ($glen bytes): $got Expected diag ($elen bytes): $exp EOM } } } sub escape { my $str = shift; my $res = ''; for my $char (split("", $str)) { my $c = ord($char); if(($c>32 and $c<125) or $c == 10) { $res .= $char; } else { $res .= sprintf('\x{%x}', $c) } } return $res; } sub cmp_results { my ($results, $expects, $name) = @_; $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); for (my $i = 0; $i < @$expects; $i++) { my $expect = $expects->[$i]; my $result = $results->[$i]; local $Test::Builder::Level = $Test::Builder::Level + 1; cmp_result($result, $expect, $name); } } ######## nicked from Test::More sub plan { my(@plan) = @_; my $caller = caller; $Test->exported_to($caller); my @imports = (); foreach my $idx (0..$#plan) { if( $plan[$idx] eq 'import' ) { my($tag, $imports) = splice @plan, $idx, 2; @imports = @$imports; last; } } $Test->plan(@plan); __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); } sub import { my($class) = shift; { no warnings 'redefine'; *Test::Builder::new = \&new_new; } goto &plan; } sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } ############ 1; __END__ =head1 NAME Test::Tester - Ease testing test modules built with Test::Builder =head1 SYNOPSIS use Test::Tester tests => 6; use Test::MyStyle; check_test( sub { is_mystyle_eq("this", "that", "not eq"); }, { ok => 0, # expect this to fail name => "not eq", diag => "Expected: 'this'\nGot: 'that'", } ); or use Test::Tester tests => 6; use Test::MyStyle; check_test( sub { is_mystyle_qr("this", "that", "not matching"); }, { ok => 0, # expect this to fail name => "not matching", diag => qr/Expected: 'this'\s+Got: 'that'/, } ); or use Test::Tester; use Test::More tests => 3; use Test::MyStyle; my ($premature, @results) = run_tests( sub { is_database_alive("dbname"); } ); # now use Test::More::like to check the diagnostic output like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); =head1 DESCRIPTION If you have written a test module based on Test::Builder then Test::Tester allows you to test it with the minimum of effort. =head1 HOW TO USE (THE EASY WAY) From version 0.08 Test::Tester no longer requires you to included anything special in your test modules. All you need to do is use Test::Tester; in your test script B<before> any other Test::Builder based modules and away you go. Other modules based on Test::Builder can be used to help with the testing. In fact you can even use functions from your module to test other functions from the same module (while this is possible it is probably not a good idea, if your module has bugs, then using it to test itself may give the wrong answers). The easiest way to test is to do something like check_test( sub { is_mystyle_eq("this", "that", "not eq") }, { ok => 0, # we expect the test to fail name => "not eq", diag => "Expected: 'this'\nGot: 'that'", } ); this will execute the is_mystyle_eq test, capturing its results and checking that they are what was expected. You may need to examine the test results in a more flexible way, for example, the diagnostic output may be quite long or complex or it may involve something that you cannot predict in advance like a timestamp. In this case you can get direct access to the test results: my ($premature, @results) = run_tests( sub { is_database_alive("dbname"); } ); like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag"); or check_test( sub { is_mystyle_qr("this", "that", "not matching") }, { ok => 0, # we expect the test to fail name => "not matching", diag => qr/Expected: 'this'\s+Got: 'that'/, } ); We cannot predict how long the database ping will take so we use Test::More's like() test to check that the diagnostic string is of the right form. =head1 HOW TO USE (THE HARD WAY) I<This is here for backwards compatibility only> Make your module use the Test::Tester::Capture object instead of the Test::Builder one. How to do this depends on your module but assuming that your module holds the Test::Builder object in $Test and that all your test routines access it through $Test then providing a function something like this sub set_builder { $Test = shift; } should allow your test scripts to do Test::YourModule::set_builder(Test::Tester->capture); and after that any tests inside your module will captured. =head1 TEST RESULTS The result of each test is captured in a hash. These hashes are the same as the hashes returned by Test::Builder->details but with a couple of extra fields. These fields are documented in L<Test::Builder> in the details() function =over 2 =item ok Did the test pass? =item actual_ok Did the test really pass? That is, did the pass come from Test::Builder->ok() or did it pass because it was a TODO test? =item name The name supplied for the test. =item type What kind of test? Possibilities include, skip, todo etc. See L<Test::Builder> for more details. =item reason The reason for the skip, todo etc. See L<Test::Builder> for more details. =back These fields are exclusive to Test::Tester. =over 2 =item diag Any diagnostics that were output for the test. This only includes diagnostics output B<after> the test result is declared. Note that Test::Builder ensures that any diagnostics end in a \n and it in earlier versions of Test::Tester it was essential that you have the final \n in your expected diagnostics. From version 0.10 onward, Test::Tester will add the \n if you forgot it. It will not add a \n if you are expecting no diagnostics. See below for help tracking down hard to find space and tab related problems. =item depth This allows you to check that your test module is setting the correct value for $Test::Builder::Level and thus giving the correct file and line number when a test fails. It is calculated by looking at caller() and $Test::Builder::Level. It should count how many subroutines there are before jumping into the function you are testing. So for example in run_tests( sub { my_test_function("a", "b") } ); the depth should be 1 and in sub deeper { my_test_function("a", "b") } run_tests(sub { deeper() }); depth should be 2, that is 1 for the sub {} and one for deeper(). This might seem a little complex but if your tests look like the simple examples in this doc then you don't need to worry as the depth will always be 1 and that's what Test::Tester expects by default. B<Note>: if you do not specify a value for depth in check_test() then it automatically compares it against 1, if you really want to skip the depth test then pass in undef. B<Note>: depth will not be correctly calculated for tests that run from a signal handler or an END block or anywhere else that hides the call stack. =back Some of Test::Tester's functions return arrays of these hashes, just like Test::Builder->details. That is, the hash for the first test will be array element 1 (not 0). Element 0 will not be a hash it will be a string which contains any diagnostic output that came before the first test. This should usually be empty, if it's not, it means something output diagnostics before any test results showed up. =head1 SPACES AND TABS Appearances can be deceptive, especially when it comes to emptiness. If you are scratching your head trying to work out why Test::Tester is saying that your diagnostics are wrong when they look perfectly right then the answer is probably whitespace. From version 0.10 on, Test::Tester surrounds the expected and got diag values with single quotes to make it easier to spot trailing whitespace. So in this example # Got diag (5 bytes): # 'abcd ' # Expected diag (4 bytes): # 'abcd' it is quite clear that there is a space at the end of the first string. Another way to solve this problem is to use colour and inverse video on an ANSI terminal, see below COLOUR below if you want this. Unfortunately this is sometimes not enough, neither colour nor quotes will help you with problems involving tabs, other non-printing characters and certain kinds of problems inherent in Unicode. To deal with this, you can switch Test::Tester into a mode whereby all "tricky" characters are shown as \{xx}. Tricky characters are those with ASCII code less than 33 or higher than 126. This makes the output more difficult to read but much easier to find subtle differences between strings. To turn on this mode either call C<show_space()> in your test script or set the C<TESTTESTERSPACE> environment variable to be a true value. The example above would then look like # Got diag (5 bytes): # abcd\x{20} # Expected diag (4 bytes): # abcd =head1 COLOUR If you prefer to use colour as a means of finding tricky whitespace characters then you can set the C<TESTTESTCOLOUR> environment variable to a comma separated pair of colours, the first for the foreground, the second for the background. For example "white,red" will print white text on a red background. This requires the Term::ANSIColor module. You can specify any colour that would be acceptable to the Term::ANSIColor::color function. If you spell colour differently, that's no problem. The C<TESTTESTERCOLOR> variable also works (if both are set then the British spelling wins out). =head1 EXPORTED FUNCTIONS =head3 ($premature, @results) = run_tests(\&test_sub) \&test_sub is a reference to a subroutine. run_tests runs the subroutine in $test_sub and captures the results of any tests inside it. You can run more than 1 test inside this subroutine if you like. $premature is a string containing any diagnostic output from before the first test. @results is an array of test result hashes. =head3 cmp_result(\%result, \%expect, $name) \%result is a ref to a test result hash. \%expect is a ref to a hash of expected values for the test result. cmp_result compares the result with the expected values. If any differences are found it outputs diagnostics. You may leave out any field from the expected result and cmp_result will not do the comparison of that field. =head3 cmp_results(\@results, \@expects, $name) \@results is a ref to an array of test results. \@expects is a ref to an array of hash refs. cmp_results checks that the results match the expected results and if any differences are found it outputs diagnostics. It first checks that the number of elements in \@results and \@expects is the same. Then it goes through each result checking it against the expected result as in cmp_result() above. =head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name) \&test_sub is a reference to a subroutine. \@expect is a ref to an array of hash refs which are expected test results. check_tests combines run_tests and cmp_tests into a single call. It also checks if the tests died at any stage. It returns the same values as run_tests, so you can further examine the test results if you need to. =head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name) \&test_sub is a reference to a subroutine. \%expect is a ref to an hash of expected values for the test result. check_test is a wrapper around check_tests. It combines run_tests and cmp_tests into a single call, checking if the test died. It assumes that only a single test is run inside \&test_sub and include a test to make sure this is true. It returns the same values as run_tests, so you can further examine the test results if you need to. =head3 show_space() Turn on the escaping of characters as described in the SPACES AND TABS section. =head1 HOW IT WORKS Normally, a test module (let's call it Test:MyStyle) calls Test::Builder->new to get the Test::Builder object. Test::MyStyle calls methods on this object to record information about test results. When Test::Tester is loaded, it replaces Test::Builder's new() method with one which returns a Test::Tester::Delegate object. Most of the time this object behaves as the real Test::Builder object. Any methods that are called are delegated to the real Test::Builder object so everything works perfectly. However once we go into test mode, the method calls are no longer passed to the real Test::Builder object, instead they go to the Test::Tester::Capture object. This object seems exactly like the real Test::Builder object, except, instead of outputting test results and diagnostics, it just records all the information for later analysis. =head1 CAVEATS Support for calling Test::Builder->note is minimal. It's implemented as an empty stub, so modules that use it will not crash but the calls are not recorded for testing purposes like the others. Patches welcome. =head1 SEE ALSO L<Test::Builder> the source of testing goodness. L<Test::Builder::Tester> for an alternative approach to the problem tackled by Test::Tester - captures the strings output by Test::Builder. This means you cannot get separate access to the individual pieces of information and you must predict B<exactly> what your test will output. =head1 AUTHOR This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts are based on other people's work. Plan handling lifted from Test::More. written by Michael G Schwern <schwern@pobox.com>. Test::Tester::Capture is a cut down and hacked up version of Test::Builder. Test::Builder was written by chromatic <chromatic@wgz.org> and Michael G Schwern <schwern@pobox.com>. =head1 LICENSE Under the same license as Perl itself See http://www.perl.com/perl/misc/Artistic.html =cut perl5/Test/use/ok.pm 0000444 00000002520 14711217623 0010256 0 ustar 00 package Test::use::ok; use 5.005; our $VERSION = '1.302186'; __END__ =head1 NAME Test::use::ok - Alternative to Test::More::use_ok =head1 SYNOPSIS use ok 'Some::Module'; =head1 DESCRIPTION According to the B<Test::More> documentation, it is recommended to run C<use_ok()> inside a C<BEGIN> block, so functions are exported at compile-time and prototypes are properly honored. That is, instead of writing this: use_ok( 'Some::Module' ); use_ok( 'Other::Module' ); One should write this: BEGIN { use_ok( 'Some::Module' ); } BEGIN { use_ok( 'Other::Module' ); } However, people often either forget to add C<BEGIN>, or mistakenly group C<use_ok> with other tests in a single C<BEGIN> block, which can create subtle differences in execution order. With this module, simply change all C<use_ok> in test scripts to C<use ok>, and they will be executed at C<BEGIN> time. The explicit space after C<use> makes it clear that this is a single compile-time action. =head1 SEE ALSO L<Test::More> =head1 MAINTAINER =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =encoding utf8 =head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L<Test-use-ok>. This work is published from Taiwan. L<http://creativecommons.org/publicdomain/zero/1.0> =cut perl5/Test/Alien.pm 0000444 00000060113 14711217623 0010103 0 ustar 00 package Test::Alien; use strict; use warnings; use 5.008004; use Env qw( @PATH ); use File::Which 1.10 qw( which ); use Capture::Tiny qw( capture capture_merged ); use Alien::Build::Temp; use File::Copy qw( move ); use Text::ParseWords qw( shellwords ); use Test2::API qw( context run_subtest ); use Exporter qw( import ); use Path::Tiny qw( path ); use Alien::Build::Util qw( _dump ); use Config; our @EXPORT = qw( alien_ok run_ok xs_ok ffi_ok with_subtest synthetic helper_ok interpolate_template_is ); # ABSTRACT: Testing tools for Alien modules our $VERSION = '2.41'; # VERSION our @aliens; sub alien_ok ($;$) { my($alien, $message) = @_; my $name = ref $alien ? ref($alien) . '[instance]' : $alien; $name = 'undef' unless defined $name; my @methods = qw( cflags libs dynamic_libs bin_dir ); $message ||= "$name responds to: @methods"; my $ok; my @diag; if(defined $alien) { my @missing = grep { ! $alien->can($_) } @methods; $ok = !@missing; push @diag, map { " missing method $_" } @missing; if($ok) { push @aliens, $alien; unshift @PATH, $alien->bin_dir; } } else { $ok = 0; push @diag, " undefined alien"; } my $ctx = context(); $ctx->ok($ok, $message); $ctx->diag($_) for @diag; $ctx->release; $ok; } sub synthetic { my($opt) = @_; $opt ||= {}; my %alien = %$opt; require Test::Alien::Synthetic; bless \%alien, 'Test::Alien::Synthetic', } sub run_ok { my($command, $message) = @_; my(@command) = ref $command ? @$command : ($command); $message ||= "run @command"; require Test::Alien::Run; my $run = bless { out => '', err => '', exit => 0, sig => 0, cmd => [@command], }, 'Test::Alien::Run'; my $ctx = context(); my $exe = which $command[0]; if(defined $exe) { shift @command; $run->{cmd} = [$exe, @command]; my @diag; my $ok = 1; my($exit, $errno); ($run->{out}, $run->{err}, $exit, $errno) = capture { system $exe, @command; ($?,$!); }; if($exit == -1) { $ok = 0; $run->{fail} = "failed to execute: $errno"; push @diag, " failed to execute: $errno"; } elsif($exit & 127) { $ok = 0; push @diag, " killed with signal: @{[ $exit & 127 ]}"; $run->{sig} = $exit & 127; } else { $run->{exit} = $exit >> 8; } $ctx->ok($ok, $message); $ok ? $ctx->note(" using $exe") : $ctx->diag(" using $exe"); $ctx->diag(@diag) for @diag; } else { $ctx->ok(0, $message); $ctx->diag(" command not found"); $run->{fail} = 'command not found'; } unless(@aliens) { $ctx->diag("run_ok called without any aliens, you may want to call alien_ok"); } $ctx->release; $run; } sub _flags { my($class, $method) = @_; my $static = "${method}_static"; $class->can($static) && $class->can('install_type') && $class->install_type eq 'share' && (!$class->can('xs_load')) ? $class->$static : $class->$method; } sub xs_ok { my $cb; $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE'; my($xs, $message) = @_; $message ||= 'xs'; $xs = { xs => $xs } unless ref $xs; # make sure this is a copy because we may # modify it. $xs->{xs} = "@{[ $xs->{xs} ]}"; $xs->{pxs} ||= {}; $xs->{cbuilder_check} ||= 'have_compiler'; $xs->{cbuilder_config} ||= {}; $xs->{cbuilder_compile} ||= {}; $xs->{cbuilder_link} ||= {}; require ExtUtils::CBuilder; my $skip = do { my $have_compiler = $xs->{cbuilder_check}; !ExtUtils::CBuilder->new( config => $xs->{cbuilder_config} )->$have_compiler; }; if($skip) { my $ctx = context(); $ctx->skip($message, 'test requires a compiler'); $ctx->skip("$message subtest", 'test requires a compiler') if $cb; $ctx->release; return; } if($xs->{cpp} || $xs->{'C++'}) { my $ctx = context(); $ctx->bail("The cpp and C++ options have been removed from xs_ok"); } else { $xs->{c_ext} ||= 'c'; } my $verbose = $xs->{verbose} || 0; my $ok = 1; my @diag; my $dir = Alien::Build::Temp->newdir( TEMPLATE => 'test-alien-XXXXXX', CLEANUP => $^O =~ /^(MSWin32|cygwin|msys)$/ ? 0 : 1, ); my $xs_filename = path($dir)->child('test.xs')->stringify; my $c_filename = path($dir)->child("test.@{[ $xs->{c_ext} ]}")->stringify; my $ctx = context(); my $module; if($xs->{xs} =~ /\bTA_MODULE\b/) { our $count; $count = 0 unless defined $count; my $name = sprintf "Test::Alien::XS::Mod%s%s", $count, chr(65 + $count % 26 ) x 4; $count++; my $code = $xs->{xs}; $code =~ s{\bTA_MODULE\b}{$name}g; $xs->{xs} = $code; } # this regex copied shamefully from ExtUtils::ParseXS # in part because we need the module name to do the bootstrap # and also because if this regex doesn't match then ParseXS # does an exit() which we don't want. if($xs->{xs} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/m) { $module = $1; $ctx->note("detect module name $module") if $verbose; } else { $ok = 0; push @diag, ' XS does not have a module decleration that we could find'; } if($ok) { open my $fh, '>', $xs_filename; print $fh $xs->{xs}; close $fh; require ExtUtils::ParseXS; my $pxs = ExtUtils::ParseXS->new; my($out, $err) = capture_merged { eval { $pxs->process_file( filename => $xs_filename, output => $c_filename, versioncheck => 0, prototypes => 0, %{ $xs->{pxs} }, ); }; $@; }; $ctx->note("parse xs $xs_filename => $c_filename") if $verbose; $ctx->note($out) if $verbose; $ctx->note("error: $err") if $verbose && $err; unless($pxs->report_error_count == 0) { $ok = 0; push @diag, ' ExtUtils::ParseXS failed:'; push @diag, " $err" if $err; push @diag, " $_" for split /\r?\n/, $out; } } push @diag, "xs_ok called without any aliens, you may want to call alien_ok" unless @aliens; if($ok) { my $cb = ExtUtils::CBuilder->new( config => do { my %config = %{ $xs->{cbuilder_config} }; my $lddlflags = join(' ', grep !/^-l/, shellwords map { _flags $_, 'libs' } @aliens) . " $Config{lddlflags}"; $config{lddlflags} = defined $config{lddlflags} ? "$lddlflags $config{lddlflags}" : $lddlflags; \%config; }, ); my %compile_options = ( source => $c_filename, %{ $xs->{cbuilder_compile} }, ); if(defined $compile_options{extra_compiler_flags} && ref($compile_options{extra_compiler_flags}) eq '') { $compile_options{extra_compiler_flags} = [ shellwords $compile_options{extra_compiler_flags} ]; } push @{ $compile_options{extra_compiler_flags} }, shellwords map { _flags $_, 'cflags' } @aliens; my($out, $obj, $err) = capture_merged { my $obj = eval { $cb->compile(%compile_options); }; ($obj, $@); }; $ctx->note("compile $c_filename") if $verbose; $ctx->note($out) if $verbose; $ctx->note($err) if $verbose && $err; if($verbose > 1) { $ctx->note(_dump({ compile_options => \%compile_options })); } unless($obj) { $ok = 0; push @diag, ' ExtUtils::CBuilder->compile failed'; push @diag, " $err" if $err; push @diag, " $_" for split /\r?\n/, $out; } if($ok) { my %link_options = ( objects => [$obj], module_name => $module, %{ $xs->{cbuilder_link} }, ); if(defined $link_options{extra_linker_flags} && ref($link_options{extra_linker_flags}) eq '') { $link_options{extra_linker_flags} = [ shellwords $link_options{extra_linker_flags} ]; } unshift @{ $link_options{extra_linker_flags} }, grep /^-l/, shellwords map { _flags $_, 'libs' } @aliens; my($out, $lib, $err) = capture_merged { my $lib = eval { $cb->link(%link_options); }; ($lib, $@); }; $ctx->note("link $obj") if $verbose; $ctx->note($out) if $verbose; $ctx->note($err) if $verbose && $err; if($verbose > 1) { $ctx->note(_dump({ link_options => \%link_options })); } if($lib && -f $lib) { $ctx->note("created lib $lib") if $xs->{verbose}; } else { $ok = 0; push @diag, ' ExtUtils::CBuilder->link failed'; push @diag, " $err" if $err; push @diag, " $_" for split /\r?\n/, $out; } if($ok) { my @modparts = split(/::/,$module); my $dl_dlext = $Config{dlext}; my $modfname = $modparts[-1]; my $libpath = path($dir)->child('auto', @modparts, "$modfname.$dl_dlext"); $libpath->parent->mkpath; move($lib, "$libpath") || die "unable to copy $lib => $libpath $!"; pop @modparts; my $pmpath = path($dir)->child(@modparts, "$modfname.pm"); $pmpath->parent->mkpath; open my $fh, '>', "$pmpath"; my($alien_with_xs_load, @rest) = grep { $_->can('xs_load') } @aliens; if($alien_with_xs_load) { { no strict 'refs'; @{join '::', $module, 'rest'} = @rest; ${join '::', $module, 'alien_with_xs_load'} = $alien_with_xs_load; } print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{ package $module; use strict; use warnings; our \$VERSION = '0.01'; our \@rest; our \$alien_with_xs_load; \$alien_with_xs_load->xs_load('$module', \$VERSION, \@rest); 1; }; } else { print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{ package $module; use strict; use warnings; require XSLoader; our \$VERSION = '0.01'; XSLoader::load('$module',\$VERSION); 1; }; } close $fh; { local @INC = @INC; unshift @INC, "$dir"; ## no critic eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{ use $module; }; ## use critic } if(my $error = $@) { $ok = 0; push @diag, ' XSLoader failed'; push @diag, " $error"; } } } } $ctx->ok($ok, $message); $ctx->diag($_) for @diag; $ctx->release; if($cb) { $cb = sub { my $ctx = context(); $ctx->plan(0, 'SKIP', "subtest requires xs success"); $ctx->release; } unless $ok; @_ = ("$message subtest", $cb, 1, $module); goto \&Test2::API::run_subtest; } $ok; } sub with_subtest (&) { my($code) = @_; # it may be possible to catch a segmentation fault, # but not with signal handlers apparently. See: # https://feepingcreature.github.io/handling.html return $code if $^O eq 'MSWin32'; # try to catch a segmentation fault and bail out # with a useful diagnostic. prove test to swallow # the diagnostic on such failures. sub { local $SIG{SEGV} = sub { my $ctx = context(); $ctx->bail("Segmentation fault"); }; $code->(@_); } } sub ffi_ok { my $cb; $cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE'; my($opt, $message) = @_; $message ||= 'ffi'; my $ok = 1; my $skip; my $ffi; my @diag; { my $min = '0.12'; # the first CPAN release $min = '0.15' if $opt->{ignore_not_found}; $min = '0.18' if $opt->{lang}; $min = '0.99' if defined $opt->{api} && $opt->{api} > 0; unless(eval { require FFI::Platypus; FFI::Platypus->VERSION($min) }) { $ok = 0; $skip = "Test requires FFI::Platypus $min"; } } if($ok && $opt->{lang}) { my $class = "FFI::Platypus::Lang::@{[ $opt->{lang} ]}"; { my $pm = "$class.pm"; $pm =~ s/::/\//g; eval { require $pm }; } if($@) { $ok = 0; $skip = "Test requires FFI::Platypus::Lang::@{[ $opt->{lang} ]}"; } } unless(@aliens) { push @diag, 'ffi_ok called without any aliens, you may want to call alien_ok'; } if($ok) { $ffi = FFI::Platypus->new( do { my @args = ( lib => [map { $_->dynamic_libs } @aliens], ignore_not_found => $opt->{ignore_not_found}, lang => $opt->{lang}, ); push @args, api => $opt->{api} if defined $opt->{api}; @args; } ); foreach my $symbol (@{ $opt->{symbols} || [] }) { unless($ffi->find_symbol($symbol)) { $ok = 0; push @diag, " $symbol not found" } } } my $ctx = context(); if($skip) { $ctx->skip($message, $skip); } else { $ctx->ok($ok, $message); } $ctx->diag($_) for @diag; $ctx->release; if($cb) { $cb = sub { my $ctx = context(); $ctx->plan(0, 'SKIP', "subtest requires ffi success"); $ctx->release; } unless $ok; @_ = ("$message subtest", $cb, 1, $ffi); goto \&Test2::API::run_subtest; } $ok; } sub _interpolator { require Alien::Build::Interpolate::Default; my $intr = Alien::Build::Interpolate::Default->new; foreach my $alien (@aliens) { if($alien->can('alien_helper')) { my $help = $alien->alien_helper; foreach my $name (keys %$help) { my $code = $help->{$name}; $intr->replace_helper($name, $code); } } } $intr; } sub helper_ok { my($name, $message) = @_; $message ||= "helper $name exists"; my $intr = _interpolator; my $code = $intr->has_helper($name); my $ok = defined $code; my $ctx = context(); $ctx->ok($ok, $message); $ctx->diag("helper_ok called without any aliens, you may want to call alien_ok") unless @aliens; $ctx->release; $ok; } sub interpolate_template_is { my($template, $pattern, $message) = @_; $message ||= "template matches"; my $intr = _interpolator; my $value = eval { $intr->interpolate($template) }; my $error = $@; my @diag; my $ok; if($error) { $ok = 0; push @diag, "error in evaluation:"; push @diag, " $error"; } elsif(ref($pattern) eq 'Regexp') { $ok = $value =~ $pattern; push @diag, "value '$value' does not match $pattern'" unless $ok; } else { $ok = $value eq "$pattern"; push @diag, "value '$value' does not equal '$pattern'" unless $ok; } my $ctx = context(); $ctx->ok($ok, $message, [@diag]); $ctx->diag('interpolate_template_is called without any aliens, you may want to call alien_ok') unless @aliens; $ctx->release; $ok; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien - Testing tools for Alien modules =head1 VERSION version 2.41 =head1 SYNOPSIS Test commands that come with your Alien: use Test2::V0; use Test::Alien; use Alien::patch; alien_ok 'Alien::patch'; run_ok([ 'patch', '--version' ]) ->success # we only accept the version written # by Larry ... ->out_like(qr{Larry Wall}); done_testing; Test that your library works with C<XS>: use Test2::V0; use Test::Alien; use Alien::Editline; alien_ok 'Alien::Editline'; my $xs = do { local $/; <DATA> }; xs_ok $xs, with_subtest { my($module) = @_; ok $module->version; }; done_testing; __DATA__ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include <editline/readline.h> const char * version(const char *class) { return rl_library_version; } MODULE = TA_MODULE PACKAGE = TA_MODULE const char *version(class); const char *class; Test that your library works with L<FFI::Platypus>: use Test2::V0; use Test::Alien; use Alien::LibYAML; alien_ok 'Alien::LibYAML'; ffi_ok { symbols => ['yaml_get_version'] }, with_subtest { my($ffi) = @_; my $get_version = $ffi->function(yaml_get_version => ['int*','int*','int*'] => 'void'); $get_version->call(\my $major, \my $minor, \my $patch); like $major, qr{[0-9]+}; like $minor, qr{[0-9]+}; like $patch, qr{[0-9]+}; }; done_testing; =head1 DESCRIPTION This module provides tools for testing L<Alien> modules. It has hooks to work easily with L<Alien::Base> based modules, but can also be used via the synthetic interface to test non L<Alien::Base> based L<Alien> modules. It has very modest prerequisites. Prior to this module the best way to test a L<Alien> module was via L<Test::CChecker>. The main downside to that module is that it is heavily influenced by and uses L<ExtUtils::CChecker>, which is a tool for checking at install time various things about your compiler. It was also written before L<Alien::Base> became as stable as it is today. In particular, L<Test::CChecker> does its testing by creating an executable and running it. Unfortunately Perl uses extensions by creating dynamic libraries and linking them into the Perl process, which is different in subtle and error prone ways. This module attempts to test the libraries in the way that they will actually be used, via either C<XS> or L<FFI::Platypus>. It also provides a mechanism for testing binaries that are provided by the various L<Alien> modules (for example L<Alien::gmake> and L<Alien::patch>). L<Alien> modules can actually be useable without a compiler, or without L<FFI::Platypus> (for example, if the library is provided by the system, and you are using L<FFI::Platypus>, or if you are building from source and you are using C<XS>), so tests with missing prerequisites are automatically skipped. For example, L</xs_ok> will automatically skip itself if a compiler is not found, and L</ffi_ok> will automatically skip itself if L<FFI::Platypus> is not installed. =head1 FUNCTIONS =head2 alien_ok alien_ok $alien, $message; alien_ok $alien; Load the given L<Alien> instance or class. Checks that the instance or class conforms to the same interface as L<Alien::Base>. Will be used by subsequent tests. The C<$alien> module only needs to provide these methods in order to conform to the L<Alien::Base> interface: =over 4 =item cflags String containing the compiler flags =item libs String containing the linker and library flags =item dynamic_libs List of dynamic libraries. Returns empty list if the L<Alien> module does not provide this. =item bin_dir Directory containing tool binaries. Returns empty list if the L<Alien> module does not provide this. =back If your L<Alien> module does not conform to this interface then you can create a synthetic L<Alien> module using the L</synthetic> function. =head2 synthetic my $alien = synthetic \%config; Create a synthetic L<Alien> module which can be passed into L</alien_ok>. C<\%config> can contain these keys (all of which are optional): =over 4 =item cflags String containing the compiler flags. =item cflags_static String containing the static compiler flags (optional). =item libs String containing the linker and library flags. =item libs_static String containing the static linker flags (optional). =item dynamic_libs List reference containing the dynamic libraries. =item bin_dir Tool binary directory. =item runtime_prop Runtime properties. =back See L<Test::Alien::Synthetic> for more details. =head2 run_ok my $run = run_ok $command; my $run = run_ok $command, $message; Runs the given command, falling back on any C<Alien::Base#bin_dir> methods provided by L<Alien> modules specified with L</alien_ok>. C<$command> can be either a string or an array reference. Only fails if the command cannot be found, or if it is killed by a signal! Returns a L<Test::Alien::Run> object, which you can use to test the exit status, output and standard error. Always returns an instance of L<Test::Alien::Run>, even if the command could not be found. =head2 xs_ok xs_ok $xs; xs_ok $xs, $message; Compiles, links the given C<XS> code and attaches to Perl. If you use the special module name C<TA_MODULE> in your C<XS> code, it will be replaced by an automatically generated package name. This can be useful if you want to pass the same C<XS> code to multiple calls to C<xs_ok> without subsequent calls replacing previous ones. C<$xs> may be either a string containing the C<XS> code, or a hash reference with these keys: =over 4 =item xs The XS code. This is the only required element. =item pxs Extra L<ExtUtils::ParseXS> arguments passed in as a hash reference. =item cbuilder_check The compile check that should be done prior to attempting to build. Should be one of C<have_compiler> or C<have_cplusplus>. Defaults to C<have_compiler>. =item cbuilder_config Hash to override values normally provided by C<Config>. =item cbuilder_compile Extra The L<ExtUtils::CBuilder> arguments passed in as a hash reference. =item cbuilder_link Extra The L<ExtUtils::CBuilder> arguments passed in as a hash reference. =item verbose Spew copious debug information via test note. =back You can use the C<with_subtest> keyword to conditionally run a subtest if the C<xs_ok> call succeeds. If C<xs_ok> does not work, then the subtest will automatically be skipped. Example: xs_ok $xs, with_subtest { # skipped if $xs fails for some reason my($module) = @_; is $module->foo, 1; }; The module name detected during the XS parsing phase will be passed in to the subtest. This is helpful when you are using a generated module name. If you need to test XS C++ interfaces, see L<Test::Alien::CPP>. =head2 ffi_ok ffi_ok; ffi_ok \%opt; ffi_ok \%opt, $message; Test that L<FFI::Platypus> works. C<\%opt> is a hash reference with these keys (all optional): =over 4 =item symbols List references of symbols that must be found for the test to succeed. =item ignore_not_found Ignores symbols that aren't found. This affects functions accessed via L<FFI::Platypus#attach> and L<FFI::Platypus#function> methods, and does not influence the C<symbols> key above. =item lang Set the language. Used primarily for language specific native types. =item api Set the API. C<api = 1> requires FFI::Platypus 0.99 or later. This option was added with Test::Alien version 1.90, so your use line should include this version as a safeguard to make sure it works: use Test::Alien 1.90; ... ffi_ok ...; =back As with L</xs_ok> above, you can use the C<with_subtest> keyword to specify a subtest to be run if C<ffi_ok> succeeds (it will skip otherwise). The L<FFI::Platypus> instance is passed into the subtest as the first argument. For example: ffi_ok with_subtest { my($ffi) = @_; is $ffi->function(foo => [] => 'void')->call, 42; }; =head2 helper_ok helper_ok $name; helper_ok $name, $message; Tests that the given helper has been defined. =head2 interpolate_template_is interpolate_template_is $template, $string; interpolate_template_is $template, $string, $message; interpolate_template_is $template, $regex; interpolate_template_is $template, $regex, $message; Tests that the given template when evaluated with the appropriate helpers will match either the given string or regular expression. =head1 SEE ALSO =over 4 =item L<Alien> =item L<Alien::Base> =item L<Alien::Build> =item L<alienfile> =item L<Test2> =item L<Test::Alien::Run> =item L<Test::Alien::CanCompile> =item L<Test::Alien::CanPlatypus> =item L<Test::Alien::Synthetic> =item L<Test::Alien::CPP> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/More.pm 0000444 00000147365 14711217625 0007776 0 ustar 00 package Test::More; use 5.006; use strict; use warnings; #---- perlcritic exemptions. ----# # We use a lot of subroutine prototypes ## no critic (Subroutines::ProhibitSubroutinePrototypes) # Can't use Carp because it might cause C<use_ok()> to accidentally succeed # even though the module being used forgot to use Carp. Yes, this # actually happened. sub _carp { my( $file, $line ) = ( caller(1) )[ 1, 2 ]; return warn @_, " at $file line $line\n"; } our $VERSION = '1.302186'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); our @EXPORT = qw(ok use_ok require_ok is isnt like unlike is_deeply cmp_ok skip todo todo_skip pass fail eq_array eq_hash eq_set $TODO plan done_testing can_ok isa_ok new_ok diag note explain subtest BAIL_OUT ); =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => 23; # or use Test::More skip_all => $reason; # or use Test::More; # see done_testing() require_ok( 'Some::Module' ); # Various ways to say "ok" ok($got eq $expected, $test_name); is ($got, $expected, $test_name); isnt($got, $expected, $test_name); # Rather than print STDERR "# here's what went wrong\n" diag("here's what went wrong"); like ($got, qr/expected/, $test_name); unlike($got, qr/expected/, $test_name); cmp_ok($got, '==', $expected, $test_name); is_deeply($got_complex_structure, $expected_complex_structure, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); BAIL_OUT($why); # UNIMPLEMENTED!!! my @status = Test::More::status; =head1 DESCRIPTION B<STOP!> If you're just getting started writing tests, have a look at L<Test2::Suite> first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. The purpose of this module is to provide a wide range of testing utilities. Various ways to say "ok" with better diagnostics, facilities to skip tests, test future features and compare complicated data structures. While you can do almost anything with a simple C<ok()> function, it doesn't provide good diagnostic output. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The preferred way to do this is to declare a plan when you C<use Test::More>. use Test::More tests => 23; There are cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare your tests at the end. use Test::More; ... run your tests ... done_testing( $number_of_tests_run ); B<NOTE> C<done_testing()> should never be called in an C<END { ... }> block. Sometimes you really don't know how many tests were run, or it's too difficult to calculate. In which case you can leave off $number_of_tests_run. In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L<Test::Harness> for details. If you want to control what functions Test::More will export, you have to use the 'import' option. For example, to import everything but 'fail', you'd do: use Test::More tests => 23, import => ['!fail']; Alternatively, you can use the C<plan()> function. Useful for when you have to calculate the number of tests. use Test::More; plan tests => keys %Stuff * 3; or for deciding between running the tests at all: use Test::More; if( $^O eq 'MacOS' ) { plan skip_all => 'Test irrelevant on MacOS'; } else { plan tests => 42; } =cut sub plan { my $tb = Test::More->builder; return $tb->plan(@_); } # This implements "use Test::More 'no_diag'" but the behavior is # deprecated. sub import_extra { my $class = shift; my $list = shift; my @other = (); my $idx = 0; my $import; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'no_diag' ) { $class->builder->no_diag(1); } elsif( defined $item and $item eq 'import' ) { if ($import) { push @$import, @{$list->[ ++$idx ]}; } else { $import = $list->[ ++$idx ]; push @other, $item, $import; } } else { push @other, $item; } $idx++; } @$list = @other; if ($class eq __PACKAGE__ && (!$import || grep $_ eq '$TODO', @$import)) { my $to = $class->builder->exported_to; no strict 'refs'; *{"$to\::TODO"} = \our $TODO; if ($import) { @$import = grep $_ ne '$TODO', @$import; } else { push @$list, import => [grep $_ ne '$TODO', @EXPORT]; } } return; } =over 4 =item B<done_testing> done_testing(); done_testing($number_of_tests); If you don't know how many tests you're going to run, you can issue the plan when you're done running tests. $number_of_tests is the same as C<plan()>, it's the number of tests you expected to run. You can omit this, in which case the number of tests you ran doesn't matter, just the fact that your tests ran to conclusion. This is safer than and replaces the "no_plan" plan. B<Note:> You must never put C<done_testing()> inside an C<END { ... }> block. The plan is there to ensure your test does not exit before testing has completed. If you use an END block you completely bypass this protection. =back =cut sub done_testing { my $tb = Test::More->builder; $tb->done_testing(@_); } =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, it's often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. It's optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B<ok> ok($got eq $expected, $test_name); This simply evaluates any expression (C<$got eq $expected> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep(!defined $_, @items), 'all items defined' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B<very> strongly encourage its use. Should an C<ok()> fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 'sufficient mucus' # in foo.t at line 42. This is the same as L<Test::Simple>'s C<ok()> routine. =cut sub ok ($;$) { my( $test, $name ) = @_; my $tb = Test::More->builder; return $tb->ok( $test, $name ); } =item B<is> =item B<isnt> is ( $got, $expected, $test_name ); isnt( $got, $expected, $test_name ); Similar to C<ok()>, C<is()> and C<isnt()> compare their two arguments with C<eq> and C<ne> respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); C<undef> will only ever match C<undef>. So you can test a value against C<undef> like this: is($not_defined, undef, "undefined as expected"); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. C<ok()> cannot know what you are testing for (beyond the name), but C<is()> and C<isnt()> know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test 'Is foo the same as bar?' # in foo.t at line 139. # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use C<is()> and C<isnt()> over C<ok()> where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); This does not check if C<exists $brooklyn{tree}> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use C<ok()>. ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); A simple call to C<isnt()> usually does not provide a strong test but there are cases when you cannot say much more about a value than that it is different from some other value: new_ok $obj, "Foo"; my $clone = $obj->clone; isa_ok $obj, "Foo", "Foo->clone"; isnt $obj, $clone, "clone() produces a different object"; For those grammatical pedants out there, there's an C<isn't()> function which is an alias of C<isnt()>. =cut sub is ($$;$) { my $tb = Test::More->builder; return $tb->is_eq(@_); } sub isnt ($$;$) { my $tb = Test::More->builder; return $tb->isnt_eq(@_); } *isn't = \&isnt; # ' to unconfuse syntax higlighters =item B<like> like( $got, qr/expected/, $test_name ); Similar to C<ok()>, C<like()> matches $got against the regex C<qr/expected/>. So this: like($got, qr/expected/, 'this is like that'); is similar to: ok( $got =~ m/expected/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (i.e. C<qr//>) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $got, '/expected/', 'this is like that' ); Regex options may be placed on the end (C<'/expected/i'>). Its advantages over C<ok()> are similar to that of C<is()> and C<isnt()>. Better diagnostics on failure. =cut sub like ($$;$) { my $tb = Test::More->builder; return $tb->like(@_); } =item B<unlike> unlike( $got, qr/expected/, $test_name ); Works exactly as C<like()>, only it checks if $got B<does not> match the given pattern. =cut sub unlike ($$;$) { my $tb = Test::More->builder; return $tb->unlike(@_); } =item B<cmp_ok> cmp_ok( $got, $op, $expected, $test_name ); Halfway between C<ok()> and C<is()> lies C<cmp_ok()>. This allows you to compare two arguments using any binary perl operator. The test passes if the comparison is true and fails otherwise. # ok( $got eq $expected ); cmp_ok( $got, 'eq', $expected, 'this eq that' ); # ok( $got == $expected ); cmp_ok( $got, '==', $expected, 'this == that' ); # ok( $got && $expected ); cmp_ok( $got, '&&', $expected, 'this && that' ); ...etc... Its advantage over C<ok()> is when the test fails you'll know what $got and $expected were: not ok 1 # Failed test in foo.t at line 12. # '23' # && # undef It's also useful in those cases where you are comparing numbers and C<is()>'s use of C<eq> will interfere: cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); It's especially useful when comparing greater-than or smaller-than relation between values: cmp_ok( $some_value, '<=', $upper_limit ); =cut sub cmp_ok($$$;$) { my $tb = Test::More->builder; return $tb->cmp_ok(@_); } =item B<can_ok> can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. No matter how many @methods you check, a single C<can_ok()> call counts as one test. If you desire otherwise, use: foreach my $meth (@methods) { can_ok('Foo', $meth); } =cut sub can_ok ($@) { my( $proto, @methods ) = @_; my $class = ref $proto || $proto; my $tb = Test::More->builder; unless($class) { my $ok = $tb->ok( 0, "->can(...)" ); $tb->diag(' can_ok() called with empty class or reference'); return $ok; } unless(@methods) { my $ok = $tb->ok( 0, "$class->can(...)" ); $tb->diag(' can_ok() called with no methods'); return $ok; } my @nok = (); foreach my $method (@methods) { $tb->_try( sub { $proto->can($method) } ) or push @nok, $method; } my $name = (@methods == 1) ? "$class->can('$methods[0]')" : "$class->can(...)" ; my $ok = $tb->ok( !@nok, $name ); $tb->diag( map " $class->can('$_') failed\n", @nok ); return $ok; } =item B<isa_ok> isa_ok($object, $class, $object_name); isa_ok($subclass, $class, $object_name); isa_ok($ref, $type, $ref_name); Checks to see if the given C<< $object->isa($class) >>. Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. You can also test a class, to make sure that it has the right ancestor: isa_ok( 'Vole', 'Rodent' ); It works on references, too: isa_ok( $array_ref, 'ARRAY' ); The diagnostics of this test normally just refer to 'the object'. If you'd like them to be more specific, you can supply an $object_name (for example 'Test customer'). =cut sub isa_ok ($$;$) { my( $thing, $class, $thing_name ) = @_; my $tb = Test::More->builder; my $whatami; if( !defined $thing ) { $whatami = 'undef'; } elsif( ref $thing ) { $whatami = 'reference'; local($@,$!); require Scalar::Util; if( Scalar::Util::blessed($thing) ) { $whatami = 'object'; } } else { $whatami = 'class'; } # We can't use UNIVERSAL::isa because we want to honor isa() overrides my( $rslt, $error ) = $tb->_try( sub { $thing->isa($class) } ); if($error) { die <<WHOA unless $error =~ /^Can't (locate|call) method "isa"/; WHOA! I tried to call ->isa on your $whatami and got some weird error. Here's the error. $error WHOA } # Special case for isa_ok( [], "ARRAY" ) and like if( $whatami eq 'reference' ) { $rslt = UNIVERSAL::isa($thing, $class); } my($diag, $name); if( defined $thing_name ) { $name = "'$thing_name' isa '$class'"; $diag = defined $thing ? "'$thing_name' isn't a '$class'" : "'$thing_name' isn't defined"; } elsif( $whatami eq 'object' ) { my $my_class = ref $thing; $thing_name = qq[An object of class '$my_class']; $name = "$thing_name isa '$class'"; $diag = "The object of class '$my_class' isn't a '$class'"; } elsif( $whatami eq 'reference' ) { my $type = ref $thing; $thing_name = qq[A reference of type '$type']; $name = "$thing_name isa '$class'"; $diag = "The reference of type '$type' isn't a '$class'"; } elsif( $whatami eq 'undef' ) { $thing_name = 'undef'; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't defined"; } elsif( $whatami eq 'class' ) { $thing_name = qq[The class (or class-like) '$thing']; $name = "$thing_name isa '$class'"; $diag = "$thing_name isn't a '$class'"; } else { die; } my $ok; if($rslt) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag(" $diag\n"); } return $ok; } =item B<new_ok> my $obj = new_ok( $class ); my $obj = new_ok( $class => \@args ); my $obj = new_ok( $class => \@args, $object_name ); A convenience function which combines creating an object and calling C<isa_ok()> on that object. It is basically equivalent to: my $obj = $class->new(@args); isa_ok $obj, $class, $object_name; If @args is not given, an empty list will be used. This function only works on C<new()> and it assumes C<new()> will return just a single object which isa C<$class>. =cut sub new_ok { my $tb = Test::More->builder; $tb->croak("new_ok() must be given at least a class") unless @_; my( $class, $args, $object_name ) = @_; $args ||= []; my $obj; my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } ); if($success) { local $Test::Builder::Level = $Test::Builder::Level + 1; isa_ok $obj, $class, $object_name; } else { $class = 'undef' if !defined $class; $tb->ok( 0, "$class->new() died" ); $tb->diag(" Error was: $error"); } return $obj; } =item B<subtest> subtest $name => \&code, @args; C<subtest()> runs the &code as its own little test with its own plan and its own result. The main test counts this as a single test using the result of the whole subtest to determine if its ok or not ok. For example... use Test::More tests => 3; pass("First test"); subtest 'An example subtest' => sub { plan tests => 2; pass("This is a subtest"); pass("So is this"); }; pass("Third test"); This would produce. 1..3 ok 1 - First test # Subtest: An example subtest 1..2 ok 1 - This is a subtest ok 2 - So is this ok 2 - An example subtest ok 3 - Third test A subtest may call C<skip_all>. No tests will be run, but the subtest is considered a skip. subtest 'skippy' => sub { plan skip_all => 'cuz I said so'; pass('this test will never be run'); }; Returns true if the subtest passed, false otherwise. Due to how subtests work, you may omit a plan if you desire. This adds an implicit C<done_testing()> to the end of your subtest. The following two subtests are equivalent: subtest 'subtest with implicit done_testing()', sub { ok 1, 'subtests with an implicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; }; subtest 'subtest with explicit done_testing()', sub { ok 1, 'subtests with an explicit done testing should work'; ok 1, '... and support more than one test'; ok 1, '... no matter how many tests are run'; done_testing(); }; Extra arguments given to C<subtest> are passed to the callback. For example: sub my_subtest { my $range = shift; ... } for my $range (1, 10, 100, 1000) { subtest "testing range $range", \&my_subtest, $range; } =cut sub subtest { my $tb = Test::More->builder; return $tb->subtest(@_); } =item B<pass> =item B<fail> pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an C<ok()>. In this case, you can simply use C<pass()> (to declare the test ok) or fail (for not ok). They are synonyms for C<ok(1)> and C<ok(0)>. Use these very, very, very sparingly. =cut sub pass (;$) { my $tb = Test::More->builder; return $tb->ok( 1, @_ ); } sub fail (;$) { my $tb = Test::More->builder; return $tb->ok( 0, @_ ); } =back =head2 Module tests Sometimes you want to test if a module, or a list of modules, can successfully load. For example, you'll often want a first test which simply loads all the modules in the distribution to make sure they work before going on to do more complicated testing. For such purposes we have C<use_ok> and C<require_ok>. =over 4 =item B<require_ok> require_ok($module); require_ok($file); Tries to C<require> the given $module or $file. If it loads successfully, the test will pass. Otherwise it fails and displays the load error. C<require_ok> will guess whether the input is a module name or a filename. No exception will be thrown if the load fails. # require Some::Module require_ok "Some::Module"; # require "Some/File.pl"; require_ok "Some/File.pl"; # stop testing if any of your modules will not load for my $module (@module) { require_ok $module or BAIL_OUT "Can't load $module"; } =cut sub require_ok ($) { my($module) = shift; my $tb = Test::More->builder; my $pack = caller; # Try to determine if we've been given a module name or file. # Module names must be barewords, files not. $module = qq['$module'] unless _is_module_name($module); my $code = <<REQUIRE; package $pack; require $module; 1; REQUIRE my( $eval_result, $eval_error ) = _eval($code); my $ok = $tb->ok( $eval_result, "require $module;" ); unless($ok) { chomp $eval_error; $tb->diag(<<DIAGNOSTIC); Tried to require '$module'. Error: $eval_error DIAGNOSTIC } return $ok; } sub _is_module_name { my $module = shift; # Module names start with a letter. # End with an alphanumeric. # The rest is an alphanumeric or :: $module =~ s/\b::\b//g; return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0; } =item B<use_ok> BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } Like C<require_ok>, but it will C<use> the $module in question and only loads modules, not files. If you just want to test a module can be loaded, use C<require_ok>. If you just want to load a module in a test, we recommend simply using C<use> directly. It will cause the test to stop. It's recommended that you run C<use_ok()> inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); Version numbers can be checked like so: # Just like "use Some::Module 1.02" BEGIN { use_ok('Some::Module', 1.02) } Don't try to do this: BEGIN { use_ok('Some::Module'); ...some code that depends on the use... ...happening at compile time... } because the notion of "compile-time" is relative. Instead, you want: BEGIN { use_ok('Some::Module') } BEGIN { ...some code that depends on the use... } If you want the equivalent of C<use Foo ()>, use a module but not import anything, use C<require_ok>. BEGIN { require_ok "Foo" } =cut sub use_ok ($;@) { my( $module, @imports ) = @_; @imports = () unless @imports; my $tb = Test::More->builder; my %caller; @caller{qw/pack file line sub args want eval req strict warn/} = caller(0); my ($pack, $filename, $line, $warn) = @caller{qw/pack file line warn/}; $filename =~ y/\n\r/_/; # so it doesn't run off the "#line $line $f" line my $code; if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { # probably a version check. Perl needs to see the bare number # for it to work with non-Exporter based modules. $code = <<USE; package $pack; BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } #line $line $filename use $module $imports[0]; 1; USE } else { $code = <<USE; package $pack; BEGIN { \${^WARNING_BITS} = \$args[-1] if defined \$args[-1] } #line $line $filename use $module \@{\$args[0]}; 1; USE } my ($eval_result, $eval_error) = _eval($code, \@imports, $warn); my $ok = $tb->ok( $eval_result, "use $module;" ); unless($ok) { chomp $eval_error; $@ =~ s{^BEGIN failed--compilation aborted at .*$} {BEGIN failed--compilation aborted at $filename line $line.}m; $tb->diag(<<DIAGNOSTIC); Tried to use '$module'. Error: $eval_error DIAGNOSTIC } return $ok; } sub _eval { my( $code, @args ) = @_; # Work around oddities surrounding resetting of $@ by immediately # storing it. my( $sigdie, $eval_result, $eval_error ); { local( $@, $!, $SIG{__DIE__} ); # isolate eval $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval) $eval_error = $@; $sigdie = $SIG{__DIE__} || undef; } # make sure that $code got a chance to set $SIG{__DIE__} $SIG{__DIE__} = $sigdie if defined $sigdie; return( $eval_result, $eval_error ); } =back =head2 Complex data structures Not everything is a simple eq check or regex. There are times you need to see if two data structures are equivalent. For these instances Test::More provides a handful of useful functions. B<NOTE> I'm not quite sure what will happen with filehandles. =over 4 =item B<is_deeply> is_deeply( $got, $expected, $test_name ); Similar to C<is()>, except that if $got and $expected are references, it does a deep comparison walking each data structure to see if they are equivalent. If the two structures are different, it will display the place where they start differing. C<is_deeply()> compares the dereferenced values of references, the references themselves (except for their type) are ignored. This means aspects such as blessing and ties are not considered "different". C<is_deeply()> currently has very limited handling of function reference and globs. It merely checks if they have the same referent. This may improve in the future. L<Test::Differences> and L<Test::Deep> provide more in-depth functionality along these lines. B<NOTE> is_deeply() has limitations when it comes to comparing strings and refs: my $path = path('.'); my $hash = {}; is_deeply( $path, "$path" ); # ok is_deeply( $hash, "$hash" ); # fail This happens because is_deeply will unoverload all arguments unconditionally. It is probably best not to use is_deeply with overloading. For legacy reasons this is not likely to ever be fixed. If you would like a much better tool for this you should see L<Test2::Suite> Specifically L<Test2::Tools::Compare> has an C<is()> function that works like C<is_deeply> with many improvements. =cut our( @Data_Stack, %Refs_Seen ); my $DNE = bless [], 'Does::Not::Exist'; sub _dne { return ref $_[0] eq ref $DNE; } ## no critic (Subroutines::RequireArgUnpacking) sub is_deeply { my $tb = Test::More->builder; unless( @_ == 2 or @_ == 3 ) { my $msg = <<'WARNING'; is_deeply() takes two or three args, you gave %d. This usually means you passed an array or hash instead of a reference to it WARNING chop $msg; # clip off newline so carp() will put in line/file _carp sprintf $msg, scalar @_; return $tb->ok(0); } my( $got, $expected, $name ) = @_; $tb->_unoverload_str( \$expected, \$got ); my $ok; if( !ref $got and !ref $expected ) { # neither is a reference $ok = $tb->is_eq( $got, $expected, $name ); } elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); } else { # both references local @Data_Stack = (); if( _deep_check( $got, $expected ) ) { $ok = $tb->ok( 1, $name ); } else { $ok = $tb->ok( 0, $name ); $tb->diag( _format_stack(@Data_Stack) ); } } return $ok; } sub _format_stack { my(@Stack) = @_; my $var = '$FOO'; my $did_arrow = 0; foreach my $entry (@Stack) { my $type = $entry->{type} || ''; my $idx = $entry->{'idx'}; if( $type eq 'HASH' ) { $var .= "->" unless $did_arrow++; $var .= "{$idx}"; } elsif( $type eq 'ARRAY' ) { $var .= "->" unless $did_arrow++; $var .= "[$idx]"; } elsif( $type eq 'REF' ) { $var = "\${$var}"; } } my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ]; my @vars = (); ( $vars[0] = $var ) =~ s/\$FOO/ \$got/; ( $vars[1] = $var ) =~ s/\$FOO/\$expected/; my $out = "Structures begin differing at:\n"; foreach my $idx ( 0 .. $#vals ) { my $val = $vals[$idx]; $vals[$idx] = !defined $val ? 'undef' : _dne($val) ? "Does not exist" : ref $val ? "$val" : "'$val'"; } $out .= "$vars[0] = $vals[0]\n"; $out .= "$vars[1] = $vals[1]\n"; $out =~ s/^/ /msg; return $out; } sub _type { my $thing = shift; return '' if !ref $thing; for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING)) { return $type if UNIVERSAL::isa( $thing, $type ); } return ''; } =back =head2 Diagnostics If you pick the right test function, you'll usually get a good idea of what went wrong when it failed. But sometimes it doesn't work out that way. So here we have ways for you to write your own diagnostic messages which are safer than just C<print STDERR>. =over 4 =item B<diag> diag(@diagnostic_message); Prints a diagnostic message which is guaranteed not to interfere with test output. Like C<print> @diagnostic_message is simply concatenated together. Returns false, so as to preserve failure. Handy for this sort of thing: ok( grep(/foo/, @users), "There's a foo user" ) or diag("Since there's no foo, check that /etc/bar is set up right"); which would produce: not ok 42 - There's a foo user # Failed test 'There's a foo user' # in foo.t at line 52. # Since there's no foo, check that /etc/bar is set up right. You might remember C<ok() or diag()> with the mnemonic C<open() or die()>. B<NOTE> The exact formatting of the diagnostic output is still changing, but it is guaranteed that whatever you throw at it won't interfere with the test. =item B<note> note(@diagnostic_message); Like C<diag()>, except the message will not be seen when the test is run in a harness. It will only be visible in the verbose TAP stream. Handy for putting in notes which might be useful for debugging, but don't indicate a problem. note("Tempfile is $tempfile"); =cut sub diag { return Test::More->builder->diag(@_); } sub note { return Test::More->builder->note(@_); } =item B<explain> my @dump = explain @diagnostic_message; Will dump the contents of any references in a human readable format. Usually you want to pass this into C<note> or C<diag>. Handy for things like... is_deeply($have, $want) || diag explain $have; or note explain \%args; Some::Class->method(%args); =cut sub explain { return Test::More->builder->explain(@_); } =back =head2 Conditional tests Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented (such as C<fork()> on MacOS), some resource isn't available (like a net connection) or a module isn't available. In these cases it's necessary to skip tests, or declare that they are supposed to fail but will work in the future (a todo test). For more details on the mechanics of skip and todo tests see L<Test::Harness>. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B<SKIP: BLOCK> SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests that might be skipped, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { eval { require HTML::Lint }; skip "HTML::Lint not installed", 2 if $@; my $lint = new HTML::Lint; isa_ok( $lint, "HTML::Lint" ); $lint->parse( $html ); is( $lint->errors, 0, "No errors found in HTML" ); } If the user does not have HTML::Lint installed, the whole block of code I<won't be run at all>. Test::More will output special ok's which Test::Harness interprets as skipped, but passing, tests. It's important that $how_many accurately reflects the number of tests in the SKIP block so the # of tests run will match up with your plan. If your plan is C<no_plan> $how_many is optional and will default to 1. It's perfectly safe to nest SKIP blocks. Each SKIP block must have the label C<SKIP>, or Test::More can't work its magic. You don't skip tests which are failing because there's a bug in your program, or for which you don't yet have code written. For that you use TODO. Read on. =cut ## no critic (Subroutines::RequireFinalReturn) sub skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; # If the plan is set, and is static, then skip needs a count. If the plan # is 'no_plan' we are fine. As well if plan is undefined then we are # waiting for done_testing. unless (defined $how_many) { my $plan = $tb->has_plan; _carp "skip() needs to know \$how_many tests are in the block" if $plan && $plan =~ m/^\d+$/; $how_many = 1; } if( defined $how_many and $how_many =~ /\D/ ) { _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; $how_many = 1; } for( 1 .. $how_many ) { $tb->skip($why); } no warnings 'exiting'; last SKIP; } =item B<TODO: BLOCK> TODO: { local $TODO = $why if $condition; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". L<Test::Harness> will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a block of tests, is that it is like having a programmatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. Note that, if you leave $TODO unset or undef, Test::More reports failures as normal. This can be useful to mark the tests as expected to fail only in certain conditions, e.g.: TODO: { local $TODO = "$^O doesn't work yet. :(" if !_os_is_supported($^O); ... } =item B<todo_skip> TODO: { todo_skip $why, $how_many if $condition; ...normal testing code... } With todo tests, it's best to have the tests actually run. That way you'll know when they start passing. Sometimes this isn't possible. Often a failing test will cause the whole program to die or hang, even inside an C<eval BLOCK> with and using C<alarm>. In these extreme cases you have no choice but to skip over the broken tests entirely. The syntax and behavior is similar to a C<SKIP: BLOCK> except the tests will be marked as failing but todo. L<Test::Harness> will interpret them as passing. =cut sub todo_skip { my( $why, $how_many ) = @_; my $tb = Test::More->builder; unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. _carp "todo_skip() needs to know \$how_many tests are in the block" unless $tb->has_plan eq 'no_plan'; $how_many = 1; } for( 1 .. $how_many ) { $tb->todo_skip($why); } no warnings 'exiting'; last TODO; } =item When do I use SKIP vs. TODO? B<If it's something the user might not be able to do>, use SKIP. This includes optional modules that aren't installed, running under an OS that doesn't have some feature (like C<fork()> or symlinks), or maybe you need an Internet connection and one isn't available. B<If it's something the programmer hasn't done yet>, use TODO. This is for any code you haven't written yet, or bugs you have yet to fix, but want to put tests in your testing script (always a good idea). =back =head2 Test control =over 4 =item B<BAIL_OUT> BAIL_OUT($reason); Indicates to the harness that things are going so badly all testing should terminate. This includes the running of any additional test scripts. This is typically used when testing cannot continue such as a critical module failing to compile or a necessary external utility not being available such as a database connection failing. The test will exit with 255. For even better control look at L<Test::Most>. =cut sub BAIL_OUT { my $reason = shift; my $tb = Test::More->builder; $tb->BAIL_OUT($reason); } =back =head2 Discouraged comparison functions The use of the following functions is discouraged as they are not actually testing functions and produce no diagnostics to help figure out what went wrong. They were written before C<is_deeply()> existed because I couldn't figure out how to display a useful diff of two arbitrary data structures. These functions are usually used inside an C<ok()>. ok( eq_array(\@got, \@expected) ); C<is_deeply()> can do that better and with diagnostics. is_deeply( \@got, \@expected ); They may be deprecated in future versions. =over 4 =item B<eq_array> my $is_eq = eq_array(\@got, \@expected); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { local @Data_Stack = (); _deep_check(@_); } sub _eq_array { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'ARRAY', $a1, $a2 ) { warn "eq_array passed a non-array ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; for( 0 .. $max ) { my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } sub _equal_nonrefs { my( $e1, $e2 ) = @_; return if ref $e1 or ref $e2; if ( defined $e1 ) { return 1 if defined $e2 and $e1 eq $e2; } else { return 1 if !defined $e2; } return; } sub _deep_check { my( $e1, $e2 ) = @_; my $tb = Test::More->builder; my $ok = 0; # Effectively turn %Refs_Seen into a stack. This avoids picking up # the same referenced used twice (such as [\$a, \$a]) to be considered # circular. local %Refs_Seen = %Refs_Seen; { $tb->_unoverload_str( \$e1, \$e2 ); # Either they're both references or both not. my $same_ref = !( !ref $e1 xor !ref $e2 ); my $not_ref = ( !ref $e1 and !ref $e2 ); if( defined $e1 xor defined $e2 ) { $ok = 0; } elsif( !defined $e1 and !defined $e2 ) { # Shortcut if they're both undefined. $ok = 1; } elsif( _dne($e1) xor _dne($e2) ) { $ok = 0; } elsif( $same_ref and( $e1 eq $e2 ) ) { $ok = 1; } elsif($not_ref) { push @Data_Stack, { type => '', vals => [ $e1, $e2 ] }; $ok = 0; } else { if( $Refs_Seen{$e1} ) { return $Refs_Seen{$e1} eq $e2; } else { $Refs_Seen{$e1} = "$e2"; } my $type = _type($e1); $type = 'DIFFERENT' unless _type($e2) eq $type; if( $type eq 'DIFFERENT' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } elsif( $type eq 'ARRAY' ) { $ok = _eq_array( $e1, $e2 ); } elsif( $type eq 'HASH' ) { $ok = _eq_hash( $e1, $e2 ); } elsif( $type eq 'REF' ) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif( $type eq 'SCALAR' ) { push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] }; $ok = _deep_check( $$e1, $$e2 ); pop @Data_Stack if $ok; } elsif($type) { push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] }; $ok = 0; } else { _whoa( 1, "No type in _deep_check" ); } } } return $ok; } sub _whoa { my( $check, $desc ) = @_; if($check) { die <<"WHOA"; WHOA! $desc This should never happen! Please contact the author immediately! WHOA } } =item B<eq_hash> my $is_eq = eq_hash(\%got, \%expected); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { local @Data_Stack = (); return _deep_check(@_); } sub _eq_hash { my( $a1, $a2 ) = @_; if( grep _type($_) ne 'HASH', $a1, $a2 ) { warn "eq_hash passed a non-hash ref"; return 0; } return 1 if $a1 eq $a2; my $ok = 1; my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; foreach my $k ( keys %$bigger ) { my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; next if _equal_nonrefs($e1, $e2); push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] }; $ok = _deep_check( $e1, $e2 ); pop @Data_Stack if $ok; last unless $ok; } return $ok; } =item B<eq_set> my $is_eq = eq_set(\@got, \@expected); Similar to C<eq_array()>, except the order of the elements is B<not> important. This is a deep check, but the irrelevancy of order only applies to the top level. ok( eq_set(\@got, \@expected) ); Is better written: is_deeply( [sort @got], [sort @expected] ); B<NOTE> By historical accident, this is not a true set comparison. While the order of elements does not matter, duplicate elements do. B<NOTE> C<eq_set()> does not know how to deal with references at the top level. The following is an example of a comparison which might not work: eq_set([\1, \2], [\2, \1]); L<Test::Deep> contains much better set comparison functions. =cut sub eq_set { my( $a1, $a2 ) = @_; return 0 unless @$a1 == @$a2; no warnings 'uninitialized'; # It really doesn't matter how we sort them, as long as both arrays are # sorted with the same algorithm. # # Ensure that references are not accidentally treated the same as a # string containing the reference. # # Have to inline the sort routine due to a threading/sort bug. # See [rt.cpan.org 6782] # # I don't know how references would be sorted so we just don't sort # them. This means eq_set doesn't really work with refs. return eq_array( [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ], [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ], ); } =back =head2 Extending and Embedding Test::More Sometimes the Test::More interface isn't quite enough. Fortunately, Test::More is built on top of L<Test::Builder> which provides a single, unified backend for any test library to use. This means two test libraries which both use <Test::Builder> B<can> be used together in the same program>. If you simply want to do a little tweaking of how the tests behave, you can access the underlying L<Test::Builder> object like so: =over 4 =item B<builder> my $test_builder = Test::More->builder; Returns the L<Test::Builder> object underlying Test::More for you to play with. =back =head1 EXIT CODES If all your tests passed, L<Test::Builder> will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run L<Test::Builder> will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. B<NOTE> This behavior may go away in future versions. =head1 COMPATIBILITY Test::More works with Perls as old as 5.8.1. Thread support is not very reliable before 5.10.1, but that's because threads are not very reliable before 5.10.1. Although Test::More has been a core module in versions of Perl since 5.6.2, Test::More has evolved since then, and not all of the features you're used to will be present in the shipped version of Test::More. If you are writing a module, don't forget to indicate in your package metadata the minimum version of Test::More that you require. For instance, if you want to use C<done_testing()> but want your test script to run on Perl 5.10.0, you will need to explicitly require Test::More > 0.88. Key feature milestones include: =over 4 =item subtests Subtests were released in Test::More 0.94, which came with Perl 5.12.0. Subtests did not implicitly call C<done_testing()> until 0.96; the first Perl with that fix was Perl 5.14.0 with 0.98. =item C<done_testing()> This was released in Test::More 0.88 and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C<cmp_ok()> Although C<cmp_ok()> was introduced in 0.40, 0.86 fixed an important bug to make it safe for overloaded objects; the fixed first shipped with Perl in 5.10.1 as part of Test::More 0.92. =item C<new_ok()> C<note()> and C<explain()> These were was released in Test::More 0.82, and first shipped with Perl in 5.10.1 as part of Test::More 0.92. =back There is a full version history in the Changes file, and the Test::More versions included as core can be found using L<Module::CoreList>: $ corelist -a Test::More =head1 CAVEATS and NOTES =over 4 =item utf8 / "Wide character in print" If you use utf8 or other non-ASCII characters with Test::More you might get a "Wide character in print" warning. Using C<< binmode STDOUT, ":utf8" >> will not fix it. L<Test::Builder> (which powers Test::More) duplicates STDOUT and STDERR. So any changes to them, including changing their output disciplines, will not be seen by Test::More. One work around is to apply encodings to STDOUT and STDERR as early as possible and before Test::More (or any other Test module) loads. use open ':std', ':encoding(utf8)'; use Test::More; A more direct work around is to change the filehandles used by L<Test::Builder>. my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; binmode $builder->todo_output, ":encoding(utf8)"; =item Overloaded objects String overloaded objects are compared B<as strings> (or in C<cmp_ok()>'s case, strings or numbers as appropriate to the comparison op). This prevents Test::More from piercing an object's interface allowing better blackbox testing. So if a function starts returning overloaded objects instead of bare strings your tests won't notice the difference. This is good. However, it does mean that functions like C<is_deeply()> cannot be used to test the internals of string overloaded objects. In this case I would suggest L<Test::Deep> which contains more flexible testing functions for complex data structures. =item Threads Test::More will only be aware of threads if C<use threads> has been done I<before> Test::More is loaded. This is ok: use threads; use Test::More; This may cause problems: use Test::More use threads; 5.8.1 and above are supported. Anything below that has too many bugs. =back =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's L<Test> module. I was largely unaware of its existence when I'd first written my own C<ok()> routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO =head2 =head2 ALTERNATIVES L<Test2::Suite> is the most recent and modern set of tools for testing. L<Test::Simple> if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (it's forward compatible). L<Test::Legacy> tests written with Test.pm, the original testing module, do not play well with other testing libraries. Test::Legacy emulates the Test.pm interface and does play well with others. =head2 ADDITIONAL LIBRARIES L<Test::Differences> for more ways to test complex data structures. And it plays well with Test::More. L<Test::Class> is like xUnit but more perlish. L<Test::Deep> gives you more powerful complex data structure testing. L<Test::Inline> shows the idea of embedded testing. L<Mock::Quick> The ultimate mocking library. Easily spawn objects defined on the fly. Can also override, block, or reimplement packages as needed. L<Test::FixtureBuilder> Quickly define fixture data for unit tests. =head2 OTHER COMPONENTS L<Test::Harness> is the test runner and output interpreter for Perl. It's the thing that powers C<make test> and where the C<prove> utility comes from. =head2 BUNDLES L<Test::Most> Most commonly needed test functions and features. =head1 AUTHORS Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration from Joshua Pritikin's Test module and lots of help from Barrie Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa gang. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 BUGS See F<https://github.com/Test-More/test-more/issues> to report and view bugs. =head1 SOURCE The source code repository for Test::More can be found at F<http://github.com/Test-More/test-more/>. =head1 COPYRIGHT Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> =cut 1; perl5/Test/Tutorial.pod 0000444 00000045622 14711217633 0011035 0 ustar 00 =head1 NAME Test::Tutorial - A tutorial about writing really basic tests =head1 DESCRIPTION I<AHHHHHHH!!!! NOT TESTING! Anything but testing! Beat me, whip me, send me to Detroit, but don't make me write tests!> I<*sob*> I<Besides, I don't know how to write the damned things.> Is this you? Is writing tests right up there with writing documentation and having your fingernails pulled out? Did you open up a test and read ######## We start with some black magic and decide that's quite enough for you? It's ok. That's all gone now. We've done all the black magic for you. And here are the tricks... =head2 Nuts and bolts of testing. Here's the most basic test program. #!/usr/bin/perl -w print "1..1\n"; print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n"; Because 1 + 1 is 2, it prints: 1..1 ok 1 What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1> "The first test passed". And that's about all magic there is to testing. Your basic unit of testing is the I<ok>. For each thing you test, an C<ok> is printed. Simple. L<Test::Harness> interprets your test results to determine if you succeeded or failed (more on that later). Writing all these print statements rapidly gets tedious. Fortunately, there's L<Test::Simple>. It has one function, C<ok()>. #!/usr/bin/perl -w use Test::Simple tests => 1; ok( 1 + 1 == 2 ); That does the same thing as the previous code. C<ok()> is the backbone of Perl testing, and we'll be using it instead of roll-your-own from here on. If C<ok()> gets a true value, the test passes. False, it fails. #!/usr/bin/perl -w use Test::Simple tests => 2; ok( 1 + 1 == 2 ); ok( 2 + 2 == 5 ); From that comes: 1..2 ok 1 not ok 2 # Failed test (test.pl at line 5) # Looks like you failed 1 tests of 2. C<1..2> "I'm going to run two tests." This number is a I<plan>. It helps to ensure your test program ran all the way through and didn't die or skip some tests. C<ok 1> "The first test passed." C<not ok 2> "The second test failed". Test::Simple helpfully prints out some extra commentary about your tests. It's not scary. Come, hold my hand. We're going to give an example of testing a module. For our example, we'll be testing a date library, L<Date::ICal>. It's on CPAN, so download a copy and follow along. [2] =head2 Where to start? This is the hardest part of testing, where do you start? People often get overwhelmed at the apparent enormity of the task of testing a whole module. The best place to start is at the beginning. L<Date::ICal> is an object-oriented module, and that means you start by making an object. Test C<new()>. #!/usr/bin/perl -w # assume these two lines are in all subsequent examples use strict; use warnings; use Test::Simple tests => 2; use Date::ICal; my $ical = Date::ICal->new; # create an object ok( defined $ical ); # check that we got something ok( $ical->isa('Date::ICal') ); # and it's the right class Run that and you should get: 1..2 ok 1 ok 2 Congratulations! You've written your first useful test. =head2 Names That output isn't terribly descriptive, is it? When you have two tests you can figure out which one is #2, but what if you have 102 tests? Each test can be given a little descriptive name as the second argument to C<ok()>. use Test::Simple tests => 2; ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); Now you'll see: 1..2 ok 1 - new() returned something ok 2 - and it's the right class =head2 Test the manual The simplest way to build up a decent testing suite is to just test what the manual says it does. [3] Let's pull something out of the L<Date::ICal/SYNOPSIS> and test that all its bits work. #!/usr/bin/perl -w use Test::Simple tests => 8; use Date::ICal; $ical = Date::ICal->new( year => 1964, month => 10, day => 16, hour => 16, min => 12, sec => 47, tz => '0530' ); ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); ok( $ical->sec == 47, ' sec()' ); ok( $ical->min == 12, ' min()' ); ok( $ical->hour == 16, ' hour()' ); ok( $ical->day == 17, ' day()' ); ok( $ical->month == 10, ' month()' ); ok( $ical->year == 1964, ' year()' ); Run that and you get: 1..8 ok 1 - new() returned something ok 2 - and it's the right class ok 3 - sec() ok 4 - min() ok 5 - hour() not ok 6 - day() # Failed test (- at line 16) ok 7 - month() ok 8 - year() # Looks like you failed 1 tests of 8. Whoops, a failure! [4] L<Test::Simple> helpfully lets us know on what line the failure occurred, but not much else. We were supposed to get 17, but we didn't. What did we get?? Dunno. You could re-run the test in the debugger or throw in some print statements to find out. Instead, switch from L<Test::Simple> to L<Test::More>. L<Test::More> does everything L<Test::Simple> does, and more! In fact, L<Test::More> does things I<exactly> the way L<Test::Simple> does. You can literally swap L<Test::Simple> out and put L<Test::More> in its place. That's just what we're going to do. L<Test::More> does more than L<Test::Simple>. The most important difference at this point is it provides more informative ways to say "ok". Although you can write almost any test with a generic C<ok()>, it can't tell you what went wrong. The C<is()> function lets us declare that something is supposed to be the same as something else: use Test::More tests => 8; use Date::ICal; $ical = Date::ICal->new( year => 1964, month => 10, day => 16, hour => 16, min => 12, sec => 47, tz => '0530' ); ok( defined $ical, 'new() returned something' ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); is( $ical->sec, 47, ' sec()' ); is( $ical->min, 12, ' min()' ); is( $ical->hour, 16, ' hour()' ); is( $ical->day, 17, ' day()' ); is( $ical->month, 10, ' month()' ); is( $ical->year, 1964, ' year()' ); "Is C<< $ical->sec >> 47?" "Is C<< $ical->min >> 12?" With C<is()> in place, you get more information: 1..8 ok 1 - new() returned something ok 2 - and it's the right class ok 3 - sec() ok 4 - min() ok 5 - hour() not ok 6 - day() # Failed test (- at line 16) # got: '16' # expected: '17' ok 7 - month() ok 8 - year() # Looks like you failed 1 tests of 8. Aha. C<< $ical->day >> returned 16, but we expected 17. A quick check shows that the code is working fine, we made a mistake when writing the tests. Change it to: is( $ical->day, 16, ' day()' ); ... and everything works. Any time you're doing a "this equals that" sort of test, use C<is()>. It even works on arrays. The test is always in scalar context, so you can test how many elements are in an array this way. [5] is( @foo, 5, 'foo has 5 elements' ); =head2 Sometimes the tests are wrong This brings up a very important lesson. Code has bugs. Tests are code. Ergo, tests have bugs. A failing test could mean a bug in the code, but don't discount the possibility that the test is wrong. On the flip side, don't be tempted to prematurely declare a test incorrect just because you're having trouble finding the bug. Invalidating a test isn't something to be taken lightly, and don't use it as a cop out to avoid work. =head2 Testing lots of values We're going to be wanting to test a lot of dates here, trying to trick the code with lots of different edge cases. Does it work before 1970? After 2038? Before 1904? Do years after 10,000 give it trouble? Does it get leap years right? We could keep repeating the code above, or we could set up a little try/expect loop. use Test::More tests => 32; use Date::ICal; my %ICal_Dates = ( # An ICal string And the year, month, day # hour, minute and second we expect. '19971024T120000' => # from the docs. [ 1997, 10, 24, 12, 0, 0 ], '20390123T232832' => # after the Unix epoch [ 2039, 1, 23, 23, 28, 32 ], '19671225T000000' => # before the Unix epoch [ 1967, 12, 25, 0, 0, 0 ], '18990505T232323' => # before the MacOS epoch [ 1899, 5, 5, 23, 23, 23 ], ); while( my($ical_str, $expect) = each %ICal_Dates ) { my $ical = Date::ICal->new( ical => $ical_str ); ok( defined $ical, "new(ical => '$ical_str')" ); ok( $ical->isa('Date::ICal'), " and it's the right class" ); is( $ical->year, $expect->[0], ' year()' ); is( $ical->month, $expect->[1], ' month()' ); is( $ical->day, $expect->[2], ' day()' ); is( $ical->hour, $expect->[3], ' hour()' ); is( $ical->min, $expect->[4], ' min()' ); is( $ical->sec, $expect->[5], ' sec()' ); } Now we can test bunches of dates by just adding them to C<%ICal_Dates>. Now that it's less work to test with more dates, you'll be inclined to just throw more in as you think of them. Only problem is, every time we add to that we have to keep adjusting the C<< use Test::More tests => ## >> line. That can rapidly get annoying. There are ways to make this work better. First, we can calculate the plan dynamically using the C<plan()> function. use Test::More; use Date::ICal; my %ICal_Dates = ( ...same as before... ); # For each key in the hash we're running 8 tests. plan tests => keys(%ICal_Dates) * 8; ...and then your tests... To be even more flexible, use C<done_testing>. This means we're just running some tests, don't know how many. [6] use Test::More; # instead of tests => 32 ... # tests here done_testing(); # reached the end safely If you don't specify a plan, L<Test::More> expects to see C<done_testing()> before your program exits. It will warn you if you forget it. You can give C<done_testing()> an optional number of tests you expected to run, and if the number ran differs, L<Test::More> will give you another kind of warning. =head2 Informative names Take a look at the line: ok( defined $ical, "new(ical => '$ical_str')" ); We've added more detail about what we're testing and the ICal string itself we're trying out to the name. So you get results like: ok 25 - new(ical => '19971024T120000') ok 26 - and it's the right class ok 27 - year() ok 28 - month() ok 29 - day() ok 30 - hour() ok 31 - min() ok 32 - sec() If something in there fails, you'll know which one it was and that will make tracking down the problem easier. Try to put a bit of debugging information into the test names. Describe what the tests test, to make debugging a failed test easier for you or for the next person who runs your test. =head2 Skipping tests Poking around in the existing L<Date::ICal> tests, I found this in F<t/01sanity.t> [7] #!/usr/bin/perl -w use Test::More tests => 7; use Date::ICal; # Make sure epoch time is being handled sanely. my $t1 = Date::ICal->new( epoch => 0 ); is( $t1->epoch, 0, "Epoch time of 0" ); # XXX This will only work on unix systems. is( $t1->ical, '19700101Z', " epoch to ical" ); is( $t1->year, 1970, " year()" ); is( $t1->month, 1, " month()" ); is( $t1->day, 1, " day()" ); # like the tests above, but starting with ical instead of epoch my $t2 = Date::ICal->new( ical => '19700101Z' ); is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); is( $t2->epoch, 0, " and back to ICal" ); The beginning of the epoch is different on most non-Unix operating systems [8]. Even though Perl smooths out the differences for the most part, certain ports do it differently. MacPerl is one off the top of my head. [9] Rather than putting a comment in the test and hoping someone will read the test while debugging the failure, we can explicitly say it's never going to work and skip the test. use Test::More tests => 7; use Date::ICal; # Make sure epoch time is being handled sanely. my $t1 = Date::ICal->new( epoch => 0 ); is( $t1->epoch, 0, "Epoch time of 0" ); SKIP: { skip('epoch to ICal not working on Mac OS', 6) if $^O eq 'MacOS'; is( $t1->ical, '19700101Z', " epoch to ical" ); is( $t1->year, 1970, " year()" ); is( $t1->month, 1, " month()" ); is( $t1->day, 1, " day()" ); # like the tests above, but starting with ical instead of epoch my $t2 = Date::ICal->new( ical => '19700101Z' ); is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" ); is( $t2->epoch, 0, " and back to ICal" ); } A little bit of magic happens here. When running on anything but MacOS, all the tests run normally. But when on MacOS, C<skip()> causes the entire contents of the SKIP block to be jumped over. It never runs. Instead, C<skip()> prints special output that tells L<Test::Harness> that the tests have been skipped. 1..7 ok 1 - Epoch time of 0 ok 2 # skip epoch to ICal not working on MacOS ok 3 # skip epoch to ICal not working on MacOS ok 4 # skip epoch to ICal not working on MacOS ok 5 # skip epoch to ICal not working on MacOS ok 6 # skip epoch to ICal not working on MacOS ok 7 # skip epoch to ICal not working on MacOS This means your tests won't fail on MacOS. This means fewer emails from MacPerl users telling you about failing tests that you know will never work. You've got to be careful with skip tests. These are for tests which don't work and I<never will>. It is not for skipping genuine bugs (we'll get to that in a moment). The tests are wholly and completely skipped. [10] This will work. SKIP: { skip("I don't wanna die!"); die, die, die, die, die; } =head2 Todo tests While thumbing through the L<Date::ICal> man page, I came across this: ical $ical_string = $ical->ical; Retrieves, or sets, the date on the object, using any valid ICal date/time string. "Retrieves or sets". Hmmm. I didn't see a test for using C<ical()> to set the date in the Date::ICal test suite. So I wrote one: use Test::More tests => 1; use Date::ICal; my $ical = Date::ICal->new; $ical->ical('20201231Z'); is( $ical->ical, '20201231Z', 'Setting via ical()' ); Run that. I saw: 1..1 not ok 1 - Setting via ical() # Failed test (- at line 6) # got: '20010814T233649Z' # expected: '20201231Z' # Looks like you failed 1 tests of 1. Whoops! Looks like it's unimplemented. Assume you don't have the time to fix this. [11] Normally, you'd just comment out the test and put a note in a todo list somewhere. Instead, explicitly state "this test will fail" by wrapping it in a C<TODO> block: use Test::More tests => 1; TODO: { local $TODO = 'ical($ical) not yet implemented'; my $ical = Date::ICal->new; $ical->ical('20201231Z'); is( $ical->ical, '20201231Z', 'Setting via ical()' ); } Now when you run, it's a little different: 1..1 not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented # got: '20010822T201551Z' # expected: '20201231Z' L<Test::More> doesn't say "Looks like you failed 1 tests of 1". That '# TODO' tells L<Test::Harness> "this is supposed to fail" and it treats a failure as a successful test. You can write tests even before you've fixed the underlying code. If a TODO test passes, L<Test::Harness> will report it "UNEXPECTEDLY SUCCEEDED". When that happens, remove the TODO block with C<local $TODO> and turn it into a real test. =head2 Testing with taint mode. Taint mode is a funny thing. It's the globalest of all global features. Once you turn it on, it affects I<all> code in your program and I<all> modules used (and all the modules they use). If a single piece of code isn't taint clean, the whole thing explodes. With that in mind, it's very important to ensure your module works under taint mode. It's very simple to have your tests run under taint mode. Just throw a C<-T> into the C<#!> line. L<Test::Harness> will read the switches in C<#!> and use them to run your tests. #!/usr/bin/perl -Tw ...test normally here... When you say C<make test> it will run with taint mode on. =head1 FOOTNOTES =over 4 =item 1 The first number doesn't really mean anything, but it has to be 1. It's the second number that's important. =item 2 For those following along at home, I'm using version 1.31. It has some bugs, which is good -- we'll uncover them with our tests. =item 3 You can actually take this one step further and test the manual itself. Have a look at L<Test::Inline> (formerly L<Pod::Tests>). =item 4 Yes, there's a mistake in the test suite. What! Me, contrived? =item 5 We'll get to testing the contents of lists later. =item 6 But what happens if your test program dies halfway through?! Since we didn't say how many tests we're going to run, how can we know it failed? No problem, L<Test::More> employs some magic to catch that death and turn the test into a failure, even if every test passed up to that point. =item 7 I cleaned it up a little. =item 8 Most Operating Systems record time as the number of seconds since a certain date. This date is the beginning of the epoch. Unix's starts at midnight January 1st, 1970 GMT. =item 9 MacOS's epoch is midnight January 1st, 1904. VMS's is midnight, November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a problem. =item 10 As long as the code inside the SKIP block at least compiles. Please don't ask how. No, it's not a filter. =item 11 Do NOT be tempted to use TODO tests as a way to avoid fixing simple bugs! =back =head1 AUTHORS Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers! =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. This documentation is free; you can redistribute it and/or modify it under the same terms as Perl itself. Irrespective of its distribution, all code examples in these files are hereby placed into the public domain. You are permitted and encouraged to use this code in your own programs for fun or for profit as you see fit. A simple comment in the code giving credit would be courteous but is not required. =cut perl5/Test/Builder/Tester/Color.pm 0000444 00000001715 14711217636 0012774 0 ustar 00 package Test::Builder::Tester::Color; use strict; our $VERSION = '1.302186'; require Test::Builder::Tester; =head1 NAME Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester =head1 SYNOPSIS When running a test script perl -MTest::Builder::Tester::Color test.t =head1 DESCRIPTION Importing this module causes the subroutine color in Test::Builder::Tester to be called with a true value causing colour highlighting to be turned on in debug output. The sole purpose of this module is to enable colour highlighting from the command line. =cut sub import { Test::Builder::Tester::color(1); } =head1 AUTHOR Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 BUGS This module will have no effect unless Term::ANSIColor is installed. =head1 SEE ALSO L<Test::Builder::Tester>, L<Term::ANSIColor> =cut 1; perl5/Test/Builder/Tester.pm 0000444 00000043163 14711217637 0011722 0 ustar 00 package Test::Builder::Tester; use strict; our $VERSION = '1.302186'; use Test::Builder; use Symbol; use Carp; =head1 NAME Test::Builder::Tester - test testsuites that have been built with Test::Builder =head1 SYNOPSIS use Test::Builder::Tester tests => 1; use Test::More; test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); =head1 DESCRIPTION A module that helps you test testing modules that are built with L<Test::Builder>. The testing system is designed to be used by performing a three step process for each test you wish to test. This process starts with using C<test_out> and C<test_err> in advance to declare what the testsuite you are testing will output with L<Test::Builder> to stdout and stderr. You then can run the test(s) from your test suite that call L<Test::Builder>. At this point the output of L<Test::Builder> is safely captured by L<Test::Builder::Tester> rather than being interpreted as real test output. The final stage is to call C<test_test> that will simply compare what you predeclared to what L<Test::Builder> actually outputted, and report the results back with a "ok" or "not ok" (with debugging) to the normal output. =cut #### # set up testing #### my $t = Test::Builder->new; ### # make us an exporter ### use Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); sub import { my $class = shift; my(@plan) = @_; my $caller = caller; $t->exported_to($caller); $t->plan(@plan); my @imports = (); foreach my $idx ( 0 .. $#plan ) { if( $plan[$idx] eq 'import' ) { @imports = @{ $plan[ $idx + 1 ] }; last; } } __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports ); } ### # set up file handles ### # create some private file handles my $output_handle = gensym; my $error_handle = gensym; # and tie them to this package my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT"; my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR"; #### # exported functions #### # for remembering that we're testing and where we're testing at my $testing = 0; my $testing_num; my $original_is_passing; # remembering where the file handles were originally connected my $original_output_handle; my $original_failure_handle; my $original_todo_handle; my $original_formatter; my $original_harness_env; # function that starts testing and redirects the filehandles for now sub _start_testing { # Hack for things that conditioned on Test-Stream being loaded $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'}; # even if we're running under Test::Harness pretend we're not # for now. This needed so Test::Builder doesn't add extra spaces $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; $ENV{HARNESS_ACTIVE} = 0; my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top); $original_formatter = $hub->format; unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) { my $fmt = Test::Builder::Formatter->new; $hub->format($fmt); } # remember what the handles were set to $original_output_handle = $t->output(); $original_failure_handle = $t->failure_output(); $original_todo_handle = $t->todo_output(); # switch out to our own handles $t->output($output_handle); $t->failure_output($error_handle); $t->todo_output($output_handle); # clear the expected list $out->reset(); $err->reset(); # remember that we're testing $testing = 1; $testing_num = $t->current_test; $t->current_test(0); $original_is_passing = $t->is_passing; $t->is_passing(1); # look, we shouldn't do the ending stuff $t->no_ending(1); } =head2 Functions These are the six methods that are exported as default. =over 4 =item test_out =item test_err Procedures for predeclaring the output that your test suite is expected to produce until C<test_test> is called. These procedures automatically assume that each line terminates with "\n". So test_out("ok 1","ok 2"); is the same as test_out("ok 1\nok 2"); which is even the same as test_out("ok 1"); test_out("ok 2"); Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have been called, all further output from L<Test::Builder> will be captured by L<Test::Builder::Tester>. This means that you will not be able perform further tests to the normal output in the normal way until you call C<test_test> (well, unless you manually meddle with the output filehandles) =cut sub test_out { # do we need to do any setup? _start_testing() unless $testing; $out->expect(@_); } sub test_err { # do we need to do any setup? _start_testing() unless $testing; $err->expect(@_); } =item test_fail Because the standard failure message that L<Test::Builder> produces whenever a test fails will be a common occurrence in your test error output, and because it has changed between Test::Builder versions, rather than forcing you to call C<test_err> with the string all the time like so test_err("# Failed test ($0 at line ".line_num(+1).")"); C<test_fail> exists as a convenience function that can be called instead. It takes one argument, the offset from the current line that the line that causes the fail is on. test_fail(+1); This means that the example in the synopsis could be rewritten more simply as: test_out("not ok 1 - foo"); test_fail(+1); fail("foo"); test_test("fail works"); =cut sub test_fail { # do we need to do any setup? _start_testing() unless $testing; # work out what line we should be on my( $package, $filename, $line ) = caller; $line = $line + ( shift() || 0 ); # prevent warnings # expect that on stderr $err->expect("# Failed test ($filename at line $line)"); } =item test_diag As most of the remaining expected output to the error stream will be created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester> provides a convenience function C<test_diag> that you can use instead of C<test_err>. The C<test_diag> function prepends comment hashes and spacing to the start and newlines to the end of the expected output passed to it and adds it to the list of expected error output. So, instead of writing test_err("# Couldn't open file"); you can write test_diag("Couldn't open file"); Remember that L<Test::Builder>'s diag function will not add newlines to the end of output and test_diag will. So to check Test::Builder->new->diag("foo\n","bar\n"); You would do test_diag("foo","bar") without the newlines. =cut sub test_diag { # do we need to do any setup? _start_testing() unless $testing; # expect the same thing, but prepended with "# " local $_; $err->expect( map { "# $_" } @_ ); } =item test_test Actually performs the output check testing the tests, comparing the data (with C<eq>) that we have captured from L<Test::Builder> against what was declared with C<test_out> and C<test_err>. This takes name/value pairs that effect how the test is run. =over =item title (synonym 'name', 'label') The name of the test that will be displayed after the C<ok> or C<not ok>. =item skip_out Setting this to a true value will cause the test to ignore if the output sent by the test to the output stream does not match that declared with C<test_out>. =item skip_err Setting this to a true value will cause the test to ignore if the output sent by the test to the error stream does not match that declared with C<test_err>. =back As a convenience, if only one argument is passed then this argument is assumed to be the name of the test (as in the above examples.) Once C<test_test> has been run test output will be redirected back to the original filehandles that L<Test::Builder> was connected to (probably STDOUT and STDERR,) meaning any further tests you run will function normally and cause success/errors for L<Test::Harness>. =cut sub test_test { # END the hack delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake'; # decode the arguments as described in the pod my $mess; my %args; if( @_ == 1 ) { $mess = shift } else { %args = @_; $mess = $args{name} if exists( $args{name} ); $mess = $args{title} if exists( $args{title} ); $mess = $args{label} if exists( $args{label} ); } # er, are we testing? croak "Not testing. You must declare output with a test function first." unless $testing; my $hub = $t->{Hub} || Test2::API::test2_stack->top; $hub->format($original_formatter); # okay, reconnect the test suite back to the saved handles $t->output($original_output_handle); $t->failure_output($original_failure_handle); $t->todo_output($original_todo_handle); # restore the test no, etc, back to the original point $t->current_test($testing_num); $testing = 0; $t->is_passing($original_is_passing); # re-enable the original setting of the harness $ENV{HARNESS_ACTIVE} = $original_harness_env; # check the output we've stashed unless( $t->ok( ( $args{skip_out} || $out->check ) && ( $args{skip_err} || $err->check ), $mess ) ) { # print out the diagnostic information about why this # test failed local $_; $t->diag( map { "$_\n" } $out->complaint ) unless $args{skip_out} || $out->check; $t->diag( map { "$_\n" } $err->complaint ) unless $args{skip_err} || $err->check; } } =item line_num A utility function that returns the line number that the function was called on. You can pass it an offset which will be added to the result. This is very useful for working out the correct text of diagnostic functions that contain line numbers. Essentially this is the same as the C<__LINE__> macro, but the C<line_num(+3)> idiom is arguably nicer. =cut sub line_num { my( $package, $filename, $line ) = caller; return $line + ( shift() || 0 ); # prevent warnings } =back In addition to the six exported functions there exists one function that can only be accessed with a fully qualified function call. =over 4 =item color When C<test_test> is called and the output that your tests generate does not match that which you declared, C<test_test> will print out debug information showing the two conflicting versions. As this output itself is debug information it can be confusing which part of the output is from C<test_test> and which was the original output from your original tests. Also, it may be hard to spot things like extraneous whitespace at the end of lines that may cause your test to fail even though the output looks similar. To assist you C<test_test> can colour the background of the debug information to disambiguate the different types of output. The debug output will have its background coloured green and red. The green part represents the text which is the same between the executed and actual output, the red shows which part differs. The C<color> function determines if colouring should occur or not. Passing it a true or false value will enable or disable colouring respectively, and the function called with no argument will return the current setting. To enable colouring from the command line, you can use the L<Text::Builder::Tester::Color> module like so: perl -Mlib=Text::Builder::Tester::Color test.t Or by including the L<Test::Builder::Tester::Color> module directly in the PERL5LIB. =cut my $color; sub color { $color = shift if @_; $color; } =back =head1 BUGS Test::Builder::Tester does not handle plans well. It has never done anything special with plans. This means that plans from outside Test::Builder::Tester will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester will effect overall testing. At this point there are no plans to fix this bug as people have come to depend on it, and Test::Builder::Tester is now discouraged in favor of C<Test2::API::intercept()>. See L<https://github.com/Test-More/test-more/issues/667> Calls C<< Test::Builder->no_ending >> turning off the ending tests. This is needed as otherwise it will trip out because we've run more tests than we strictly should have and it'll register any failures we had that we were testing for as real failures. The color function doesn't work unless L<Term::ANSIColor> is compatible with your terminal. Additionally, L<Win32::Console::ANSI> must be installed on windows platforms for color output. Bugs (and requests for new features) can be reported to the author though GitHub: L<https://github.com/Test-More/test-more/issues> =head1 AUTHOR Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. Some code taken from L<Test::More> and L<Test::Catch>, written by Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts Copyright Micheal G Schwern 2001. Used and distributed with permission. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 NOTES Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting me use his testing system to try this module out on. =head1 SEE ALSO L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>. =cut 1; #################################################################### # Helper class that is used to remember expected and received data package Test::Builder::Tester::Tie; ## # add line(s) to be expected sub expect { my $self = shift; my @checks = @_; foreach my $check (@checks) { $check = $self->_account_for_subtest($check); $check = $self->_translate_Failed_check($check); push @{ $self->{wanted} }, ref $check ? $check : "$check\n"; } } sub _account_for_subtest { my( $self, $check ) = @_; my $hub = $t->{Stack}->top; my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0; return ref($check) ? $check : (' ' x $nesting) . $check; } sub _translate_Failed_check { my( $self, $check ) = @_; if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) { $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/"; } return $check; } ## # return true iff the expected data matches the got data sub check { my $self = shift; # turn off warnings as these might be undef local $^W = 0; my @checks = @{ $self->{wanted} }; my $got = $self->{got}; foreach my $check (@checks) { $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check ); return 0 unless $got =~ s/^$check//; } return length $got == 0; } ## # a complaint message about the inputs not matching (to be # used for debugging messages) sub complaint { my $self = shift; my $type = $self->type; my $got = $self->got; my $wanted = join '', @{ $self->wanted }; # are we running in colour mode? if(Test::Builder::Tester::color) { # get color eval { require Term::ANSIColor }; unless($@) { eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms # colours my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green"); my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red"); my $reset = Term::ANSIColor::color("reset"); # work out where the two strings start to differ my $char = 0; $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 ); # get the start string and the two end strings my $start = $green . substr( $wanted, 0, $char ); my $gotend = $red . substr( $got, $char ) . $reset; my $wantedend = $red . substr( $wanted, $char ) . $reset; # make the start turn green on and off $start =~ s/\n/$reset\n$green/g; # make the ends turn red on and off $gotend =~ s/\n/$reset\n$red/g; $wantedend =~ s/\n/$reset\n$red/g; # rebuild the strings $got = $start . $gotend; $wanted = $start . $wantedend; } } my @got = split "\n", $got; my @wanted = split "\n", $wanted; $got = ""; $wanted = ""; while (@got || @wanted) { my $g = shift @got || ""; my $w = shift @wanted || ""; if ($g ne $w) { if($g =~ s/(\s+)$/ |> /g) { $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1; } if($w =~ s/(\s+)$/ |> /g) { $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1; } $g = "> $g"; $w = "> $w"; } else { $g = " $g"; $w = " $w"; } $got = $got ? "$got\n$g" : $g; $wanted = $wanted ? "$wanted\n$w" : $w; } return "$type is:\n" . "$got\nnot:\n$wanted\nas expected"; } ## # forget all expected and got data sub reset { my $self = shift; %$self = ( type => $self->{type}, got => '', wanted => [], ); } sub got { my $self = shift; return $self->{got}; } sub wanted { my $self = shift; return $self->{wanted}; } sub type { my $self = shift; return $self->{type}; } ### # tie interface ### sub PRINT { my $self = shift; $self->{got} .= join '', @_; } sub TIEHANDLE { my( $class, $type ) = @_; my $self = bless { type => $type }, $class; $self->reset; return $self; } sub READ { } sub READLINE { } sub GETC { } sub FILENO { } 1; perl5/Test/Builder/Module.pm 0000444 00000007757 14711217644 0011710 0 ustar 00 package Test::Builder::Module; use strict; use Test::Builder; require Exporter; our @ISA = qw(Exporter); our $VERSION = '1.302186'; =head1 NAME Test::Builder::Module - Base class for test modules =head1 SYNOPSIS # Emulates Test::Simple package Your::Module; my $CLASS = __PACKAGE__; use parent 'Test::Builder::Module'; @EXPORT = qw(ok); sub ok ($;$) { my $tb = $CLASS->builder; return $tb->ok(@_); } 1; =head1 DESCRIPTION This is a superclass for L<Test::Builder>-based modules. It provides a handful of common functionality and a method of getting at the underlying L<Test::Builder> object. =head2 Importing Test::Builder::Module is a subclass of L<Exporter> which means your module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... all act normally. A few methods are provided to do the C<< use Your::Module tests => 23 >> part for you. =head3 import Test::Builder::Module provides an C<import()> method which acts in the same basic way as L<Test::More>'s, setting the plan and controlling exporting of functions and variables. This allows your module to set the plan independent of L<Test::More>. All arguments passed to C<import()> are passed onto C<< Your::Module->builder->plan() >> with the exception of C<< import =>[qw(things to import)] >>. use Your::Module import => [qw(this that)], tests => 23; says to import the functions C<this()> and C<that()> as well as set the plan to be 23 tests. C<import()> also sets the C<exported_to()> attribute of your builder to be the caller of the C<import()> function. Additional behaviors can be added to your C<import()> method by overriding C<import_extra()>. =cut sub import { my($class) = shift; Test2::API::test2_load() unless Test2::API::test2_in_preload(); # Don't run all this when loading ourself. return 1 if $class eq 'Test::Builder::Module'; my $test = $class->builder; my $caller = caller; $test->exported_to($caller); $class->import_extra( \@_ ); my(@imports) = $class->_strip_imports( \@_ ); $test->plan(@_); local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; $class->Exporter::import(@imports); } sub _strip_imports { my $class = shift; my $list = shift; my @imports = (); my @other = (); my $idx = 0; while( $idx <= $#{$list} ) { my $item = $list->[$idx]; if( defined $item and $item eq 'import' ) { push @imports, @{ $list->[ $idx + 1 ] }; $idx++; } else { push @other, $item; } $idx++; } @$list = @other; return @imports; } =head3 import_extra Your::Module->import_extra(\@import_args); C<import_extra()> is called by C<import()>. It provides an opportunity for you to add behaviors to your module based on its import list. Any extra arguments which shouldn't be passed on to C<plan()> should be stripped off by this method. See L<Test::More> for an example of its use. B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it feels like a bit of an ugly hack in its current form. =cut sub import_extra { } =head2 Builder Test::Builder::Module provides some methods of getting at the underlying Test::Builder object. =head3 builder my $builder = Your::Class->builder; This method returns the L<Test::Builder> object associated with Your::Class. It is not a constructor so you can call it as often as you like. This is the preferred way to get the L<Test::Builder> object. You should I<not> get it via C<< Test::Builder->new >> as was previously recommended. The object returned by C<builder()> may change at runtime so you should call C<builder()> inside each function rather than store it in a global. sub ok { my $builder = Your::Class->builder; return $builder->ok(@_); } =cut sub builder { return Test::Builder->new; } =head1 SEE ALSO L<< Test2::Manual::Tooling::TestBuilder >> describes the improved options for writing testing modules provided by L<< Test2 >>. =cut 1; perl5/Test/Builder/Formatter.pm 0000444 00000004112 14711217645 0012405 0 ustar 00 package Test::Builder::Formatter; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } use Test2::Util::HashBase qw/no_header no_diag/; BEGIN { *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); my $todo = OUT_ERR() + 1; *OUT_TODO = sub() { $todo }; } sub init { my $self = shift; $self->SUPER::init(@_); $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; } sub plan_tap { my ($self, $f) = @_; return if $self->{+NO_HEADER}; return $self->SUPER::plan_tap($f); } sub debug_tap { my ($self, $f, $num) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::debug_tap($f, $num); $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } sub info_tap { my ($self, $f) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::info_tap($f); $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } sub redirect { my ($self, $out) = @_; $_->[0] = OUT_TODO for @$out; } sub no_subtest_space { 1 } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP =head1 DESCRIPTION This is what takes events and turns them into TAP. =head1 SYNOPSIS use Test::Builder; # Loads Test::Builder::Formatter for you =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test/Builder/IO/Scalar.pm 0000444 00000032510 14711217646 0012162 0 ustar 00 package Test::Builder::IO::Scalar; =head1 NAME Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder =head1 DESCRIPTION This is a copy of L<IO::Scalar> which ships with L<Test::Builder> to support scalar references as filehandles on Perl 5.6. Newer versions of Perl simply use C<open()>'s built in support. L<Test::Builder> can not have dependencies on other modules without careful consideration, so its simply been copied into the distribution. =head1 COPYRIGHT and LICENSE This file came from the "IO-stringy" Perl5 toolkit. Copyright (c) 1996 by Eryq. All rights reserved. Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut # This is copied code, I don't care. ##no critic use Carp; use strict; use vars qw($VERSION @ISA); use IO::Handle; use 5.005; ### The package version, both in 1.23 style *and* usable by MakeMaker: $VERSION = "2.114"; ### Inheritance: @ISA = qw(IO::Handle); #============================== =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I<Class method.> Return a new, unattached scalar handle. If any arguments are given, they're sent to open(). =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = bless \do { local *FH }, $class; tie *$self, $class, $self; $self->open(@_); ### open on anonymous by default $self; } sub DESTROY { shift->close; } #------------------------------ =item open [SCALARREF] I<Instance method.> Open the scalar handle on a new scalar, pointed to by SCALARREF. If no SCALARREF is given, a "private" scalar is created to hold the file data. Returns the self object on success, undefined on error. =cut sub open { my ($self, $sref) = @_; ### Sanity: defined($sref) or do {my $s = ''; $sref = \$s}; (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; ### Setup: *$self->{Pos} = 0; ### seek position *$self->{SR} = $sref; ### scalar reference $self; } #------------------------------ =item opened I<Instance method.> Is the scalar handle opened on something? =cut sub opened { *{shift()}->{SR}; } #------------------------------ =item close I<Instance method.> Disassociate the scalar handle from its underlying scalar. Done automatically on destroy. =cut sub close { my $self = shift; %{*$self} = (); 1; } =back =cut #============================== =head2 Input and output =over 4 =cut #------------------------------ =item flush I<Instance method.> No-op, provided for OO compatibility. =cut sub flush { "0 but true" } #------------------------------ =item getc I<Instance method.> Return the next character, or undef if none remain. =cut sub getc { my $self = shift; ### Return undef right away if at EOF; else, move pos forward: return undef if $self->eof; substr(${*$self->{SR}}, *$self->{Pos}++, 1); } #------------------------------ =item getline I<Instance method.> Return the next line, or undef on end of string. Can safely be called in an array context. Currently, lines are delimited by "\n". =cut sub getline { my $self = shift; ### Return undef right away if at EOF: return undef if $self->eof; ### Get next line: my $sr = *$self->{SR}; my $i = *$self->{Pos}; ### Start matching at this point. ### Minimal impact implementation! ### We do the fast fast thing (no regexps) if using the ### classic input record separator. ### Case 1: $/ is undef: slurp all... if (!defined($/)) { *$self->{Pos} = length $$sr; return substr($$sr, $i); } ### Case 2: $/ is "\n": zoom zoom zoom... elsif ($/ eq "\012") { ### Seek ahead for "\n"... yes, this really is faster than regexps. my $len = length($$sr); for (; $i < $len; ++$i) { last if ord (substr ($$sr, $i, 1)) == 10; } ### Extract the line: my $line; if ($i < $len) { ### We found a "\n": $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); *$self->{Pos} = $i+1; ### Remember where we finished up. } else { ### No "\n"; slurp the remainder: $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); *$self->{Pos} = $len; } return $line; } ### Case 3: $/ is ref to int. Do fixed-size records. ### (Thanks to Dominique Quatravaux.) elsif (ref($/)) { my $len = length($$sr); my $i = ${$/} + 0; my $line = substr ($$sr, *$self->{Pos}, $i); *$self->{Pos} += $i; *$self->{Pos} = $len if (*$self->{Pos} > $len); return $line; } ### Case 4: $/ is either "" (paragraphs) or something weird... ### This is Graham's general-purpose stuff, which might be ### a tad slower than Case 2 for typical data, because ### of the regexps. else { pos($$sr) = $i; ### If in paragraph mode, skip leading lines (and update i!): length($/) or (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); ### If we see the separator in the buffer ahead... if (length($/) ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! : $$sr =~ m,\n\n,g ### (a paragraph) ) { *$self->{Pos} = pos $$sr; return substr($$sr, $i, *$self->{Pos}-$i); } ### Else if no separator remains, just slurp the rest: else { *$self->{Pos} = length $$sr; return substr($$sr, $i); } } } #------------------------------ =item getlines I<Instance method.> Get all remaining lines. It will croak() if accidentally called in a scalar context. =cut sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); my ($line, @lines); push @lines, $line while (defined($line = $self->getline)); @lines; } #------------------------------ =item print ARGS... I<Instance method.> Print ARGS to the underlying scalar. B<Warning:> this continues to always cause a seek to the end of the string, but if you perform seek()s and tell()s, it is still safer to explicitly seek-to-end before subsequent print()s. =cut sub print { my $self = shift; *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); 1; } sub _unsafe_print { my $self = shift; my $append = join('', @_) . $\; ${*$self->{SR}} .= $append; *$self->{Pos} += length($append); 1; } sub _old_print { my $self = shift; ${*$self->{SR}} .= join('', @_) . $\; *$self->{Pos} = length(${*$self->{SR}}); 1; } #------------------------------ =item read BUF, NBYTES, [OFFSET] I<Instance method.> Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub read { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); $n = length($read); *$self->{Pos} += $n; ($off ? substr($_[1], $off) : $_[1]) = $read; return $n; } #------------------------------ =item write BUF, NBYTES, [OFFSET] I<Instance method.> Write some bytes to the scalar. =cut sub write { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $data = substr($_[1], $off, $n); $n = length($data); $self->print($data); return $n; } #------------------------------ =item sysread BUF, LEN, [OFFSET] I<Instance method.> Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub sysread { my $self = shift; $self->read(@_); } #------------------------------ =item syswrite BUF, NBYTES, [OFFSET] I<Instance method.> Write some bytes to the scalar. =cut sub syswrite { my $self = shift; $self->write(@_); } =back =cut #============================== =head2 Seeking/telling and other attributes =over 4 =cut #------------------------------ =item autoflush I<Instance method.> No-op, provided for OO compatibility. =cut sub autoflush {} #------------------------------ =item binmode I<Instance method.> No-op, provided for OO compatibility. =cut sub binmode {} #------------------------------ =item clearerr I<Instance method.> Clear the error and EOF flags. A no-op. =cut sub clearerr { 1 } #------------------------------ =item eof I<Instance method.> Are we at end of file? =cut sub eof { my $self = shift; (*$self->{Pos} >= length(${*$self->{SR}})); } #------------------------------ =item seek OFFSET, WHENCE I<Instance method.> Seek to a given position in the stream. =cut sub seek { my ($self, $pos, $whence) = @_; my $eofpos = length(${*$self->{SR}}); ### Seek: if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END else { croak "bad seek whence ($whence)" } ### Fixup: if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } return 1; } #------------------------------ =item sysseek OFFSET, WHENCE I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> =cut sub sysseek { my $self = shift; $self->seek (@_); } #------------------------------ =item tell I<Instance method.> Return the current position in the stream, as a numeric offset. =cut sub tell { *{shift()}->{Pos} } #------------------------------ =item use_RS [YESNO] I<Instance method.> B<Deprecated and ignored.> Obey the current setting of $/, like IO::Handle does? Default is false in 1.x, but cold-welded true in 2.x and later. =cut sub use_RS { my ($self, $yesno) = @_; carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; } #------------------------------ =item setpos POS I<Instance method.> Set the current position, using the opaque value returned by C<getpos()>. =cut sub setpos { shift->seek($_[0],0) } #------------------------------ =item getpos I<Instance method.> Return the current position in the string, as an opaque object. =cut *getpos = \&tell; #------------------------------ =item sref I<Instance method.> Return a reference to the underlying scalar. =cut sub sref { *{shift()}->{SR} } #------------------------------ # Tied handle methods... #------------------------------ # Conventional tiehandle interface: sub TIEHANDLE { ((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__)) ? $_[1] : shift->new(@_)); } sub GETC { shift->getc(@_) } sub PRINT { shift->print(@_) } sub PRINTF { shift->print(sprintf(shift, @_)) } sub READ { shift->read(@_) } sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } sub WRITE { shift->write(@_); } sub CLOSE { shift->close(@_); } sub SEEK { shift->seek(@_); } sub TELL { shift->tell(@_); } sub EOF { shift->eof(@_); } sub FILENO { -1 } #------------------------------------------------------------ 1; __END__ =back =cut =head1 WARNINGS Perl's TIEHANDLE spec was incomplete prior to 5.005_57; it was missing support for C<seek()>, C<tell()>, and C<eof()>. Attempting to use these functions with an IO::Scalar will not work prior to 5.005_57. IO::Scalar will not have the relevant methods invoked; and even worse, this kind of bug can lie dormant for a while. If you turn warnings on (via C<$^W> or C<perl -w>), and you see something like this... attempt to seek on unopened filehandle ...then you are probably trying to use one of these functions on an IO::Scalar with an old Perl. The remedy is to simply use the OO version; e.g.: $SH->seek(0,0); ### GOOD: will work on any 5.005 seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond =head1 VERSION $Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHORS =head2 Primary Maintainer David F. Skoll (F<dfs@roaringpenguin.com>). =head2 Principal author Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head2 Other contributors The full set of contributors always includes the folks mentioned in L<IO::Stringy/"CHANGE LOG">. But just the same, special thanks to the following individuals for their invaluable contributions (if I've forgotten or misspelled your name, please email me!): I<Andy Glew,> for contributing C<getc()>. I<Brandon Browning,> for suggesting C<opened()>. I<David Richter,> for finding and fixing the bug in C<PRINTF()>. I<Eric L. Brine,> for his offset-using read() and write() implementations. I<Richard Jones,> for his patches to massively improve the performance of C<getline()> and add C<sysread> and C<syswrite>. I<B. K. Oxley (binkley),> for stringification and inheritance improvements, and sundry good ideas. I<Doug Wilson,> for the IO::Handle inheritance and automatic tie-ing. =head1 SEE ALSO L<IO::String>, which is quite similar but which was designed more-recently and with an IO::Handle-like interface in mind, so you could mix OO- and native-filehandle usage without using tied(). I<Note:> as of version 2.x, these classes all work like their IO::Handle counterparts, so we have comparable functionality to IO::String. =cut perl5/Test/Builder/TodoDiag.pm 0000444 00000002071 14711217651 0012133 0 ustar 00 package Test::Builder::TodoDiag; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } sub diagnostics { 0 } sub facet_data { my $self = shift; my $out = $self->SUPER::facet_data(); $out->{info}->[0]->{debug} = 0; return $out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag =head1 DESCRIPTION This is used to encapsulate diag messages created inside TODO. =head1 SYNOPSIS You do not need to use this directly. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/Test/Alien/Synthetic.pm 0000444 00000010536 14711217652 0012063 0 ustar 00 package Test::Alien::Synthetic; use strict; use warnings; use 5.008004; use Test2::API qw( context ); # ABSTRACT: A mock alien object for testing our $VERSION = '2.41'; # VERSION sub _def ($) { my($val) = @_; defined $val ? $val : '' } sub cflags { _def shift->{cflags} } sub libs { _def shift->{libs} } sub dynamic_libs { @{ shift->{dynamic_libs} || [] } } sub runtime_prop { my($self) = @_; defined $self->{runtime_prop} ? $self->{runtime_prop} : {}; } sub cflags_static { my($self) = @_; defined $self->{cflags_static} ? $self->{cflags_static} : $self->cflags; } sub libs_static { my($self) = @_; defined $self->{libs_static} ? $self->{libs_static} : $self->libs; } sub bin_dir { my $dir = shift->{bin_dir}; defined $dir && -d $dir ? ($dir) : (); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien::Synthetic - A mock alien object for testing =head1 VERSION version 2.41 =head1 SYNOPSIS use Test2::V0; use Test::Alien; my $alien = synthetic { cflags => '-I/foo/bar/include', libs => '-L/foo/bar/lib -lbaz', }; alien_ok $alien; done_testing; =head1 DESCRIPTION This class is used to model a synthetic L<Alien> class that implements the minimum L<Alien::Base> interface needed by L<Test::Alien>. It can be useful if you have a non-L<Alien::Base> based L<Alien> distribution that you need to test. B<NOTE>: The name of this class may move in the future, so do not refer to this class name directly. Instead create instances of this class using the L<Test::Alien#synthetic> function. =head1 ATTRIBUTES =head2 cflags String containing the compiler flags =head2 cflags_static String containing the static compiler flags =head2 libs String containing the linker and library flags =head2 libs_static String containing the static linker and library flags =head2 dynamic_libs List reference containing the dynamic libraries. =head2 bin_dir Tool binary directory. =head2 runtime_prop Runtime properties. =head1 EXAMPLE Here is a complete example using L<Alien::Libarchive> which is a non-L<Alien::Base> based L<Alien> distribution. use strict; use warnings; use Test2::V0; use Test::Alien; use Alien::Libarchive; my $real = Alien::Libarchive->new; my $alien = synthetic { cflags => scalar $real->cflags, libs => scalar $real->libs, dynamic_libs => [$real->dlls], }; alien_ok $alien; xs_ok do { local $/; <DATA> }, with_subtest { my($module) = @_; my $ptr = $module->archive_read_new; like $ptr, qr{^[0-9]+$}; $module->archive_read_free($ptr); }; ffi_ok { symbols => [qw( archive_read_new )] }, with_subtest { my($ffi) = @_; my $new = $ffi->function(archive_read_new => [] => 'opaque'); my $free = $ffi->function(archive_read_close => ['opaque'] => 'void'); my $ptr = $new->(); like $ptr, qr{^[0-9]+$}; $free->($ptr); }; done_testing; __DATA__ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include <archive.h> MODULE = TA_MODULE PACKAGE = TA_MODULE void *archive_read_new(class); const char *class; CODE: RETVAL = (void*) archive_read_new(); OUTPUT: RETVAL void archive_read_free(class, ptr); const char *class; void *ptr; CODE: archive_read_free(ptr); =head1 SEE ALSO =over 4 =item L<Test::Alien> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Alien/Run.pm 0000444 00000014122 14711217653 0010651 0 ustar 00 package Test::Alien::Run; use strict; use warnings; use 5.008004; use Test2::API qw( context ); # ABSTRACT: Run object our $VERSION = '2.41'; # VERSION sub out { shift->{out} } sub err { shift->{err} } sub exit { shift->{exit} } sub signal { shift->{sig} } sub success { my($self, $message) = @_; $message ||= 'command succeeded'; my $ok = $self->exit == 0 && $self->signal == 0; $ok = 0 if $self->{fail}; my $ctx = context(); $ctx->ok($ok, $message); unless($ok) { $ctx->diag(" command exited with @{[ $self->exit ]}") if $self->exit; $ctx->diag(" command killed with @{[ $self->signal ]}") if $self->signal; $ctx->diag(" @{[ $self->{fail} ]}") if $self->{fail}; } $ctx->release; $self; } sub exit_is { my($self, $exit, $message) = @_; $message ||= "command exited with value $exit"; my $ok = $self->exit == $exit; my $ctx = context(); $ctx->ok($ok, $message); $ctx->diag(" actual exit value was: @{[ $self->exit ]}") unless $ok; $ctx->release; $self; } sub exit_isnt { my($self, $exit, $message) = @_; $message ||= "command exited with value not $exit"; my $ok = $self->exit != $exit; my $ctx = context(); $ctx->ok($ok, $message); $ctx->diag(" actual exit value was: @{[ $self->exit ]}") unless $ok; $ctx->release; $self; } sub _like { my($self, $regex, $source, $not, $message) = @_; my $ok = $self->{$source} =~ $regex; $ok = !$ok if $not; my $ctx = context(); $ctx->ok($ok, $message); unless($ok) { $ctx->diag(" $source:"); $ctx->diag(" $_") for split /\r?\n/, $self->{$source}; $ctx->diag($not ? ' matches:' : ' does not match:'); $ctx->diag(" $regex"); } $ctx->release; $self; } sub out_like { my($self, $regex, $message) = @_; $message ||= "output matches $regex"; $self->_like($regex, 'out', 0, $message); } sub out_unlike { my($self, $regex, $message) = @_; $message ||= "output does not match $regex"; $self->_like($regex, 'out', 1, $message); } sub err_like { my($self, $regex, $message) = @_; $message ||= "standard error matches $regex"; $self->_like($regex, 'err', 0, $message); } sub err_unlike { my($self, $regex, $message) = @_; $message ||= "standard error does not match $regex"; $self->_like($regex, 'err', 1, $message); } sub note { my($self) = @_; my $ctx = context(); $ctx->note("[cmd]"); $ctx->note(" @{$self->{cmd}}"); if($self->out ne '') { $ctx->note("[out]"); $ctx->note(" $_") for split /\r?\n/, $self->out; } if($self->err ne '') { $ctx->note("[err]"); $ctx->note(" $_") for split /\r?\n/, $self->err; } $ctx->release; $self; } sub diag { my($self) = @_; my $ctx = context(); $ctx->diag("[cmd]"); $ctx->diag(" @{$self->{cmd}}"); if($self->out ne '') { $ctx->diag("[out]"); $ctx->diag(" $_") for split /\r?\n/, $self->out; } if($self->err ne '') { $ctx->diag("[err]"); $ctx->diag(" $_") for split /\r?\n/, $self->err; } $ctx->release; $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien::Run - Run object =head1 VERSION version 2.41 =head1 SYNOPSIS use Test2::V0; use Test::Alien; run_ok([ $^X, -e => 'print "some output"; exit 22']) ->exit_is(22) ->out_like(qr{some}); =head1 DESCRIPTION This class stores information about a process run as performed by L<Test::Alien#run_ok>. That function is the I<ONLY> way to create an instance of this class. =head1 ATTRIBUTES =head2 out my $str = $run->out; The standard output from the run. =head2 err my $str = $run->err; The standard error from the run. =head2 exit my $int = $run->exit; The exit value of the run. =head2 signal my $int = $run->signal; The signal that killed the run, or zero if the process was terminated normally. =head1 METHODS These methods return the run object itself, so they can be chained, as in the synopsis above. =head2 success $run->success; $run->success($message); Passes if the process terminated normally with an exit value of 0. =head2 exit_is $run->exit_is($exit); $run->exit_is($exit, $message); Passes if the process terminated with the given exit value. =head2 exit_isnt $run->exit_isnt($exit); $run->exit_isnt($exit, $message); Passes if the process terminated with an exit value of anything but the given value. =head2 out_like $run->out_like($regex); $run->out_like($regex, $message); Passes if the output of the run matches the given pattern. =head2 out_unlike $run->out_unlike($regex); $run->out_unlike($regex, $message); Passes if the output of the run does not match the given pattern. =head2 err_like $run->err_like($regex); $run->err_like($regex, $message); Passes if the standard error of the run matches the given pattern. =head2 err_unlike $run->err_unlike($regex); $run->err_unlike($regex, $message); Passes if the standard error of the run does not match the given pattern. =head2 note $run->note; Send the output and standard error as test note. =head2 diag $run->diag; Send the output and standard error as test diagnostic. =head1 SEE ALSO =over 4 =item L<Test::Alien> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Alien/CanCompile.pm 0000444 00000003607 14711217654 0012126 0 ustar 00 package Test::Alien::CanCompile; use strict; use warnings; use 5.008004; use Test2::API qw( context ); # ABSTRACT: Skip a test file unless a C compiler is available our $VERSION = '2.41'; # VERSION sub skip { require ExtUtils::CBuilder; ExtUtils::CBuilder->new->have_compiler ? undef : 'This test requires a compiler.'; } sub import { my $skip = __PACKAGE__->skip; return unless defined $skip; my $ctx = context(); $ctx->plan(0, SKIP => $skip); $ctx->release; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien::CanCompile - Skip a test file unless a C compiler is available =head1 VERSION version 2.41 =head1 SYNOPSIS use Test::Alien::CanCompile; =head1 DESCRIPTION This is just a L<Test2> plugin that requires that a compiler be available. Otherwise the test will be skipped. =head1 SEE ALSO =over 4 =item L<Test::Alien> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Alien/Build.pm 0000444 00000042201 14711217655 0011145 0 ustar 00 package Test::Alien::Build; use strict; use warnings; use 5.008004; use Exporter qw( import ); use Path::Tiny qw( path ); use Carp qw( croak ); use Test2::API qw( context run_subtest ); use Capture::Tiny qw( capture_merged ); use Alien::Build::Util qw( _mirror ); use List::Util 1.33 qw( any ); use Alien::Build::Temp; our @EXPORT = qw( alienfile alienfile_ok alienfile_skip_if_missing_prereqs alien_download_ok alien_extract_ok alien_build_ok alien_build_clean alien_clean_install alien_install_type_is alien_checkpoint_ok alien_resume_ok alien_subtest alien_rc ); # ABSTRACT: Tools for testing Alien::Build + alienfile our $VERSION = '2.41'; # VERSION my $build; my $build_alienfile; my $build_root; my $build_targ; sub alienfile::targ { $build_targ; } sub alienfile { my($package, $filename, $line) = caller; ($package, $filename, $line) = caller(2) if $package eq __PACKAGE__; $filename = path($filename)->absolute; my %args = @_ == 0 ? (filename => 'alienfile') : @_ % 2 ? ( source => do { '# line '. $line . ' "' . path($filename)->absolute . qq("\n) . $_[0] }) : @_; require alienfile; push @alienfile::EXPORT, 'targ' unless any { /^targ$/ } @alienfile::EXPORT; my $temp = Alien::Build::Temp->newdir; my $get_temp_root = do{ my $root; # may be undef; sub { $root ||= Path::Tiny->new($temp); if(@_) { my $path = $root->child(@_); $path->mkpath; $path; } else { return $root; } }; }; if($args{source}) { my $file = $get_temp_root->()->child('alienfile'); $file->spew_utf8($args{source}); $args{filename} = $file->stringify; } else { unless(defined $args{filename}) { croak "You must specify at least one of filename or source"; } $args{filename} = path($args{filename})->absolute->stringify; } $args{stage} ||= $get_temp_root->('stage')->stringify; $args{prefix} ||= $get_temp_root->('prefix')->stringify; $args{root} ||= $get_temp_root->('root')->stringify; require Alien::Build; _alienfile_clear(); my $out = capture_merged { $build_targ = $args{targ}; $build = Alien::Build->load($args{filename}, root => $args{root}); $build->set_stage($args{stage}); $build->set_prefix($args{prefix}); }; my $ctx = context(); $ctx->note($out) if $out; $ctx->release; $build_alienfile = $args{filename}; $build_root = $temp; $build } sub _alienfile_clear { eval { defined $build_root && -d $build_root && path($build_root)->remove_tree }; undef $build; undef $build_alienfile; undef $build_root; undef $build_targ; } sub alienfile_ok { my $build; my $name; my $error; if(@_ == 1 && ! defined $_[0]) { $build = $_[0]; $error = 'no alienfile given'; $name = 'alienfile compiled'; } elsif(@_ == 1 && eval { $_[0]->isa('Alien::Build') }) { $build = $_[0]; $name = 'alienfile compiled'; } else { $build = eval { alienfile(@_) }; $error = $@; $name = 'alienfile compiles'; } my $ok = !! $build; my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag("error: $error") if $error; $ctx->release; $build; } sub alienfile_skip_if_missing_prereqs { my($phase) = @_; if($build) { eval { $build->load_requires('configure', 1) }; if(my $error = $@) { my $reason = "Missing configure prereq"; if($error =~ /Required (.*) (.*),/) { $reason .= ": $1 $2"; } my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release; return; } $phase ||= $build->install_type; eval { $build->load_requires($phase, 1) }; if(my $error = $@) { my $reason = "Missing $phase prereq"; if($error =~ /Required (.*) (.*),/) { $reason .= ": $1 $2"; } my $ctx = context(); $ctx->plan(0, SKIP => $reason); $ctx->release; return; } } } sub alien_install_type_is { my($type, $name) = @_; croak "invalid install type" unless defined $type && $type =~ /^(system|share)$/; $name ||= "alien install type is $type"; my $ok = 0; my @diag; if($build) { my($out, $actual) = capture_merged { $build->load_requires('configure'); $build->install_type; }; if($type eq $actual) { $ok = 1; } else { push @diag, "expected install type of $type, but got $actual"; } } else { push @diag, 'no alienfile' } my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag($_) for @diag; $ctx->release; $ok; } sub alien_download_ok { my($name) = @_; $name ||= 'alien download'; my $ok; my $file; my @diag; my @note; if($build) { my($out, $error) = capture_merged { eval { $build->load_requires('configure'); $build->load_requires($build->install_type); $build->download; }; $@; }; if($error) { $ok = 0; push @diag, $out if defined $out; push @diag, "extract threw exception: $error"; } else { $file = $build->install_prop->{download}; if(-d $file || -f $file) { $ok = 1; push @note, $out if defined $out; } else { $ok = 0; push @diag, $out if defined $out; push @diag, 'no file or directory'; } } } else { $ok = 0; push @diag, 'no alienfile'; } my $ctx = context(); $ctx->ok($ok, $name); $ctx->note($_) for @note; $ctx->diag($_) for @diag; $ctx->release; $file; } sub alien_extract_ok { my($archive, $name) = @_; $name ||= $archive ? "alien extraction of $archive" : 'alien extraction'; my $ok; my $dir; my @diag; if($build) { my($out, $error); ($out, $dir, $error) = capture_merged { my $dir = eval { $build->load_requires('configure'); $build->load_requires($build->install_type); $build->download; $build->extract($archive); }; ($dir, $@); }; if($error) { $ok = 0; push @diag, $out if defined $out; push @diag, "extract threw exception: $error"; } else { if(-d $dir) { $ok = 1; } else { $ok = 0; push @diag, 'no directory'; } } } else { $ok = 0; push @diag, 'no alienfile'; } my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag($_) for @diag; $ctx->release; $dir; } my $count = 1; sub alien_build_ok { my $opt = defined $_[0] && ref($_[0]) eq 'HASH' ? shift : { class => 'Alien::Base' }; my($name) = @_; $name ||= 'alien builds okay'; my $ok; my @diag; my @note; my $alien; if($build) { my($out,$error) = capture_merged { eval { $build->load_requires('configure'); $build->load_requires($build->install_type); $build->download; $build->build; }; $@; }; if($error) { $ok = 0; push @diag, $out if defined $out; push @diag, "build threw exception: $error"; } else { $ok = 1; push @note, $out if defined $out; require Alien::Base; my $prefix = $build->runtime_prop->{prefix}; my $stage = $build->install_prop->{stage}; my %prop = %{ $build->runtime_prop }; $prop{distdir} = $prefix; _mirror $stage, $prefix; my $dist_dir = sub { $prefix; }; my $runtime_prop = sub { \%prop; }; $alien = sprintf 'Test::Alien::Build::Faux%04d', $count++; { no strict 'refs'; @{ "${alien}::ISA" } = $opt->{class}; *{ "${alien}::dist_dir" } = $dist_dir; *{ "${alien}::runtime_prop" } = $runtime_prop; } } } else { $ok = 0; push @diag, 'no alienfile'; } my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag($_) for @diag; $ctx->note($_) for @note; $ctx->release; $alien; } sub alien_build_clean { my $ctx = context(); if($build_root) { foreach my $child (path($build_root)->children) { next if $child->basename eq 'prefix'; $ctx->note("clean: rm: $child"); $child->remove_tree; } } else { $ctx->note("no build to clean"); } $ctx->release; } sub alien_clean_install { my($name) = @_; $name ||= "run clean_install"; my $ok; my @diag; my @note; if($build) { my($out,$error) = capture_merged { eval { $build->clean_install; }; $@; }; if($error) { $ok = 0; push @diag, $out if defined $out && $out ne ''; push @diag, "build threw exception: $error"; } else { $ok = 1; push @note, $out if defined $out && $out ne ''; } } else { $ok = 0; push @diag, 'no alienfile'; } my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag($_) for @diag; $ctx->note($_) for @note; $ctx->release; } sub alien_checkpoint_ok { my($name) = @_; $name ||= "alien checkpoint ok"; my $ok; my @diag; if($build) { eval { $build->checkpoint }; if($@) { push @diag, "error in checkpoint: $@"; $ok = 0; } else { $ok = 1; } undef $build; } else { push @diag, "no build to checkpoint"; $ok = 0; } my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag($_) for @diag; $ctx->release; $ok; } sub alien_resume_ok { my($name) = @_; $name ||= "alien resume ok"; my $ok; my @diag; if($build_alienfile && $build_root && !defined $build) { $build = eval { Alien::Build->resume($build_alienfile, "$build_root/root") }; if($@) { push @diag, "error in resume: $@"; $ok = 0; } else { $ok = 1; } } else { if($build) { push @diag, "build has not been checkpointed"; } else { push @diag, "no build to resume"; } $ok = 0; } my $ctx = context(); $ctx->ok($ok, $name); $ctx->diag($_) for @diag; $ctx->release; ($ok && $build) || $ok; } my $alien_rc_root; sub alien_rc { my($code) = @_; croak "passed in undef rc" unless defined $code; croak "looks like you have already defined a rc.pl file" if $ENV{ALIEN_BUILD_RC} ne '-'; my(undef, $filename, $line) = caller; my $code2 = "use strict; use warnings;\n" . '# line ' . $line . ' "' . path($filename)->absolute . "\n$code"; $alien_rc_root ||= Alien::Build::Temp->newdir; my $rc = path($alien_rc_root)->child('rc.pl'); $rc->spew_utf8($code2); $ENV{ALIEN_BUILD_RC} = "$rc"; return 1; } sub alien_subtest { my($name, $code, @args) = @_; _alienfile_clear; my $ctx = context(); my $pass = run_subtest($name, $code, { buffered => 1 }, @args); $ctx->release; _alienfile_clear; $pass; } delete $ENV{$_} for qw( ALIEN_BUILD_LOG ALIEN_BUILD_PRELOAD ALIEN_BUILD_POSTLOAD ALIEN_INSTALL_TYPE PKG_CONFIG_PATH ALIEN_BUILD_PKG_CONFIG ); $ENV{ALIEN_BUILD_RC} = '-'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien::Build - Tools for testing Alien::Build + alienfile =head1 VERSION version 2.41 =head1 SYNOPSIS use Test2::V0; use Test::Alien::Build; # returns an instance of Alien::Build. my $build = alienfile_ok q{ use alienfile; plugin 'My::Plugin' => ( foo => 1, bar => 'string', ... ); }; alien_build_ok 'builds okay.'; done_testing; =head1 DESCRIPTION This module provides some tools for testing L<Alien::Build> and L<alienfile>. Outside of L<Alien::Build> core development, It is probably most useful for L<Alien::Build::Plugin> developers. This module also unsets a number of L<Alien::Build> specific environment variables, in order to make tests reproducible even when overrides are set in different environments. So if you want to test those variables in various states you should explicitly set them in your test script. These variables are unset if they defined: C<ALIEN_BUILD_PRELOAD> C<ALIEN_BUILD_POSTLOAD> C<ALIEN_INSTALL_TYPE>. =head1 FUNCTIONS =head2 alienfile my $build = alienfile; my $build = alienfile q{ use alienfile ... }; my $build = alienfile filename => 'alienfile'; Create a Alien::Build instance from the given L<alienfile>. The first two forms are abbreviations. my $build = alienfile; # is the same as my $build = alienfile filename => 'alienfile'; and my $build = alienfile q{ use alienfile ... }; # is the same as my $build = alienfile source => q{ use alienfile ... }; Except for the second abbreviated form sets the line number before feeding the source into L<Alien::Build> so that you will get diagnostics with the correct line numbers. =over 4 =item source The source for the alienfile as a string. You must specify one of C<source> or C<filename>. =item filename The filename for the alienfile. You must specify one of C<source> or C<filename>. =item root The build root. =item stage The staging area for the build. =item prefix The install prefix for the build. =back =head2 alienfile_ok my $build = alienfile_ok; my $build = alienfile_ok q{ use alienfile ... }; my $build = alienfile_ok filename => 'alienfile'; my $build = alienfile_ok $build; Same as C<alienfile> above, except that it runs as a test, and will not throw an exception on failure (it will return undef instead). [version 1.49] As of version 1.49 you can also pass in an already formed instance of L<Alien::Build>. This allows you to do something like this: subtest 'a subtest' => sub { my $build = alienfile q{ use alienfile; ... }; alienfile_skip_if_missing_prereqs; # skip if alienfile prereqs are missing alienfile_ok $build; # delayed pass/fail for the compile of alienfile }; =head2 alienfile_skip_if_missing_prereqs alienfile_skip_if_missing_prereqs; alienfile_skip_if_missing_prereqs $phase; Skips the test or subtest if the prereqs for the alienfile are missing. If C<$phase> is not given, then either C<share> or C<system> will be detected. =head2 alien_install_type_is alien_install_type_is $type; alien_install_type_is $type, $name; Simple test to see if the install type is what you expect. C<$type> should be one of C<system> or C<share>. =head2 alien_download_ok my $file = alien_download_ok; my $file = alien_download_ok $name; Makes a download attempt and test that a file or directory results. Returns the file or directory if successful. Returns C<undef> otherwise. =head2 alien_extract_ok my $dir = alien_extract_ok; my $dir = alien_extract_ok $archive; my $dir = alien_extract_ok $archive, $name; my $dir = alien_extract_ok undef, $name; Makes an extraction attempt and test that a directory results. Returns the directory if successful. Returns C<undef> otherwise. =head2 alien_build_ok my $alien = alien_build_ok; my $alien = alien_build_ok $name; my $alien = alien_build_ok { class => $class }; my $alien = alien_build_ok { class => $class }, $name; Runs the download and build stages. Passes if the build succeeds. Returns an instance of L<Alien::Base> which can be passed into C<alien_ok> from L<Test::Alien>. Returns C<undef> if the test fails. Options =over 4 =item class The base class to use for your alien. This is L<Alien::Base> by default. Should be a subclass of L<Alien::Base>, or at least adhere to its API. =back =head2 alien_build_clean alien_build_clean; Removes all files with the current build, except for the runtime prefix. This helps test that the final install won't depend on the build files. =head2 alien_clean_install alien_clean_install; Runs C<$build-E<gt>clean_install>, and verifies it did not crash. =head2 alien_checkpoint_ok alien_checkpoint_ok; alien_checkpoint_ok $test_name; Test the checkpoint of a build. =head2 alien_resume_ok alien_resume_ok; alien_resume_ok $test_name; Test a resume a checkpointed build. =head2 alien_rc alien_rc $code; Creates C<rc.pl> file in a temp directory and sets ALIEN_BUILD_RC. Useful for testing plugins that should be called from C<~/.alienbuild/rc.pl>. Note that because of the nature of how the C<~/.alienbuild/rc.pl> file works, you can only use this once! =head2 alien_subtest alien_subtest $test_name => sub { ... }; Clear the build object and clear the build object before and after the subtest. =head1 SEE ALSO =over 4 =item L<Alien> =item L<alienfile> =item L<Alien::Build> =item L<Test::Alien> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Alien/Diag.pm 0000444 00000005602 14711217660 0010752 0 ustar 00 package Test::Alien::Diag; use strict; use warnings; use 5.008004; use Test2::API qw( context ); use Exporter qw( import ); our @EXPORT = qw( alien_diag ); our @EXPORT_OK = @EXPORT; # ABSTRACT: Print out standard diagnostic for Aliens in the test step. our $VERSION = '2.41'; # VERSION sub alien_diag ($@) { my $ctx = context(); my $max = 0; foreach my $alien (@_) { foreach my $name (qw( cflags cflags_static libs libs_static version install_type dynamic_libs bin_dir )) { my $str = "$alien->$name"; if(length($str) > $max) { $max = length($str); } } } $ctx->diag(''); foreach my $alien (@_) { $ctx->diag('') for 1..2; my $found = 0; foreach my $name (qw( cflags cflags_static libs libs_static version install_type )) { if(eval { $alien->can($name) }) { $found++; $ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $alien->$name); } } foreach my $name (qw( dynamic_libs bin_dir )) { if(eval { $alien->can($name) }) { $found++; my @list = eval { $alien->$name }; next if $@; $ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $_) for @list; } } $ctx->diag("no diagnostics found for $alien") unless $found; $ctx->diag('') for 1..2; } $ctx->release; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien::Diag - Print out standard diagnostic for Aliens in the test step. =head1 VERSION version 2.41 =head1 SYNOPSIS use Test2::V0; use Test::Alien::Diag qw( alien_diag ); =head1 DESCRIPTION This module provides an C<alien_diag> method that prints out diagnostics useful for cpantesters for other bug reports that gives a quick summary of the important settings like C<clfags> and C<libs>. =head1 FUNCTIONS =head2 alien_diag alien_diag $alien; prints out diagnostics. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Alien/CanPlatypus.pm 0000444 00000003612 14711217660 0012350 0 ustar 00 package Test::Alien::CanPlatypus; use strict; use warnings; use 5.008004; use Test2::API qw( context ); # ABSTRACT: Skip a test file unless FFI::Platypus is available our $VERSION = '2.41'; # VERSION sub skip { eval { require FFI::Platypus; 1 } ? undef : 'This test requires FFI::Platypus.'; } sub import { my $skip = __PACKAGE__->skip; return unless defined $skip; my $ctx = context(); $ctx->plan(0, SKIP => $skip); $ctx->release; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test::Alien::CanPlatypus - Skip a test file unless FFI::Platypus is available =head1 VERSION version 2.41 =head1 SYNOPSIS use Test::Alien::CanPlatypus; =head1 DESCRIPTION This is just a L<Test2> plugin that requires that L<FFI::Platypus> be available. Otherwise the test will be skipped. =head1 SEE ALSO =over 4 =item L<Test::Alien> =item L<FFI::Platypus> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test/Builder.pm 0000444 00000177261 14711217660 0010457 0 ustar 00 package Test::Builder; use 5.006; use strict; use warnings; our $VERSION = '1.302186'; BEGIN { if( $] < 5.008 ) { require Test::Builder::IO::Scalar; } } use Scalar::Util qw/blessed reftype weaken/; use Test2::Util qw/USE_THREADS try get_tid/; use Test2::API qw/context release/; # Make Test::Builder thread-safe for ithreads. BEGIN { warn "Test::Builder was loaded after Test2 initialization, this is not recommended." if Test2::API::test2_init_done() || Test2::API::test2_load_done(); if (USE_THREADS && ! Test2::API::test2_ipc_disabled()) { require Test2::IPC; require Test2::IPC::Driver::Files; Test2::IPC::Driver::Files->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_no_wait(1); } } use Test2::Event::Subtest; use Test2::Hub::Subtest; use Test::Builder::Formatter; use Test::Builder::TodoDiag; our $Level = 1; our $Test = $ENV{TB_NO_EARLY_INIT} ? undef : Test::Builder->new; sub _add_ts_hooks { my $self = shift; my $hub = $self->{Stack}->top; # Take a reference to the hash key, we do this to avoid closing over $self # which is the singleton. We use a reference because the value could change # in rare cases. my $epkgr = \$self->{Exported_To}; #$hub->add_context_aquire(sub {$_[0]->{level} += $Level - 1}); $hub->pre_filter( sub { my ($active_hub, $e) = @_; my $epkg = $$epkgr; my $cpkg = $e->{trace} ? $e->{trace}->{frame}->[0] : undef; no strict 'refs'; no warnings 'once'; my $todo; $todo = ${"$cpkg\::TODO"} if $cpkg; $todo = ${"$epkg\::TODO"} if $epkg && !$todo; return $e unless defined($todo); return $e unless length($todo); # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; $e->set_todo($todo) if $e->can('set_todo'); $e->add_amnesty({tag => 'TODO', details => $todo}); # Set todo on ok's if ($e->isa('Test2::Event::Ok')) { $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $todo; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1, intercept_inherit => { clean => sub { my %params = @_; my $state = $params{state}; my $trace = $params{trace}; my $epkg = $$epkgr; my $cpkg = $trace->{frame}->[0]; no strict 'refs'; no warnings 'once'; $state->{+__PACKAGE__} = {}; $state->{+__PACKAGE__}->{"$cpkg\::TODO"} = ${"$cpkg\::TODO"} if $cpkg; $state->{+__PACKAGE__}->{"$epkg\::TODO"} = ${"$epkg\::TODO"} if $epkg; ${"$cpkg\::TODO"} = undef if $cpkg; ${"$epkg\::TODO"} = undef if $epkg; }, restore => sub { my %params = @_; my $state = $params{state}; no strict 'refs'; no warnings 'once'; for my $item (keys %{$state->{+__PACKAGE__}}) { no strict 'refs'; no warnings 'once'; ${"$item"} = $state->{+__PACKAGE__}->{$item}; } }, }, ); } { no warnings; INIT { use warnings; Test2::API::test2_load() unless Test2::API::test2_in_preload(); } } sub new { my($class) = shift; unless($Test) { $Test = $class->create(singleton => 1); Test2::API::test2_add_callback_post_load( sub { $Test->{Original_Pid} = $$ if !$Test->{Original_Pid} || $Test->{Original_Pid} == 0; $Test->reset(singleton => 1); $Test->_add_ts_hooks; } ); # Non-TB tools normally expect 0 added to the level. $Level is normally 1. So # we only want the level to change if $Level != 1. # TB->ctx compensates for this later. Test2::API::test2_add_callback_context_aquire(sub { $_[0]->{level} += $Level - 1 }); Test2::API::test2_add_callback_exit(sub { $Test->_ending(@_) }); Test2::API::test2_ipc()->set_no_fatal(1) if Test2::API::test2_has_ipc(); } return $Test; } sub create { my $class = shift; my %params = @_; my $self = bless {}, $class; if ($params{singleton}) { $self->{Stack} = Test2::API::test2_stack(); } else { $self->{Stack} = Test2::API::Stack->new; $self->{Stack}->new_hub( formatter => Test::Builder::Formatter->new, ipc => Test2::API::test2_ipc(), ); $self->reset(%params); $self->_add_ts_hooks; } return $self; } sub ctx { my $self = shift; context( # 1 for our frame, another for the -1 off of $Level in our hook at the top. level => 2, fudge => 1, stack => $self->{Stack}, hub => $self->{Hub}, wrapped => 1, @_ ); } sub parent { my $self = shift; my $ctx = $self->ctx; my $chub = $self->{Hub} || $ctx->hub; $ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); my $parent = $meta->{parent}; return undef unless $parent; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $parent, }, blessed($self); } sub child { my( $self, $name ) = @_; $name ||= "Child of " . $self->name; my $ctx = $self->ctx; my $parent = $ctx->hub; my $pmeta = $parent->meta(__PACKAGE__, {}); $self->croak("You already have a child named ($pmeta->{child}) running") if $pmeta->{child}; $pmeta->{child} = $name; # Clear $TODO for the child. my $orig_TODO = $self->find_TODO(undef, 1, undef); my $subevents = []; my $hub = $ctx->stack->new_hub( class => 'Test2::Hub::Subtest', ); $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; return $e; }, inherit => 1) if $orig_TODO; $hub->listen(sub { push @$subevents => $_[1] }); $hub->set_nested( $parent->nested + 1 ); my $meta = $hub->meta(__PACKAGE__, {}); $meta->{Name} = $name; $meta->{TODO} = $orig_TODO; $meta->{TODO_PKG} = $ctx->trace->package; $meta->{parent} = $parent; $meta->{Test_Results} = []; $meta->{subevents} = $subevents; $meta->{subtest_id} = $hub->id; $meta->{subtest_uuid} = $hub->uuid; $meta->{subtest_buffered} = $parent->format ? 0 : 1; $self->_add_ts_hooks; $ctx->release; return bless { Original_Pid => $$, Stack => $self->{Stack}, Hub => $hub, no_log_results => $self->{no_log_results} }, blessed($self); } sub finalize { my $self = shift; my $ok = 1; ($ok) = @_ if @_; my $st_ctx = $self->ctx; my $chub = $self->{Hub} || return $st_ctx->release; my $meta = $chub->meta(__PACKAGE__, {}); if ($meta->{child}) { $self->croak("Can't call finalize() with child ($meta->{child}) active"); } local $? = 0; # don't fail if $subtests happened to set $? nonzero $self->{Stack}->pop($chub); $self->find_TODO($meta->{TODO_PKG}, 1, $meta->{TODO}); my $parent = $self->parent; my $ctx = $parent->ctx; my $trace = $ctx->trace; delete $ctx->hub->meta(__PACKAGE__, {})->{child}; $chub->finalize($trace->snapshot(hid => $chub->hid, nested => $chub->nested), 1) if $ok && $chub->count && !$chub->no_ending && !$chub->ended; my $plan = $chub->plan || 0; my $count = $chub->count; my $failed = $chub->failed; my $passed = $chub->is_passing; my $num_extra = $plan =~ m/\D/ ? 0 : $count - $plan; if ($count && $num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $st_ctx->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $st_ctx->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $st_ctx->diag(<<"FAIL"); All assertions inside the subtest passed, but errors were encountered. FAIL } $st_ctx->release; unless ($chub->bailed_out) { my $plan = $chub->plan; if ( $plan && $plan eq 'SKIP' ) { $parent->skip($chub->skip_reason, $meta->{Name}); } elsif ( !$chub->count ) { $parent->ok( 0, sprintf q[No tests run for subtest "%s"], $meta->{Name} ); } else { $parent->{subevents} = $meta->{subevents}; $parent->{subtest_id} = $meta->{subtest_id}; $parent->{subtest_uuid} = $meta->{subtest_uuid}; $parent->{subtest_buffered} = $meta->{subtest_buffered}; $parent->ok( $chub->is_passing, $meta->{Name} ); } } $ctx->release; return $chub->is_passing; } sub subtest { my $self = shift; my ($name, $code, @args) = @_; my $ctx = $self->ctx; $ctx->throw("subtest()'s second argument must be a code ref") unless $code && reftype($code) eq 'CODE'; $name ||= "Child of " . $self->name; $_->($name,$code,@args) for Test2::API::test2_list_pre_subtest_callbacks(); $ctx->note("Subtest: $name"); my $child = $self->child($name); my $start_pid = $$; my $st_ctx; my ($ok, $err, $finished, $child_error); T2_SUBTEST_WRAPPER: { my $ctx = $self->ctx; $st_ctx = $ctx->snapshot; $ctx->release; $ok = eval { local $Level = 1; $code->(@args); 1 }; ($err, $child_error) = ($@, $?); # They might have done 'BEGIN { skip_all => "whatever" }' if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) { $ok = undef; $err = undef; } else { $finished = 1; } } if ($start_pid != $$ && !$INC{'Test2/IPC.pm'}) { warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err; exit 255; } my $trace = $ctx->trace; if (!$finished) { if(my $bailed = $st_ctx->hub->bailed_out) { my $chub = $child->{Hub}; $self->{Stack}->pop($chub); $ctx->bail($bailed->reason); } my $code = $st_ctx->hub->exit_code; $ok = !$code; $err = "Subtest ended with exit code $code" if $code; } my $st_hub = $st_ctx->hub; my $plan = $st_hub->plan; my $count = $st_hub->count; if (!$count && (!defined($plan) || "$plan" ne 'SKIP')) { $st_ctx->plan(0) unless defined $plan; $st_ctx->diag('No tests run!'); } $child->finalize($st_ctx->trace); $ctx->release; die $err unless $ok; $? = $child_error if defined $child_error; return $st_hub->is_passing; } sub name { my $self = shift; my $ctx = $self->ctx; release $ctx, $ctx->hub->meta(__PACKAGE__, {})->{Name}; } sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my ($self, %params) = @_; Test2::API::test2_unset_is_end(); # We leave this a global because it has to be localized and localizing # hash keys is just asking for pain. Also, it was documented. $Level = 1; $self->{no_log_results} = $ENV{TEST_NO_LOG_RESULTS} ? 1 : 0 unless $params{singleton}; $self->{Original_Pid} = Test2::API::test2_in_preload() ? -1 : $$; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->release; unless ($params{singleton}) { $hub->reset_state(); $hub->_tb_reset(); } $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); %$meta = ( Name => $0, Ending => 0, Done_Testing => undef, Skip_All => 0, Test_Results => [], parent => $meta->{parent}, ); $self->{Exported_To} = undef unless $params{singleton}; $self->{Orig_Handles} ||= do { my $format = $ctx->hub->format; my $out; if ($format && $format->isa('Test2::Formatter::TAP')) { $out = $format->handles; } $out ? [@$out] : []; }; $self->use_numbers(1); $self->no_header(0) unless $params{singleton}; $self->no_ending(0) unless $params{singleton}; $self->reset_outputs; $ctx->release; return; } my %plan_cmds = ( no_plan => \&no_plan, skip_all => \&skip_all, tests => \&_plan_tests, ); sub plan { my( $self, $cmd, $arg ) = @_; return unless $cmd; my $ctx = $self->ctx; my $hub = $ctx->hub; $ctx->throw("You tried to plan twice") if $hub->plan; local $Level = $Level + 1; if( my $method = $plan_cmds{$cmd} ) { local $Level = $Level + 1; $self->$method($arg); } else { my @args = grep { defined } ( $cmd, $arg ); $ctx->throw("plan() doesn't understand @args"); } release $ctx, 1; } sub _plan_tests { my($self, $arg) = @_; my $ctx = $self->ctx; if($arg) { local $Level = $Level + 1; $self->expected_tests($arg); } elsif( !defined $arg ) { $ctx->throw("Got an undefined number of tests"); } else { $ctx->throw("You said to run 0 tests"); } $ctx->release; } sub expected_tests { my $self = shift; my($max) = @_; my $ctx = $self->ctx; if(@_) { $self->croak("Number of tests must be a positive integer. You gave it '$max'") unless $max =~ /^\+?\d+$/; $ctx->plan($max); } my $hub = $ctx->hub; $ctx->release; my $plan = $hub->plan; return 0 unless $plan; return 0 if $plan =~ m/\D/; return $plan; } sub no_plan { my($self, $arg) = @_; my $ctx = $self->ctx; if (defined $ctx->hub->plan) { warn "Plan already set, no_plan() is a no-op, this will change to a hard failure in the future."; $ctx->release; return; } $ctx->alert("no_plan takes no arguments") if $arg; $ctx->hub->plan('NO PLAN'); release $ctx, 1; } sub done_testing { my($self, $num_tests) = @_; my $ctx = $self->ctx; my $meta = $ctx->hub->meta(__PACKAGE__, {}); if ($meta->{Done_Testing}) { my ($file, $line) = @{$meta->{Done_Testing}}[1,2]; local $ctx->hub->{ended}; # OMG This is awful. $self->ok(0, "done_testing() was already called at $file line $line"); $ctx->release; return; } $meta->{Done_Testing} = [$ctx->trace->call]; my $plan = $ctx->hub->plan; my $count = $ctx->hub->count; # If done_testing() specified the number of tests, shut off no_plan if( defined $num_tests ) { $ctx->plan($num_tests) if !$plan || $plan eq 'NO PLAN'; } elsif ($count && defined $num_tests && $count != $num_tests) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} but done_testing() expects $num_tests"); } else { $num_tests = $self->current_test; } if( $self->expected_tests && $num_tests != $self->expected_tests ) { $self->ok(0, "planned to run @{[ $self->expected_tests ]} ". "but done_testing() expects $num_tests"); } $ctx->plan($num_tests) if $ctx->hub->plan && $ctx->hub->plan eq 'NO PLAN'; $ctx->hub->finalize($ctx->trace, 1); release $ctx, 1; } sub has_plan { my $self = shift; my $ctx = $self->ctx; my $plan = $ctx->hub->plan; $ctx->release; return( $plan ) if $plan && $plan !~ m/\D/; return('no_plan') if $plan && $plan eq 'NO PLAN'; return(undef); } sub skip_all { my( $self, $reason ) = @_; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Skip_All} = $reason || 1; # Work around old perl bug if ($] < 5.020000) { my $begin = 0; my $level = 0; while (my @call = caller($level++)) { last unless @call && $call[0]; next unless $call[3] =~ m/::BEGIN$/; $begin++; last; } # HACK! die 'Label not found for "last T2_SUBTEST_WRAPPER"' if $begin && $ctx->hub->meta(__PACKAGE__, {})->{parent}; } $reason = "$reason" if defined $reason; $ctx->plan(0, SKIP => $reason); } sub exported_to { my( $self, $pack ) = @_; if( defined $pack ) { $self->{Exported_To} = $pack; } return $self->{Exported_To}; } sub ok { my( $self, $test, $name ) = @_; my $ctx = $self->ctx; # $test might contain an object which we don't want to accidentally # store, so we turn it into a boolean. $test = $test ? 1 : 0; # In case $name is a string overloaded object, force it to stringify. no warnings qw/uninitialized numeric/; $name = "$name" if defined $name; # Profiling showed that the regex here was a huge time waster, doing the # numeric addition first cuts our profile time from ~300ms to ~50ms $self->diag(<<" ERR") if 0 + $name && $name =~ /^[\d\s]+$/; You named your test '$name'. You shouldn't use numbers for your test names. Very confusing. ERR use warnings qw/uninitialized numeric/; my $trace = $ctx->{trace}; my $hub = $ctx->{hub}; my $result = { ok => $test, actual_ok => $test, reason => '', type => '', (name => defined($name) ? $name : ''), }; $hub->{_meta}->{+__PACKAGE__}->{Test_Results}[ $hub->{count} ] = $result unless $self->{no_log_results}; my $orig_name = $name; my @attrs; my $subevents = delete $self->{subevents}; my $subtest_id = delete $self->{subtest_id}; my $subtest_uuid = delete $self->{subtest_uuid}; my $subtest_buffered = delete $self->{subtest_buffered}; my $epkg = 'Test2::Event::Ok'; if ($subevents) { $epkg = 'Test2::Event::Subtest'; push @attrs => (subevents => $subevents, subtest_id => $subtest_id, subtest_uuid => $subtest_uuid, buffered => $subtest_buffered); } my $e = bless { trace => bless( {%$trace}, 'Test2::EventFacet::Trace'), pass => $test, name => $name, _meta => {'Test::Builder' => $result}, effective_pass => $test, @attrs, }, $epkg; $hub->send($e); $self->_ok_debug($trace, $orig_name) unless($test); $ctx->release; return $test; } sub _ok_debug { my $self = shift; my ($trace, $orig_name) = @_; my $is_todo = $self->in_todo; my $msg = $is_todo ? "Failed (TODO)" : "Failed"; my (undef, $file, $line) = $trace->call; if (defined $orig_name) { $self->diag(qq[ $msg test '$orig_name'\n at $file line $line.\n]); } else { $self->diag(qq[ $msg test at $file line $line.\n]); } } sub _diag_fh { my $self = shift; local $Level = $Level + 1; return $self->in_todo ? $self->todo_output : $self->failure_output; } sub _unoverload { my ($self, $type, $thing) = @_; return unless ref $$thing; return unless blessed($$thing) || scalar $self->_try(sub{ $$thing->isa('UNIVERSAL') }); { local ($!, $@); require overload; } my $string_meth = overload::Method( $$thing, $type ) || return; $$thing = $$thing->$string_meth(); } sub _unoverload_str { my $self = shift; $self->_unoverload( q[""], $_ ) for @_; } sub _unoverload_num { my $self = shift; $self->_unoverload( '0+', $_ ) for @_; for my $val (@_) { next unless $self->_is_dualvar($$val); $$val = $$val + 0; } } # This is a hack to detect a dualvar such as $! sub _is_dualvar { my( $self, $val ) = @_; # Objects are not dualvars. return 0 if ref $val; no warnings 'numeric'; my $numval = $val + 0; return ($numval != 0 and $numval ne $val ? 1 : 0); } sub is_eq { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, 'eq', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'eq', $expect, $name ); } sub is_num { my( $self, $got, $expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $expect ) { # undef only matches undef and nothing else my $test = !defined $got && !defined $expect; $self->ok( $test, $name ); $self->_is_diag( $got, '==', $expect ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '==', $expect, $name ); } sub _diag_fmt { my( $self, $type, $val ) = @_; if( defined $$val ) { if( $type eq 'eq' or $type eq 'ne' ) { # quote and force string context $$val = "'$$val'"; } else { # force numeric context $self->_unoverload_num($val); } } else { $$val = 'undef'; } return; } sub _is_diag { my( $self, $got, $type, $expect ) = @_; $self->_diag_fmt( $type, $_ ) for \$got, \$expect; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: $expect DIAGNOSTIC } sub _isnt_diag { my( $self, $got, $type ) = @_; $self->_diag_fmt( $type, \$got ); local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); got: $got expected: anything else DIAGNOSTIC } sub isnt_eq { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, 'ne' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, 'ne', $dont_expect, $name ); } sub isnt_num { my( $self, $got, $dont_expect, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; if( !defined $got || !defined $dont_expect ) { # undef only matches undef and nothing else my $test = defined $got || defined $dont_expect; $self->ok( $test, $name ); $self->_isnt_diag( $got, '!=' ) unless $test; $ctx->release; return $test; } release $ctx, $self->cmp_ok( $got, '!=', $dont_expect, $name ); } sub like { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '=~', $name ); } sub unlike { my( $self, $thing, $regex, $name ) = @_; my $ctx = $self->ctx; local $Level = $Level + 1; release $ctx, $self->_regex_ok( $thing, $regex, '!~', $name ); } my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" ); # Bad, these are not comparison operators. Should we include more? my %cmp_ok_bl = map { ( $_, 1 ) } ( "=", "+=", ".=", "x=", "^=", "|=", "||=", "&&=", "..."); sub cmp_ok { my( $self, $got, $type, $expect, $name ) = @_; my $ctx = $self->ctx; if ($cmp_ok_bl{$type}) { $ctx->throw("$type is not a valid comparison operator in cmp_ok()"); } my ($test, $succ); my $error; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval my($pack, $file, $line) = $ctx->trace->call(); my $warning_bits = $ctx->trace->warning_bits; # convert this to a code string so the BEGIN doesn't have to close # over it, which can lead to issues with Devel::Cover my $bits_code = defined $warning_bits ? qq["\Q$warning_bits\E"] : 'undef'; # This is so that warnings come out at the caller's level $succ = eval qq[ BEGIN {\${^WARNING_BITS} = $bits_code}; #line $line "(eval in cmp_ok) $file" \$test = (\$got $type \$expect); 1; ]; $error = $@; } local $Level = $Level + 1; my $ok = $self->ok( $test, $name ); # Treat overloaded objects as numbers if we're asked to do a # numeric comparison. my $unoverload = $numeric_cmps{$type} ? '_unoverload_num' : '_unoverload_str'; $self->diag(<<"END") unless $succ; An error occurred while using $type: ------------------------------------ $error ------------------------------------ END unless($ok) { $self->$unoverload( \$got, \$expect ); if( $type =~ /^(eq|==)$/ ) { $self->_is_diag( $got, $type, $expect ); } elsif( $type =~ /^(ne|!=)$/ ) { no warnings; my $eq = ($got eq $expect || $got == $expect) && ( (defined($got) xor defined($expect)) || (length($got) != length($expect)) ); use warnings; if ($eq) { $self->_cmp_diag( $got, $type, $expect ); } else { $self->_isnt_diag( $got, $type ); } } else { $self->_cmp_diag( $got, $type, $expect ); } } return release $ctx, $ok; } sub _cmp_diag { my( $self, $got, $type, $expect ) = @_; $got = defined $got ? "'$got'" : 'undef'; $expect = defined $expect ? "'$expect'" : 'undef'; local $Level = $Level + 1; return $self->diag(<<"DIAGNOSTIC"); $got $type $expect DIAGNOSTIC } sub _caller_context { my $self = shift; my( $pack, $file, $line ) = $self->caller(1); my $code = ''; $code .= "#line $line $file\n" if defined $file and defined $line; return $code; } sub BAIL_OUT { my( $self, $reason ) = @_; my $ctx = $self->ctx; $self->{Bailed_Out} = 1; $ctx->bail($reason); } { no warnings 'once'; *BAILOUT = \&BAIL_OUT; } sub skip { my( $self, $why, $name ) = @_; $why ||= ''; $name = '' unless defined $name; $self->_unoverload_str( \$why ); my $ctx = $self->ctx; $name = "$name"; $why = "$why"; $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. $name =~ s{\n}{\n# }sg; $why =~ s{\n}{\n# }sg; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 1, name => $name, type => 'skip', reason => $why, } unless $self->{no_log_results}; my $tctx = $ctx->snapshot; $tctx->skip('', $why); return release $ctx, 1; } sub todo_skip { my( $self, $why ) = @_; $why ||= ''; my $ctx = $self->ctx; $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}[ $ctx->hub->count ] = { 'ok' => 1, actual_ok => 0, name => '', type => 'todo_skip', reason => $why, } unless $self->{no_log_results}; $why =~ s{\n}{\n# }sg; my $tctx = $ctx->snapshot; $tctx->send_event( 'Skip', todo => $why, todo_diag => 1, reason => $why, pass => 0); return release $ctx, 1; } sub maybe_regex { my( $self, $regex ) = @_; my $usable_regex = undef; return $usable_regex unless defined $regex; my( $re, $opts ); # Check for qr/foo/ if( _is_qr($regex) ) { $usable_regex = $regex; } # Check for '/foo/' or 'm,foo,' elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx ) { $usable_regex = length $opts ? "(?$opts)$re" : $re; } return $usable_regex; } sub _is_qr { my $regex = shift; # is_regexp() checks for regexes in a robust manner, say if they're # blessed. return re::is_regexp($regex) if defined &re::is_regexp; return ref $regex eq 'Regexp'; } sub _regex_ok { my( $self, $thing, $regex, $cmp, $name ) = @_; my $ok = 0; my $usable_regex = $self->maybe_regex($regex); unless( defined $usable_regex ) { local $Level = $Level + 1; $ok = $self->ok( 0, $name ); $self->diag(" '$regex' doesn't look much like a regex to me."); return $ok; } { my $test; my $context = $self->_caller_context; { ## no critic (BuiltinFunctions::ProhibitStringyEval) local( $@, $!, $SIG{__DIE__} ); # isolate eval # No point in issuing an uninit warning, they'll see it in the diagnostics no warnings 'uninitialized'; $test = eval $context . q{$test = $thing =~ /$usable_regex/ ? 1 : 0}; } $test = !$test if $cmp eq '!~'; local $Level = $Level + 1; $ok = $self->ok( $test, $name ); } unless($ok) { $thing = defined $thing ? "'$thing'" : 'undef'; my $match = $cmp eq '=~' ? "doesn't match" : "matches"; local $Level = $Level + 1; $self->diag( sprintf <<'DIAGNOSTIC', $thing, $match, $regex ); %s %13s '%s' DIAGNOSTIC } return $ok; } sub is_fh { my $self = shift; my $maybe_fh = shift; return 0 unless defined $maybe_fh; return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob return eval { $maybe_fh->isa("IO::Handle") } || eval { tied($maybe_fh)->can('TIEHANDLE') }; } sub level { my( $self, $level ) = @_; if( defined $level ) { $Level = $level; } return $Level; } sub use_numbers { my( $self, $use_nums ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can('no_numbers') && $format->can('set_no_numbers')) { warn "The current formatter does not support 'use_numbers'" if $format; return release $ctx, 0; } $format->set_no_numbers(!$use_nums) if defined $use_nums; return release $ctx, $format->no_numbers ? 0 : 1; } BEGIN { for my $method (qw(no_header no_diag)) { my $set = "set_$method"; my $code = sub { my( $self, $no ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; unless ($format && $format->can($set)) { warn "The current formatter does not support '$method'" if $format; $ctx->release; return } $format->$set($no) if defined $no; return release $ctx, $format->$method ? 1 : 0; }; no strict 'refs'; ## no critic *$method = $code; } } sub no_ending { my( $self, $no ) = @_; my $ctx = $self->ctx; $ctx->hub->set_no_ending($no) if defined $no; return release $ctx, $ctx->hub->no_ending; } sub diag { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDERR $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->diag($text); $ctx->release; return 0; } sub note { my $self = shift; return unless @_; my $text = join '' => map {defined($_) ? $_ : 'undef'} @_; if (Test2::API::test2_in_preload()) { chomp($text); $text =~ s/^/# /msg; print STDOUT $text, "\n"; return 0; } my $ctx = $self->ctx; $ctx->note($text); $ctx->release; return 0; } sub explain { my $self = shift; local ($@, $!); require Data::Dumper; return map { ref $_ ? do { my $dumper = Data::Dumper->new( [$_] ); $dumper->Indent(1)->Terse(1); $dumper->Sortkeys(1) if $dumper->can("Sortkeys"); $dumper->Dump; } : $_ } @_; } sub output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_STD()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_STD()]; } sub failure_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->handles->[Test2::Formatter::TAP::OUT_ERR()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test2::Formatter::TAP::OUT_ERR()]; } sub todo_output { my( $self, $fh ) = @_; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test::Builder::Formatter'); $format->handles->[Test::Builder::Formatter::OUT_TODO()] = $self->_new_fh($fh) if defined $fh; return $format->handles->[Test::Builder::Formatter::OUT_TODO()]; } sub _new_fh { my $self = shift; my($file_or_fh) = shift; my $fh; if( $self->is_fh($file_or_fh) ) { $fh = $file_or_fh; } elsif( ref $file_or_fh eq 'SCALAR' ) { # Scalar refs as filehandles was added in 5.8. if( $] >= 5.008 ) { open $fh, ">>", $file_or_fh or $self->croak("Can't open scalar ref $file_or_fh: $!"); } # Emulate scalar ref filehandles with a tie. else { $fh = Test::Builder::IO::Scalar->new($file_or_fh) or $self->croak("Can't tie scalar ref $file_or_fh"); } } else { open $fh, ">", $file_or_fh or $self->croak("Can't open test output log $file_or_fh: $!"); _autoflush($fh); } return $fh; } sub _autoflush { my($fh) = shift; my $old_fh = select $fh; $| = 1; select $old_fh; return; } sub reset_outputs { my $self = shift; my $ctx = $self->ctx; my $format = $ctx->hub->format; $ctx->release; return unless $format && $format->isa('Test2::Formatter::TAP'); $format->set_handles([@{$self->{Orig_Handles}}]) if $self->{Orig_Handles}; return; } sub carp { my $self = shift; my $ctx = $self->ctx; $ctx->alert(join "", @_); $ctx->release; } sub croak { my $self = shift; my $ctx = $self->ctx; $ctx->throw(join "", @_); $ctx->release; } sub current_test { my( $self, $num ) = @_; my $ctx = $self->ctx; my $hub = $ctx->hub; if( defined $num ) { $hub->set_count($num); unless ($self->{no_log_results}) { # If the test counter is being pushed forward fill in the details. my $test_results = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; if ($num > @$test_results) { my $start = @$test_results ? @$test_results : 0; for ($start .. $num - 1) { $test_results->[$_] = { 'ok' => 1, actual_ok => undef, reason => 'incrementing test number', type => 'unknown', name => undef }; } } # If backward, wipe history. Its their funeral. elsif ($num < @$test_results) { $#{$test_results} = $num - 1; } } } return release $ctx, $hub->count; } sub is_passing { my $self = shift; my $ctx = $self->ctx; my $hub = $ctx->hub; if( @_ ) { my ($bool) = @_; $hub->set_failed(0) if $bool; $hub->is_passing($bool); } return release $ctx, $hub->is_passing; } sub summary { my($self) = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return map { $_ ? $_->{'ok'} : () } @$data; } sub details { my $self = shift; return if $self->{no_log_results}; my $ctx = $self->ctx; my $data = $ctx->hub->meta(__PACKAGE__, {})->{Test_Results}; $ctx->release; return @$data; } sub find_TODO { my( $self, $pack, $set, $new_value ) = @_; my $ctx = $self->ctx; $pack ||= $ctx->trace->package || $self->exported_to; $ctx->release; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; my $old_value = ${ $pack . '::TODO' }; $set and ${ $pack . '::TODO' } = $new_value; return $old_value; } sub todo { my( $self, $pack ) = @_; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return $meta->[-1]->[1] if $meta && @$meta; $pack ||= $ctx->trace->package; return unless $pack; no strict 'refs'; ## no critic no warnings 'once'; return ${ $pack . '::TODO' }; } sub in_todo { my $self = shift; local $Level = $Level + 1; my $ctx = $self->ctx; $ctx->release; my $meta = $ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}; return 1 if $meta && @$meta; my $pack = $ctx->trace->package || return 0; no strict 'refs'; ## no critic no warnings 'once'; my $todo = ${ $pack . '::TODO' }; return 0 unless defined $todo; return 0 if "$todo" eq ''; return 1; } sub todo_start { my $self = shift; my $message = @_ ? shift : ''; my $ctx = $self->ctx; my $hub = $ctx->hub; my $filter = $hub->pre_filter(sub { my ($active_hub, $e) = @_; # Turn a diag into a todo diag return Test::Builder::TodoDiag->new(%$e) if ref($e) eq 'Test2::Event::Diag'; # Set todo on ok's if ($hub == $active_hub && $e->isa('Test2::Event::Ok')) { $e->set_todo($message); $e->set_effective_pass(1); if (my $result = $e->get_meta(__PACKAGE__)) { $result->{reason} ||= $message; $result->{type} ||= 'todo'; $result->{ok} = 1; } } return $e; }, inherit => 1); push @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}} => [$filter, $message]; $ctx->release; return; } sub todo_end { my $self = shift; my $ctx = $self->ctx; my $set = pop @{$ctx->hub->meta(__PACKAGE__, {todo => []})->{todo}}; $ctx->throw('todo_end() called without todo_start()') unless $set; $ctx->hub->pre_unfilter($set->[0]); $ctx->release; return; } sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my( $self ) = @_; my $ctx = $self->ctx; my $trace = $ctx->trace; $ctx->release; return wantarray ? $trace->call : $trace->package; } sub _try { my( $self, $code, %opts ) = @_; my $error; my $return; { local $!; # eval can mess up $! local $@; # don't set $@ in the test local $SIG{__DIE__}; # don't trip an outside DIE handler. $return = eval { $code->() }; $error = $@; } die $error if $error and $opts{die_on_fail}; return wantarray ? ( $return, $error ) : $return; } sub _ending { my $self = shift; my ($ctx, $real_exit_code, $new) = @_; unless ($ctx) { my $octx = $self->ctx; $ctx = $octx->snapshot; $octx->release; } return if $ctx->hub->no_ending; return if $ctx->hub->meta(__PACKAGE__, {})->{Ending}++; # Don't bother with an ending if this is a forked copy. Only the parent # should do the ending. return unless $self->{Original_Pid} == $$; my $hub = $ctx->hub; return if $hub->bailed_out; my $plan = $hub->plan; my $count = $hub->count; my $failed = $hub->failed; my $passed = $hub->is_passing; return unless $plan || $count || $failed; # Ran tests but never declared a plan or hit done_testing if( !$hub->plan and $hub->count ) { $self->diag("Tests were run but no plan was declared and done_testing() was not seen."); if($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } # But if the tests ran, handle exit code. if($failed > 0) { my $exit_code = $failed <= 254 ? $failed : 254; $$new ||= $exit_code; return; } $$new ||= 254; return; } if ($real_exit_code && !$count) { $self->diag("Looks like your test exited with $real_exit_code before it could output anything."); $$new ||= $real_exit_code; return; } return if $plan && "$plan" eq 'SKIP'; if (!$count) { $self->diag('No tests run!'); $$new ||= 255; return; } if ($real_exit_code) { $self->diag(<<"FAIL"); Looks like your test exited with $real_exit_code just after $count. FAIL $$new ||= $real_exit_code; return; } if ($plan eq 'NO PLAN') { $ctx->plan( $count ); $plan = $hub->plan; } # Figure out if we passed or failed and print helpful messages. my $num_extra = $count - $plan; if ($num_extra != 0) { my $s = $plan == 1 ? '' : 's'; $self->diag(<<"FAIL"); Looks like you planned $plan test$s but ran $count. FAIL } if ($failed) { my $s = $failed == 1 ? '' : 's'; my $qualifier = $num_extra == 0 ? '' : ' run'; $self->diag(<<"FAIL"); Looks like you failed $failed test$s of $count$qualifier. FAIL } if (!$passed && !$failed && $count && !$num_extra) { $ctx->diag(<<"FAIL"); All assertions passed, but errors were encountered. FAIL } my $exit_code = 0; if ($failed) { $exit_code = $failed <= 254 ? $failed : 254; } elsif ($num_extra != 0) { $exit_code = 255; } elsif (!$passed) { $exit_code = 255; } $$new ||= $exit_code; return; } # Some things used this even though it was private... I am looking at you # Test::Builder::Prefix... sub _print_comment { my( $self, $fh, @msgs ) = @_; return if $self->no_diag; return unless @msgs; # Prevent printing headers when compiling (i.e. -c) return if $^C; # Smash args together like print does. # Convert undef to 'undef' so its readable. my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs; # Escape the beginning, _print will take care of the rest. $msg =~ s/^/# /; local( $\, $", $, ) = ( undef, ' ', '' ); print $fh $msg; return 0; } # This is used by Test::SharedFork to turn on IPC after the fact. Not # documenting because I do not want it used. The method name is borrowed from # Test::Builder 2 # Once Test2 stuff goes stable this method will be removed and Test::SharedFork # will be made smarter. sub coordinate_forks { my $self = shift; { local ($@, $!); require Test2::IPC; } Test2::IPC->import; Test2::API::test2_ipc_enable_polling(); Test2::API::test2_load(); my $ipc = Test2::IPC::apply_ipc($self->{Stack}); $ipc->set_no_fatal(1); Test2::API::test2_no_wait(1); } sub no_log_results { $_[0]->{no_log_results} = 1 } 1; __END__ =head1 NAME Test::Builder - Backend for building test libraries =head1 SYNOPSIS package My::Test::Module; use base 'Test::Builder::Module'; my $CLASS = __PACKAGE__; sub ok { my($test, $name) = @_; my $tb = $CLASS->builder; $tb->ok($test, $name); } =head1 DESCRIPTION L<Test::Simple> and L<Test::More> have proven to be popular testing modules, but they're not always flexible enough. Test::Builder provides a building block upon which to write your own test libraries I<which can work together>. =head2 Construction =over 4 =item B<new> my $Test = Test::Builder->new; Returns a Test::Builder object representing the current state of the test. Since you only run one test per program C<new> always returns the same Test::Builder object. No matter how many times you call C<new()>, you're getting the same object. This is called a singleton. This is done so that multiple modules share such global information as the test counter and where test output is going. If you want a completely new Test::Builder object different from the singleton, use C<create>. =item B<create> my $Test = Test::Builder->create; Ok, so there can be more than one Test::Builder object and this is how you get it. You might use this instead of C<new()> if you're testing a Test::Builder based module, but otherwise you probably want C<new>. B<NOTE>: the implementation is not complete. C<level>, for example, is still shared by B<all> Test::Builder objects, even ones created using this method. Also, the method name may change in the future. =item B<subtest> $builder->subtest($name, \&subtests, @args); See documentation of C<subtest> in Test::More. C<subtest> also, and optionally, accepts arguments which will be passed to the subtests reference. =item B<name> diag $builder->name; Returns the name of the current builder. Top level builders default to C<$0> (the name of the executable). Child builders are named via the C<child> method. If no name is supplied, will be named "Child of $parent->name". =item B<reset> $Test->reset; Reinitializes the Test::Builder singleton to its original state. Mostly useful for tests run in persistent environments where the same test might be run multiple times in the same process. =back =head2 Setting up tests These methods are for setting up tests and declaring how many there are. You usually only want to call one of these methods. =over 4 =item B<plan> $Test->plan('no_plan'); $Test->plan( skip_all => $reason ); $Test->plan( tests => $num_tests ); A convenient way to set up your tests. Call this and Test::Builder will print the appropriate headers and take the appropriate actions. If you call C<plan()>, don't call any of the other methods below. =item B<expected_tests> my $max = $Test->expected_tests; $Test->expected_tests($max); Gets/sets the number of tests we expect this test to run and prints out the appropriate headers. =item B<no_plan> $Test->no_plan; Declares that this test will run an indeterminate number of tests. =item B<done_testing> $Test->done_testing(); $Test->done_testing($num_tests); Declares that you are done testing, no more tests will be run after this point. If a plan has not yet been output, it will do so. $num_tests is the number of tests you planned to run. If a numbered plan was already declared, and if this contradicts, a failing test will be run to reflect the planning mistake. If C<no_plan> was declared, this will override. If C<done_testing()> is called twice, the second call will issue a failing test. If C<$num_tests> is omitted, the number of tests run will be used, like no_plan. C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but safer. You'd use it like so: $Test->ok($a == $b); $Test->done_testing(); Or to plan a variable number of tests: for my $test (@tests) { $Test->ok($test); } $Test->done_testing(scalar @tests); =item B<has_plan> $plan = $Test->has_plan Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests). =item B<skip_all> $Test->skip_all; $Test->skip_all($reason); Skips all the tests, using the given C<$reason>. Exits immediately with 0. =item B<exported_to> my $pack = $Test->exported_to; $Test->exported_to($pack); Tells Test::Builder what package you exported your functions to. This method isn't terribly useful since modules which share the same Test::Builder object might get exported to different packages and only the last one will be honored. =back =head2 Running tests These actually run the tests, analogous to the functions in Test::More. They all return true if the test passed, false if the test failed. C<$name> is always optional. =over 4 =item B<ok> $Test->ok($test, $name); Your basic test. Pass if C<$test> is true, fail if $test is false. Just like Test::Simple's C<ok()>. =item B<is_eq> $Test->is_eq($got, $expected, $name); Like Test::More's C<is()>. Checks if C<$got eq $expected>. This is the string version. C<undef> only ever matches another C<undef>. =item B<is_num> $Test->is_num($got, $expected, $name); Like Test::More's C<is()>. Checks if C<$got == $expected>. This is the numeric version. C<undef> only ever matches another C<undef>. =item B<isnt_eq> $Test->isnt_eq($got, $dont_expect, $name); Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is the string version. =item B<isnt_num> $Test->isnt_num($got, $dont_expect, $name); Like L<Test::More>'s C<isnt()>. Checks if C<$got ne $dont_expect>. This is the numeric version. =item B<like> $Test->like($thing, qr/$regex/, $name); $Test->like($thing, '/$regex/', $name); Like L<Test::More>'s C<like()>. Checks if $thing matches the given C<$regex>. =item B<unlike> $Test->unlike($thing, qr/$regex/, $name); $Test->unlike($thing, '/$regex/', $name); Like L<Test::More>'s C<unlike()>. Checks if $thing B<does not match> the given C<$regex>. =item B<cmp_ok> $Test->cmp_ok($thing, $type, $that, $name); Works just like L<Test::More>'s C<cmp_ok()>. $Test->cmp_ok($big_num, '!=', $other_big_num); =back =head2 Other Testing Methods These are methods which are used in the course of writing a test but are not themselves tests. =over 4 =item B<BAIL_OUT> $Test->BAIL_OUT($reason); Indicates to the L<Test::Harness> that things are going so badly all testing should terminate. This includes running any additional test scripts. It will exit with 255. =for deprecated BAIL_OUT() used to be BAILOUT() =item B<skip> $Test->skip; $Test->skip($why); Skips the current test, reporting C<$why>. =item B<todo_skip> $Test->todo_skip; $Test->todo_skip($why); Like C<skip()>, only it will declare the test as failing and TODO. Similar to print "not ok $tnum # TODO $why\n"; =begin _unimplemented =item B<skip_rest> $Test->skip_rest; $Test->skip_rest($reason); Like C<skip()>, only it skips all the rest of the tests you plan to run and terminates the test. If you're running under C<no_plan>, it skips once and terminates the test. =end _unimplemented =back =head2 Test building utility methods These methods are useful when writing your own test methods. =over 4 =item B<maybe_regex> $Test->maybe_regex(qr/$regex/); $Test->maybe_regex('/$regex/'); This method used to be useful back when Test::Builder worked on Perls before 5.6 which didn't have qr//. Now its pretty useless. Convenience method for building testing functions that take regular expressions as arguments. Takes a quoted regular expression produced by C<qr//>, or a string representing a regular expression. Returns a Perl value which may be used instead of the corresponding regular expression, or C<undef> if its argument is not recognized. For example, a version of C<like()>, sans the useful diagnostic messages, could be written as: sub laconic_like { my ($self, $thing, $regex, $name) = @_; my $usable_regex = $self->maybe_regex($regex); die "expecting regex, found '$regex'\n" unless $usable_regex; $self->ok($thing =~ m/$usable_regex/, $name); } =item B<is_fh> my $is_fh = $Test->is_fh($thing); Determines if the given C<$thing> can be used as a filehandle. =cut =back =head2 Test style =over 4 =item B<level> $Test->level($how_high); How far up the call stack should C<$Test> look when reporting where the test failed. Defaults to 1. Setting C<$Test::Builder::Level> overrides. This is typically useful localized: sub my_ok { my $test = shift; local $Test::Builder::Level = $Test::Builder::Level + 1; $TB->ok($test); } To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant. =item B<use_numbers> $Test->use_numbers($on_or_off); Whether or not the test should output numbers. That is, this if true: ok 1 ok 2 ok 3 or this if false ok ok ok Most useful when you can't depend on the test output order, such as when threads or forking is involved. Defaults to on. =item B<no_diag> $Test->no_diag($no_diag); If set true no diagnostics will be printed. This includes calls to C<diag()>. =item B<no_ending> $Test->no_ending($no_ending); Normally, Test::Builder does some extra diagnostics when the test ends. It also changes the exit code as described below. If this is true, none of that will be done. =item B<no_header> $Test->no_header($no_header); If set to true, no "1..N" header will be printed. =back =head2 Output Controlling where the test output goes. It's ok for your test to change where STDOUT and STDERR point to, Test::Builder's default output settings will not be affected. =over 4 =item B<diag> $Test->diag(@msgs); Prints out the given C<@msgs>. Like C<print>, arguments are simply appended together. Normally, it uses the C<failure_output()> handle, but if this is for a TODO test, the C<todo_output()> handle is used. Output will be indented and marked with a # so as not to interfere with test output. A newline will be put on the end if there isn't one already. We encourage using this rather than calling print directly. Returns false. Why? Because C<diag()> is often used in conjunction with a failing test (C<ok() || diag()>) it "passes through" the failure. return ok(...) || diag(...); =for blame transfer Mark Fowler <mark@twoshortplanks.com> =item B<note> $Test->note(@msgs); Like C<diag()>, but it prints to the C<output()> handle so it will not normally be seen by the user except in verbose mode. =item B<explain> my @dump = $Test->explain(@msgs); Will dump the contents of any references in a human readable format. Handy for things like... is_deeply($have, $want) || diag explain $have; or is_deeply($have, $want) || note explain $have; =item B<output> =item B<failure_output> =item B<todo_output> my $filehandle = $Test->output; $Test->output($filehandle); $Test->output($filename); $Test->output(\$scalar); These methods control where Test::Builder will print its output. They take either an open C<$filehandle>, a C<$filename> to open and write to or a C<$scalar> reference to append to. It will always return a C<$filehandle>. B<output> is where normal "ok/not ok" test output goes. Defaults to STDOUT. B<failure_output> is where diagnostic output on test failures and C<diag()> goes. It is normally not read by Test::Harness and instead is displayed to the user. Defaults to STDERR. C<todo_output> is used instead of C<failure_output()> for the diagnostics of a failing TODO test. These will not be seen by the user. Defaults to STDOUT. =item reset_outputs $tb->reset_outputs; Resets all the output filehandles back to their defaults. =item carp $tb->carp(@message); Warns with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). =item croak $tb->croak(@message); Dies with C<@message> but the message will appear to come from the point where the original test function was called (C<< $tb->caller >>). =back =head2 Test Status and Info =over 4 =item B<no_log_results> This will turn off result long-term storage. Calling this method will make C<details> and C<summary> useless. You may want to use this if you are running enough tests to fill up all available memory. Test::Builder->new->no_log_results(); There is no way to turn it back on. =item B<current_test> my $curr_test = $Test->current_test; $Test->current_test($num); Gets/sets the current test number we're on. You usually shouldn't have to set this. If set forward, the details of the missing tests are filled in as 'unknown'. if set backward, the details of the intervening tests are deleted. You can erase history if you really want to. =item B<is_passing> my $ok = $builder->is_passing; Indicates if the test suite is currently passing. More formally, it will be false if anything has happened which makes it impossible for the test suite to pass. True otherwise. For example, if no tests have run C<is_passing()> will be true because even though a suite with no tests is a failure you can add a passing test to it and start passing. Don't think about it too much. =item B<summary> my @tests = $Test->summary; A simple summary of the tests so far. True for pass, false for fail. This is a logical pass/fail, so todos are passes. Of course, test #1 is $tests[0], etc... =item B<details> my @tests = $Test->details; Like C<summary()>, but with a lot more detail. $tests[$test_num - 1] = { 'ok' => is the test considered a pass? actual_ok => did it literally say 'ok'? name => name of the test (if any) type => type of test (if any, see below). reason => reason for the above (if any) }; 'ok' is true if Test::Harness will consider the test to be a pass. 'actual_ok' is a reflection of whether or not the test literally printed 'ok' or 'not ok'. This is for examining the result of 'todo' tests. 'name' is the name of the test. 'type' indicates if it was a special test. Normal tests have a type of ''. Type can be one of the following: skip see skip() todo see todo() todo_skip see todo_skip() unknown see below Sometimes the Test::Builder test counter is incremented without it printing any test output, for example, when C<current_test()> is changed. In these cases, Test::Builder doesn't know the result of the test, so its type is 'unknown'. These details for these tests are filled in. They are considered ok, but the name and actual_ok is left C<undef>. For example "not ok 23 - hole count # TODO insufficient donuts" would result in this structure: $tests[22] = # 23 - 1, since arrays start from 0. { ok => 1, # logically, the test passed since its todo actual_ok => 0, # in absolute terms, it failed name => 'hole count', type => 'todo', reason => 'insufficient donuts' }; =item B<todo> my $todo_reason = $Test->todo; my $todo_reason = $Test->todo($pack); If the current tests are considered "TODO" it will return the reason, if any. This reason can come from a C<$TODO> variable or the last call to C<todo_start()>. Since a TODO test does not need a reason, this function can return an empty string even when inside a TODO block. Use C<< $Test->in_todo >> to determine if you are currently inside a TODO block. C<todo()> is about finding the right package to look for C<$TODO> in. It's pretty good at guessing the right package to look at. It first looks for the caller based on C<$Level + 1>, since C<todo()> is usually called inside a test function. As a last resort it will use C<exported_to()>. Sometimes there is some confusion about where C<todo()> should be looking for the C<$TODO> variable. If you want to be sure, tell it explicitly what $pack to use. =item B<find_TODO> my $todo_reason = $Test->find_TODO(); my $todo_reason = $Test->find_TODO($pack); Like C<todo()> but only returns the value of C<$TODO> ignoring C<todo_start()>. Can also be used to set C<$TODO> to a new value while returning the old value: my $old_reason = $Test->find_TODO($pack, 1, $new_reason); =item B<in_todo> my $in_todo = $Test->in_todo; Returns true if the test is currently inside a TODO block. =item B<todo_start> $Test->todo_start(); $Test->todo_start($message); This method allows you declare all subsequent tests as TODO tests, up until the C<todo_end> method has been called. The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out whether or not we're in a TODO test. However, often we find that this is not possible to determine (such as when we want to use C<$TODO> but the tests are being executed in other packages which can't be inferred beforehand). Note that you can use this to nest "todo" tests $Test->todo_start('working on this'); # lots of code $Test->todo_start('working on that'); # more code $Test->todo_end; $Test->todo_end; This is generally not recommended, but large testing systems often have weird internal needs. We've tried to make this also work with the TODO: syntax, but it's not guaranteed and its use is also discouraged: TODO: { local $TODO = 'We have work to do!'; $Test->todo_start('working on this'); # lots of code $Test->todo_start('working on that'); # more code $Test->todo_end; $Test->todo_end; } Pick one style or another of "TODO" to be on the safe side. =item C<todo_end> $Test->todo_end; Stops running tests as "TODO" tests. This method is fatal if called without a preceding C<todo_start> method call. =item B<caller> my $package = $Test->caller; my($pack, $file, $line) = $Test->caller; my($pack, $file, $line) = $Test->caller($height); Like the normal C<caller()>, except it reports according to your C<level()>. C<$height> will be added to the C<level()>. If C<caller()> winds up off the top of the stack it report the highest context. =back =head1 EXIT CODES If all your tests passed, Test::Builder will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Builder will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died or all passed but wrong # of tests run any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. =head1 THREADS In perl 5.8.1 and later, Test::Builder is thread-safe. The test number is shared by all threads. This means if one thread sets the test number using C<current_test()> they will all be effected. While versions earlier than 5.8.1 had threads they contain too many bugs to support. Test::Builder is only thread-aware if threads.pm is loaded I<before> Test::Builder. You can directly disable thread support with one of the following: $ENV{T2_NO_IPC} = 1 or no Test2::IPC; or Test2::API::test2_ipc_disable() =head1 MEMORY An informative hash, accessible via C<details()>, is stored for each test you perform. So memory usage will scale linearly with each test run. Although this is not a problem for most test suites, it can become an issue if you do large (hundred thousands to million) combinatorics tests in the same run. In such cases, you are advised to either split the test file into smaller ones, or use a reverse approach, doing "normal" (code) compares and triggering C<fail()> should anything go unexpected. Future versions of Test::Builder will have a way to turn history off. =head1 EXAMPLES CPAN can provide the best examples. L<Test::Simple>, L<Test::More>, L<Test::Exception> and L<Test::Differences> all use Test::Builder. =head1 SEE ALSO =head2 INTERNALS L<Test2>, L<Test2::API> =head2 LEGACY L<Test::Simple>, L<Test::More> =head2 EXTERNAL L<Test::Harness> =head1 AUTHORS Original code by chromatic, maintained by Michael G Schwern E<lt>schwern@pobox.comE<gt> =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and Michael G Schwern E<lt>schwern@pobox.comE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://www.perl.com/perl/misc/Artistic.html> perl5/FFI/CheckLib.pm 0000444 00000041301 14711217670 0010204 0 ustar 00 package FFI::CheckLib; use strict; use warnings; use File::Spec; use List::Util 1.33 qw( any ); use Carp qw( croak carp ); use base qw( Exporter ); our @EXPORT = qw( find_lib assert_lib check_lib check_lib_or_exit find_lib_or_exit find_lib_or_die ); our @EXPORT_OK = qw( which where has_symbols ); # ABSTRACT: Check that a library is available for FFI our $VERSION = '0.28'; # VERSION our $system_path = []; our $os ||= $^O; my $try_ld_on_text = 0; if($os eq 'MSWin32' || $os eq 'msys') { $system_path = eval { require Env; Env->import('@PATH'); \our @PATH; }; die $@ if $@; } else { $system_path = eval { require DynaLoader; no warnings 'once'; \@DynaLoader::dl_library_path; }; die $@ if $@; } our $pattern = [ qr{^lib(.*?)\.so(?:\.([0-9]+(?:\.[0-9]+)*))?$} ]; our $version_split = qr/\./; if($os eq 'cygwin') { push @$pattern, qr{^cyg(.*?)(?:-([0-9])+)?\.dll$}; } elsif($os eq 'msys') { # doesn't seem as though msys uses psudo libfoo.so files # in the way that cygwin sometimes does. we can revisit # this if we find otherwise. $pattern = [ qr{^msys-(.*?)(?:-([0-9])+)?\.dll$} ]; } elsif($os eq 'MSWin32') { # handle cases like libgeos-3-7-0___.dll and libgtk-2.0-0.dll $pattern = [ qr{^(?:lib)?(\w+?)(?:-([0-9-\.]+))?_*\.dll$}i ]; $version_split = qr/\-/; } elsif($os eq 'darwin') { push @$pattern, qr{^lib(.*?)(?:\.([0-9]+(?:\.[0-9]+)*))?\.(?:dylib|bundle)$}; } elsif($os eq 'linux') { if(-e '/etc/redhat-release' && -x '/usr/bin/ld') { $try_ld_on_text = 1; } } sub _matches { my($filename, $path) = @_; foreach my $regex (@$pattern) { return [ $1, # 0 capture group 1 library name File::Spec->catfile($path, $filename), # 1 full path to library defined $2 ? (split $version_split, $2) : (), # 2... capture group 2 library version ] if $filename =~ $regex; } return (); } sub _cmp { my($A,$B) = @_; return $A->[0] cmp $B->[0] if $A->[0] ne $B->[0]; my $i=2; while(1) { return 0 if !defined($A->[$i]) && !defined($B->[$i]); return -1 if !defined $A->[$i]; return 1 if !defined $B->[$i]; return $B->[$i] <=> $A->[$i] if $A->[$i] != $B->[$i]; $i++; } } my $diagnostic; sub _is_binary { -B $_[0] } sub find_lib { my(%args) = @_; undef $diagnostic; croak "find_lib requires lib argument" unless defined $args{lib}; my $recursive = $args{_r} || $args{recursive} || 0; # make arguments be lists. foreach my $arg (qw( lib libpath symbol verify alien )) { next if ref $args{$arg} eq 'ARRAY'; if(defined $args{$arg}) { $args{$arg} = [ $args{$arg} ]; } else { $args{$arg} = []; } } if(defined $args{systempath} && !ref($args{systempath})) { $args{systempath} = [ $args{systempath} ]; } my @path = @{ $args{libpath} }; @path = map { _recurse($_) } @path if $recursive; push @path, grep { defined } defined $args{systempath} ? @{ $args{systempath} } : @$system_path; my $any = any { $_ eq '*' } @{ $args{lib} }; my %missing = map { $_ => 1 } @{ $args{lib} }; my %symbols = map { $_ => 1 } @{ $args{symbol} }; my @found; delete $missing{'*'}; alien: foreach my $alien (@{ $args{alien} }) { unless($alien =~ /^([A-Za-z_][A-Za-z_0-9]*)(::[A-Za-z_][A-Za-z_0-9]*)*$/) { croak "Doesn't appear to be a valid Alien name $alien"; } unless(eval { $alien->can('dynamic_libs') }) { { my $pm = "$alien.pm"; $pm =~ s/::/\//g; local $@ = ''; eval { require $pm }; next alien if $@; } unless(eval { $alien->can('dynamic_libs') }) { croak "Alien $alien doesn't provide a dynamic_libs method"; } } push @path, [$alien->dynamic_libs]; } foreach my $path (@path) { next if ref $path ne 'ARRAY' && ! -d $path; my @maybe = # make determinist based on names and versions sort { _cmp($a,$b) } # Filter out the items that do not match the name that we are looking for # Filter out any broken symbolic links grep { ($any || $missing{$_->[0]} ) && (-e $_->[1]) } ref $path eq 'ARRAY' ? do { map { my($v, $d, $f) = File::Spec->splitpath($_); _matches($f, File::Spec->catpath($v,$d,'')); } @$path; } : do { my $dh; opendir $dh, $path; # get [ name, full_path ] mapping, # each entry is a 2 element list ref map { _matches($_,$path) } readdir $dh; }; if($try_ld_on_text && $args{try_linker_script}) { # This is tested in t/ci.t only @maybe = map { -B $_->[1] ? $_ : do { my($name, $so) = @$_; my $output = `/usr/bin/ld -t $so -o /dev/null -shared`; $output =~ /\((.*?lib.*\.so.*?)\)/ ? [$name, $1] : die "unable to parse ld output"; } } @maybe; } midloop: foreach my $lib (@maybe) { next unless $any || $missing{$lib->[0]}; foreach my $verify (@{ $args{verify} }) { next midloop unless $verify->(@$lib); } delete $missing{$lib->[0]}; if(%symbols) { require DynaLoader; my $dll = DynaLoader::dl_load_file($lib->[1],0); foreach my $symbol (keys %symbols) { if(DynaLoader::dl_find_symbol($dll, $symbol) ? 1 : 0) { delete $symbols{$symbol} } } DynaLoader::dl_unload_file($dll); } my $found = $lib->[1]; unless($any) { while(-l $found) { require File::Basename; my $dir = File::Basename::dirname($found); $found = File::Spec->rel2abs( readlink($found), $dir ); } } push @found, $found; } } if(%missing) { my @missing = sort keys %missing; if(@missing > 1) { $diagnostic = "libraries not found: @missing" } else { $diagnostic = "library not found: @missing" } } elsif(%symbols) { my @missing = sort keys %symbols; if(@missing > 1) { $diagnostic = "symbols not found: @missing" } else { $diagnostic = "symbol not found: @missing" } } return if %symbols; return $found[0] unless wantarray; return @found; } sub _recurse { my($dir) = @_; return unless -d $dir; my $dh; opendir $dh, $dir; my @list = grep { -d $_ } map { File::Spec->catdir($dir, $_) } grep !/^\.\.?$/, readdir $dh; closedir $dh; ($dir, map { _recurse($_) } @list); } sub assert_lib { croak $diagnostic || 'library not found' unless check_lib(@_); } sub check_lib_or_exit { unless(check_lib(@_)) { carp $diagnostic || 'library not found'; exit; } } sub find_lib_or_exit { my(@libs) = find_lib(@_); unless(@libs) { carp $diagnostic || 'library not found'; exit; } return unless @libs; wantarray ? @libs : $libs[0]; } sub find_lib_or_die { my(@libs) = find_lib(@_); unless(@libs) { croak $diagnostic || 'library not found'; } return unless @libs; wantarray ? @libs : $libs[0]; } sub check_lib { find_lib(@_) ? 1 : 0; } sub which { my($name) = @_; croak("cannot which *") if $name eq '*'; scalar find_lib( lib => $name ); } sub where { my($name) = @_; $name eq '*' ? find_lib(lib => '*') : find_lib(lib => '*', verify => sub { $_[0] eq $name }); } sub has_symbols { my($path, @symbols) = @_; require DynaLoader; my $dll = DynaLoader::dl_load_file($path, 0); my $ok = 1; foreach my $symbol (@symbols) { unless(DynaLoader::dl_find_symbol($dll, $symbol)) { $ok = 0; last; } } DynaLoader::dl_unload_file($dll); $ok; } sub system_path { $system_path; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::CheckLib - Check that a library is available for FFI =head1 VERSION version 0.28 =head1 SYNOPSIS use FFI::CheckLib; check_lib_or_exit( lib => 'jpeg', symbol => 'jinit_memory_mgr' ); check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] ); # or prompt for path to library and then: print "where to find jpeg library: "; my $path = <STDIN>; check_lib_or_exit( lib => 'jpeg', libpath => $path ); =head1 DESCRIPTION This module checks whether a particular dynamic library is available for FFI to use. It is modeled heavily on L<Devel::CheckLib>, but will find dynamic libraries even when development packages are not installed. It also provides a L<find_lib|FFI::CheckLib#find_lib> function that will return the full path to the found dynamic library, which can be feed directly into L<FFI::Platypus> or another FFI system. Although intended mainly for FFI modules via L<FFI::Platypus> and similar, this module does not actually use any FFI to do its detection and probing. This module does not have any non-core runtime dependencies. The test suite does depend on L<Test2::Suite>. =head1 FUNCTIONS All of these take the same named parameters and are exported by default. =head2 find_lib my(@libs) = find_lib(%args); This will return a list of dynamic libraries, or empty list if none were found. [version 0.05] If called in scalar context it will return the first library found. Arguments are key value pairs with these keys: =over 4 =item lib Must be either a string with the name of a single library or a reference to an array of strings of library names. Depending on your platform, C<CheckLib> will prepend C<lib> or append C<.dll> or C<.so> when searching. [version 0.11] As a special case, if C<*> is specified then any libs found will match. =item libpath A string or array of additional paths to search for libraries. =item systempath [version 0.11] A string or array of system paths to search for instead of letting L<FFI::CheckLib> determine the system path. You can set this to C<[]> in order to not search I<any> system paths. =item symbol A string or a list of symbol names that must be found. =item verify A code reference used to verify a library really is the one that you want. It should take two arguments, which is the name of the library and the full path to the library pathname. It should return true if it is acceptable, and false otherwise. You can use this in conjunction with L<FFI::Platypus> to determine if it is going to meet your needs. Example: use FFI::CheckLib; use FFI::Platypus; my($lib) = find_lib( lib => 'foo', verify => sub { my($name, $libpath) = @_; my $ffi = FFI::Platypus->new; $ffi->lib($libpath); my $f = $ffi->function('foo_version', [] => 'int'); return $f->call() >= 500; # we accept version 500 or better }, ); =item recursive [version 0.11] Recursively search for libraries in any non-system paths (those provided via C<libpath> above). =item try_linker_script [version 0.24] Some vendors provide C<.so> files that are linker scripts that point to the real binary shared library. These linker scripts can be used by gcc or clang, but are not directly usable by L<FFI::Platypus> and friends. On select platforms, this options will use the linker command (C<ld>) to attempt to resolve the real C<.so> for non-binary files. Since there is extra overhead this is off by default. An example is libyaml on Red Hat based Linux distributions. On Debian these are handled with symlinks and no trickery is required. =item alien [version 0.25] If no libraries can be found, try the given aliens instead. The Alien classes specified must provide the L<Alien::Base> interface for dynamic libraries, which is to say they should provide a method called C<dynamic_libs> that returns a list of dynamic libraries. [version 0.28] In 0.28 and later, if the L<Alien> is not installed then it will be ignored and this module will search in system or specified directories only. This module I<will> still throw an exception, if the L<Alien> doesn't look like a module name or if it does not provide a C<dynamic_libs> method (which is implemented by all L<Alien::Base> subclasses). =back =head2 assert_lib assert_lib(%args); This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>, except that instead of returning empty list of failure it throws an exception. =head2 check_lib_or_exit check_lib_or_exit(%args); This behaves exactly the same as L<assert_lib|FFI::CheckLib#assert_lib>, except that instead of dying, it warns (with exactly the same error message) and exists. This is intended for use in C<Makefile.PL> or C<Build.PL> =head2 find_lib_or_exit [version 0.05] my(@libs) = find_lib_or_exit(%args); This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>, except that if the library is not found, it will call exit with an appropriate diagnostic. =head2 find_lib_or_die [version 0.06] my(@libs) = find_lib_or_die(%args); This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>, except that if the library is not found, it will die with an appropriate diagnostic. =head2 check_lib my $bool = check_lib(%args); This behaves exactly the same as L<find_lib|FFI::CheckLib#find_lib>, except that it returns true (1) on finding the appropriate libraries or false (0) otherwise. =head2 which [version 0.17] my $path = where($name); Return the path to the first library that matches the given name. Not exported by default. =head2 where [version 0.17] my @paths = where($name); Return the paths to all the libraries that match the given name. Not exported by default. =head2 has_symbols [version 0.17] my $bool = has_symbols($path, @symbol_names); Returns true if I<all> of the symbols can be found in the dynamic library located at the given path. Can be useful in conjunction with C<verify> with C<find_lib> above. Not exported by default. =head2 system_path [version 0.20] my $path = FFI::CheckLib::system_path; Returns the system path as a list reference. On some systems, this is C<PATH> on others it might be C<LD_LIBRARY_PATH> on still others it could be something completely different. So although you I<may> add items to this list, you should probably do some careful consideration before you do so. This function is not exportable, even on request. =head1 FAQ =over 4 =item Why not just use C<dlopen>? Calling C<dlopen> on a library name and then C<dlclose> immediately can tell you if you have the exact name of a library available on a system. It does have a number of drawbacks as well. =over 4 =item No absolute or relative path It only tells you that the library is I<somewhere> on the system, not having the absolute or relative path makes it harder to generate useful diagnostics. =item POSIX only This doesn't work on non-POSIX systems like Microsoft Windows. If you are using a POSIX emulation layer on Windows that provides C<dlopen>, like Cygwin, there are a number of gotchas there as well. Having a layer written in Perl handles this means that developers on Unix can develop FFI that will more likely work on these platforms without special casing them. =item inconsistent implementations Even on POSIX systems you have inconsistent implementations. OpenBSD for example don't usually include symlinks for C<.so> files meaning you need to know the exact C<.so> version. =item non-system directories By default C<dlopen> only works for libraries in the system paths. Most platforms have a way of configuring the search for different non-system paths, but none of them are portable, and are usually discouraged anyway. L<Alien> and friends need to do searches for dynamic libraries in non-system directories for C<share> installs. =back =item My 64-bit Perl is misconfigured and has 32-bit libraries in its search path. Is that a bug in L<FFI::CheckLib>? Nope. =item The way L<FFI::CheckLib> is implemented it won't work on AIX, HP-UX, OpenVMS or Plan 9. I know for a fact that it doesn't work on AIX I<as currently implemented> because I used to develop on AIX in the early 2000s, and I am aware of some of the technical challenges. There are probably other systems that it won't work on. I would love to add support for these platforms. Realistically these platforms have a tiny market share, and absent patches from users or the companies that own these operating systems (patches welcome), or hardware / CPU time donations, these platforms are unsupportable anyway. =back =head1 SEE ALSO =over 4 =item L<FFI::Platypus> Call library functions dynamically without a compiler. =item L<Dist::Zilla::Plugin::FFI::CheckLib> L<Dist::Zilla> plugin for this module. =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Bakkiaraj Murugesan (bakkiaraj) Dan Book (grinnz, DBOOK) Ilya Pavlov (Ilya, ILUX) Shawn Laffan (SLAFFAN) Petr Pisar (ppisar) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014-2018 by Graham Ollis. 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 perl5/Try/Tiny.pm 0000444 00000050372 14711217673 0007650 0 ustar 00 package Try::Tiny; # git description: v0.29-2-g3b23a06 use 5.006; # ABSTRACT: Minimal try/catch with proper preservation of $@ our $VERSION = '0.30'; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT = our @EXPORT_OK = qw(try catch finally); use Carp; $Carp::Internal{+__PACKAGE__}++; BEGIN { my $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname; my $sn = $INC{'Sub/Name.pm'} && eval { Sub::Name->VERSION(0.08) }; unless ($su || $sn) { $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname; unless ($su) { $sn = eval { require Sub::Name; Sub::Name->VERSION(0.08) }; } } *_subname = $su ? \&Sub::Util::set_subname : $sn ? \&Sub::Name::subname : sub { $_[1] }; *_HAS_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0}; } my %_finally_guards; # Need to prototype as @ not $$ because of the way Perl evaluates the prototype. # Keeping it at $$ means you only ever get 1 sub because we need to eval in a list # context & not a scalar one sub try (&;@) { my ( $try, @code_refs ) = @_; # we need to save this here, the eval block will be in scalar context due # to $failed my $wantarray = wantarray; # work around perl bug by explicitly initializing these, due to the likelyhood # this will be used in global destruction (perl rt#119311) my ( $catch, @finally ) = (); # find labeled blocks in the argument list. # catch and finally tag the blocks by blessing a scalar reference to them. foreach my $code_ref (@code_refs) { if ( ref($code_ref) eq 'Try::Tiny::Catch' ) { croak 'A try() may not be followed by multiple catch() blocks' if $catch; $catch = ${$code_ref}; } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) { push @finally, ${$code_ref}; } else { croak( 'try() encountered an unexpected argument (' . ( defined $code_ref ? $code_ref : 'undef' ) . ') - perhaps a missing semi-colon before or' ); } } # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's # not perfect, but we could provide a list of additional errors for # $catch->(); # name the blocks if we have Sub::Name installed _subname(caller().'::try {...} ' => $try) if _HAS_SUBNAME; # set up scope guards to invoke the finally blocks at the end. # this should really be a function scope lexical variable instead of # file scope + local but that causes issues with perls < 5.20 due to # perl rt#119311 local $_finally_guards{guards} = [ map { Try::Tiny::ScopeGuard->_new($_) } @finally ]; # save the value of $@ so we can set $@ back to it in the beginning of the eval # and restore $@ after the eval finishes my $prev_error = $@; my ( @ret, $error ); # failed will be true if the eval dies, because 1 will not be returned # from the eval body my $failed = not eval { $@ = $prev_error; # evaluate the try block in the correct context if ( $wantarray ) { @ret = $try->(); } elsif ( defined $wantarray ) { $ret[0] = $try->(); } else { $try->(); }; return 1; # properly set $failed to false }; # preserve the current error and reset the original value of $@ $error = $@; $@ = $prev_error; # at this point $failed contains a true value if the eval died, even if some # destructor overwrote $@ as the eval was unwinding. if ( $failed ) { # pass $error to the finally blocks push @$_, $error for @{$_finally_guards{guards}}; # if we got an error, invoke the catch block. if ( $catch ) { # This works like given($error), but is backwards compatible and # sets $_ in the dynamic scope for the body of C<$catch> for ($error) { return $catch->($error); } # in case when() was used without an explicit return, the C<for> # loop will be aborted and there's no useful return value } return; } else { # no failure, $@ is back to what it was, everything is fine return $wantarray ? @ret : $ret[0]; } } sub catch (&;@) { my ( $block, @rest ) = @_; croak 'Useless bare catch()' unless wantarray; _subname(caller().'::catch {...} ' => $block) if _HAS_SUBNAME; return ( bless(\$block, 'Try::Tiny::Catch'), @rest, ); } sub finally (&;@) { my ( $block, @rest ) = @_; croak 'Useless bare finally()' unless wantarray; _subname(caller().'::finally {...} ' => $block) if _HAS_SUBNAME; return ( bless(\$block, 'Try::Tiny::Finally'), @rest, ); } { package # hide from PAUSE Try::Tiny::ScopeGuard; use constant UNSTABLE_DOLLARAT => ("$]" < '5.013002') ? 1 : 0; sub _new { shift; bless [ @_ ]; } sub DESTROY { my ($code, @args) = @{ $_[0] }; local $@ if UNSTABLE_DOLLARAT; eval { $code->(@args); 1; } or do { warn "Execution of finally() block $code resulted in an exception, which " . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. ' . 'Your program will continue as if this event never took place. ' . "Original exception text follows:\n\n" . (defined $@ ? $@ : '$@ left undefined...') . "\n" ; } } } __PACKAGE__ __END__ =pod =encoding UTF-8 =head1 NAME Try::Tiny - Minimal try/catch with proper preservation of $@ =head1 VERSION version 0.30 =head1 SYNOPSIS You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional conditions, avoiding quirks in Perl and common mistakes: # handle errors with a catch handler try { die "foo"; } catch { warn "caught error: $_"; # not $@ }; You can also use it like a standalone C<eval> to catch and ignore any error conditions. Obviously, this is an extreme measure not to be undertaken lightly: # just silence errors try { die "foo"; }; =head1 DESCRIPTION This module provides bare bones C<try>/C<catch>/C<finally> statements that are designed to minimize common mistakes with eval blocks, and NOTHING else. This is unlike L<TryCatch> which provides a nice syntax and avoids adding another call stack layer, and supports calling C<return> from the C<try> block to return from the parent subroutine. These extra features come at a cost of a few dependencies, namely L<Devel::Declare> and L<Scope::Upper> which are occasionally problematic, and the additional catch filtering uses L<Moose> type constraints which may not be desirable either. The main focus of this module is to provide simple and reliable error handling for those having a hard time installing L<TryCatch>, but who still want to write correct C<eval> blocks without 5 lines of boilerplate each time. It's designed to work as correctly as possible in light of the various pathological edge cases (see L</BACKGROUND>) and to be compatible with any style of error values (simple strings, references, objects, overloaded objects, etc). If the C<try> block dies, it returns the value of the last statement executed in the C<catch> block, if there is one. Otherwise, it returns C<undef> in scalar context or the empty list in list context. The following examples all assign C<"bar"> to C<$x>: my $x = try { die "foo" } catch { "bar" }; my $x = try { die "foo" } || "bar"; my $x = (try { die "foo" }) // "bar"; my $x = eval { die "foo" } || "bar"; You can add C<finally> blocks, yielding the following: my $x; try { die 'foo' } finally { $x = 'bar' }; try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' }; C<finally> blocks are always executed making them suitable for cleanup code which cannot be handled using local. You can add as many C<finally> blocks to a given C<try> block as you like. Note that adding a C<finally> block without a preceding C<catch> block suppresses any errors. This behaviour is consistent with using a standalone C<eval>, but it is not consistent with C<try>/C<finally> patterns found in other programming languages, such as Java, Python, Javascript or C#. If you learnt the C<try>/C<finally> pattern from one of these languages, watch out for this. =head1 EXPORTS All functions are exported by default using L<Exporter>. If you need to rename the C<try>, C<catch> or C<finally> keyword consider using L<Sub::Import> to get L<Sub::Exporter>'s flexibility. =over 4 =item try (&;@) Takes one mandatory C<try> subroutine, an optional C<catch> subroutine and C<finally> subroutine. The mandatory subroutine is evaluated in the context of an C<eval> block. If no error occurred the value from the first block is returned, preserving list/scalar context. If there was an error and the second subroutine was given it will be invoked with the error in C<$_> (localized) and as that block's first and only argument. C<$@> does B<not> contain the error. Inside the C<catch> block it has the same value it had before the C<try> block was executed. Note that the error may be false, but if that happens the C<catch> block will still be invoked. Once all execution is finished then the C<finally> block, if given, will execute. =item catch (&;@) Intended to be used in the second argument position of C<try>. Returns a reference to the subroutine it was given but blessed as C<Try::Tiny::Catch> which allows try to decode correctly what to do with this code reference. catch { ... } Inside the C<catch> block the caught error is stored in C<$_>, while previous value of C<$@> is still available for use. This value may or may not be meaningful depending on what happened before the C<try>, but it might be a good idea to preserve it in an error stack. For code that captures C<$@> when throwing new errors (i.e. L<Class::Throwable>), you'll need to do: local $@ = $_; =item finally (&;@) try { ... } catch { ... } finally { ... }; Or try { ... } finally { ... }; Or even try { ... } finally { ... } catch { ... }; Intended to be the second or third element of C<try>. C<finally> blocks are always executed in the event of a successful C<try> or if C<catch> is run. This allows you to locate cleanup code which cannot be done via C<local()> e.g. closing a file handle. When invoked, the C<finally> block is passed the error that was caught. If no error was caught, it is passed nothing. (Note that the C<finally> block does not localize C<$_> with the error, since unlike in a C<catch> block, there is no way to know if C<$_ == undef> implies that there were no errors.) In other words, the following code does just what you would expect: try { die_sometimes(); } catch { # ...code run in case of error } finally { if (@_) { print "The try block died with: @_\n"; } else { print "The try block ran without error.\n"; } }; B<You must always do your own error handling in the C<finally> block>. C<Try::Tiny> will not do anything about handling possible errors coming from code located in these blocks. Furthermore B<exceptions in C<finally> blocks are not trappable and are unable to influence the execution of your program>. This is due to limitation of C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This may change in a future version of Try::Tiny. In the same way C<catch()> blesses the code reference this subroutine does the same except it bless them as C<Try::Tiny::Finally>. =back =head1 BACKGROUND There are a number of issues with C<eval>. =head2 Clobbering $@ When you run an C<eval> block and it succeeds, C<$@> will be cleared, potentially clobbering an error that is currently being caught. This causes action at a distance, clearing previous errors your caller may have not yet handled. C<$@> must be properly localized before invoking C<eval> in order to avoid this issue. More specifically, L<before Perl version 5.14.0|perl5140delta/"Exception Handling"> C<$@> was clobbered at the beginning of the C<eval>, which also made it impossible to capture the previous error before you die (for instance when making exception objects with error stacks). For this reason C<try> will actually set C<$@> to its previous value (the one available before entering the C<try> block) in the beginning of the C<eval> block. =head2 Localizing $@ silently masks errors Inside an C<eval> block, C<die> behaves sort of like: sub die { $@ = $_[0]; return_undef_from_eval(); } This means that if you were polite and localized C<$@> you can't die in that scope, or your error will be discarded (printing "Something's wrong" instead). The workaround is very ugly: my $error = do { local $@; eval { ... }; $@; }; ... die $error; =head2 $@ might not be a true value This code is wrong: if ( $@ ) { ... } because due to the previous caveats it may have been unset. C<$@> could also be an overloaded error object that evaluates to false, but that's asking for trouble anyway. The classic failure mode (fixed in L<Perl 5.14.0|perl5140delta/"Exception Handling">) is: sub Object::DESTROY { eval { ... } } eval { my $obj = Object->new; die "foo"; }; if ( $@ ) { } In this case since C<Object::DESTROY> is not localizing C<$@> but still uses C<eval>, it will set C<$@> to C<"">. The destructor is called when the stack is unwound, after C<die> sets C<$@> to C<"foo at Foo.pm line 42\n">, so by the time C<if ( $@ )> is evaluated it has been cleared by C<eval> in the destructor. The workaround for this is even uglier than the previous ones. Even though we can't save the value of C<$@> from code that doesn't localize, we can at least be sure the C<eval> was aborted due to an error: my $failed = not eval { ... return 1; }; This is because an C<eval> that caught a C<die> will always return a false value. =head1 ALTERNATE SYNTAX Using Perl 5.10 you can use L<perlsyn/"Switch statements"> (but please don't, because that syntax has since been deprecated because there was too much unexpected magical behaviour). =for stopwords topicalizer The C<catch> block is invoked in a topicalizer context (like a C<given> block), but note that you can't return a useful value from C<catch> using the C<when> blocks without an explicit C<return>. This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to concisely match errors: try { require Foo; } catch { when (/^Can't locate .*?\.pm in \@INC/) { } # ignore default { die $_ } }; =head1 CAVEATS =over 4 =item * C<@_> is not available within the C<try> block, so you need to copy your argument list. In case you want to work with argument values directly via C<@_> aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference: sub foo { my ( $self, @args ) = @_; try { $self->bar(@args) } } or sub bar_in_place { my $self = shift; my $args = \@_; try { $_ = $self->bar($_) for @$args } } =item * C<return> returns from the C<try> block, not from the parent sub (note that this is also how C<eval> works, but not how L<TryCatch> works): sub parent_sub { try { die; } catch { return; }; say "this text WILL be displayed, even though an exception is thrown"; } Instead, you should capture the return value: sub parent_sub { my $success = try { die; 1; }; return unless $success; say "This text WILL NEVER appear!"; } # OR sub parent_sub_with_catch { my $success = try { die; 1; } catch { # do something with $_ return undef; #see note }; return unless $success; say "This text WILL NEVER appear!"; } Note that if you have a C<catch> block, it must return C<undef> for this to work, since if a C<catch> block exists, its return value is returned in place of C<undef> when an exception is thrown. =item * C<try> introduces another caller stack frame. L<Sub::Uplevel> is not used. L<Carp> will not report this when using full stack traces, though, because C<%Carp::Internal> is used. This lack of magic is considered a feature. =for stopwords unhygienically =item * The value of C<$_> in the C<catch> block is not guaranteed to be the value of the exception thrown (C<$@>) in the C<try> block. There is no safe way to ensure this, since C<eval> may be used unhygienically in destructors. The only guarantee is that the C<catch> will be called if an exception is thrown. =item * The return value of the C<catch> block is not ignored, so if testing the result of the expression for truth on success, be sure to return a false value from the C<catch> block: my $obj = try { MightFail->new; } catch { ... return; # avoid returning a true value; }; return unless $obj; =item * C<$SIG{__DIE__}> is still in effect. Though it can be argued that C<$SIG{__DIE__}> should be disabled inside of C<eval> blocks, since it isn't people have grown to rely on it. Therefore in the interests of compatibility, C<try> does not disable C<$SIG{__DIE__}> for the scope of the error throwing code. =item * Lexical C<$_> may override the one set by C<catch>. For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some confusing behavior: given ($foo) { when (...) { try { ... } catch { warn $_; # will print $foo, not the error warn $_[0]; # instead, get the error like this } } } Note that this behavior was changed once again in L<Perl5 version 18|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>. However, since the entirety of lexical C<$_> is now L<considered experimental |https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it is unclear whether the new version 18 behavior is final. =back =head1 SEE ALSO =over 4 =item L<TryCatch> Much more feature complete, more convenient semantics, but at the cost of implementation complexity. =item L<autodie> Automatic error throwing for builtin functions and more. Also designed to work well with C<given>/C<when>. =item L<Throwable> A lightweight role for rolling your own exception classes. =item L<Error> Exception object implementation with a C<try> statement. Does not localize C<$@>. =item L<Exception::Class::TryCatch> Provides a C<catch> statement, but properly calling C<eval> is your responsibility. The C<try> keyword pushes C<$@> onto an error stack, avoiding some of the issues with C<$@>, but you still need to localize to prevent clobbering. =back =head1 LIGHTNING TALK I gave a lightning talk about this module, you can see the slides (Firefox only): L<http://web.archive.org/web/20100628040134/http://nothingmuch.woobling.org/talks/takahashi.xul> Or read the source: L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml> =head1 SUPPORT Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny> (or L<bug-Try-Tiny@rt.cpan.org|mailto:bug-Try-Tiny@rt.cpan.org>). =head1 AUTHORS =over 4 =item * יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org> =item * Jesse Luehrs <doy@tozt.net> =back =head1 CONTRIBUTORS =for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Lukas Mai Aristotle Pagaltzis Dagfinn Ilmari Mannsåker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jens Berthold Jonathan Yu Marc Mims Stosberg Pali =over 4 =item * Karen Etheridge <ether@cpan.org> =item * Peter Rabbitson <ribasushi@cpan.org> =item * Ricardo Signes <rjbs@cpan.org> =item * Mark Fowler <mark@twoshortplanks.com> =item * Graham Knop <haarg@haarg.org> =item * Lukas Mai <l.mai@web.de> =item * Aristotle Pagaltzis <pagaltzis@gmx.de> =item * Dagfinn Ilmari Mannsåker <ilmari@ilmari.org> =item * Paul Howarth <paul@city-fan.org> =item * Rudolf Leermakers <rudolf@hatsuseno.org> =item * anaxagoras <walkeraj@gmail.com> =item * awalker <awalker@sourcefire.com> =item * chromatic <chromatic@wgz.org> =item * Alex <alex@koban.(none)> =item * cm-perl <cm-perl@users.noreply.github.com> =item * Andrew Yates <ayates@haddock.local> =item * David Lowe <davidl@lokku.com> =item * Glenn Fowler <cebjyre@cpan.org> =item * Hans Dieter Pearcey <hdp@weftsoar.net> =item * Jens Berthold <jens@jebecs.de> =item * Jonathan Yu <JAWNSY@cpan.org> =item * Marc Mims <marc@questright.com> =item * Mark Stosberg <mark@stosberg.com> =item * Pali <pali@cpan.org> =back =head1 COPYRIGHT AND LICENCE This software is Copyright (c) 2009 by יובל קוג'מן (Yuval Kogman). This is free software, licensed under: The MIT (X11) License =cut perl5/ExtUtils/Command/MM.pm 0000444 00000017030 14711217677 0011615 0 ustar 00 package ExtUtils::Command::MM; require 5.006; use strict; use warnings; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(test_harness pod2man perllocal_install uninstall warn_if_old_packlist test_s cp_nonempty); our $VERSION = '7.62'; $VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; sub mtime { no warnings 'redefine'; local $@; *mtime = (eval { require Time::HiRes } && defined &Time::HiRes::stat) ? sub { (Time::HiRes::stat($_[0]))[9] } : sub { ( stat($_[0]))[9] } ; goto &mtime; } =head1 NAME ExtUtils::Command::MM - Commands for the MM's to use in Makefiles =head1 SYNOPSIS perl "-MExtUtils::Command::MM" -e "function" "--" arguments... =head1 DESCRIPTION B<FOR INTERNAL USE ONLY!> The interface is not stable. ExtUtils::Command::MM encapsulates code which would otherwise have to be done with large "one" liners. Any $(FOO) used in the examples are make variables, not Perl. =over 4 =item B<test_harness> test_harness($verbose, @test_libs); Runs the tests on @ARGV via Test::Harness passing through the $verbose flag. Any @test_libs will be unshifted onto the test's @INC. @test_libs are run in alphabetical order. =cut sub test_harness { require Test::Harness; require File::Spec; $Test::Harness::verbose = shift; # Because Windows doesn't do this for us and listing all the *.t files # out on the command line can blow over its exec limit. require ExtUtils::Command; my @argv = ExtUtils::Command::expand_wildcards(@ARGV); local @INC = @INC; unshift @INC, map { File::Spec->rel2abs($_) } @_; Test::Harness::runtests(sort { lc $a cmp lc $b } @argv); } =item B<pod2man> pod2man( '--option=value', $podfile1 => $manpage1, $podfile2 => $manpage2, ... ); # or args on @ARGV pod2man() is a function performing most of the duties of the pod2man program. Its arguments are exactly the same as pod2man as of 5.8.0 with the addition of: --perm_rw octal permission to set the resulting manpage to And the removal of: --verbose/-v --help/-h If no arguments are given to pod2man it will read from @ARGV. If Pod::Man is unavailable, this function will warn and return undef. =cut sub pod2man { local @ARGV = @_ ? @_ : @ARGV; { local $@; if( !eval { require Pod::Man } ) { warn "Pod::Man is not available: $@". "Man pages will not be generated during this install.\n"; return 0; } } require Getopt::Long; # We will cheat and just use Getopt::Long. We fool it by putting # our arguments into @ARGV. Should be safe. my %options = (); Getopt::Long::config ('bundling_override'); Getopt::Long::GetOptions (\%options, 'section|s=s', 'release|r=s', 'center|c=s', 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l', 'name|n=s', 'perm_rw=i', 'utf8|u' ); delete $options{utf8} unless $Pod::Man::VERSION >= 2.17; # If there's no files, don't bother going further. return 0 unless @ARGV; # Official sets --center, but don't override things explicitly set. if ($options{official} && !defined $options{center}) { $options{center} = q[Perl Programmer's Reference Guide]; } # This isn't a valid Pod::Man option and is only accepted for backwards # compatibility. delete $options{lax}; my $count = scalar @ARGV / 2; my $plural = $count == 1 ? 'document' : 'documents'; print "Manifying $count pod $plural\n"; do {{ # so 'next' works my ($pod, $man) = splice(@ARGV, 0, 2); next if ((-e $man) && (mtime($man) > mtime($pod)) && (mtime($man) > mtime("Makefile"))); my $parser = Pod::Man->new(%options); $parser->parse_from_file($pod, $man) or do { warn("Could not install $man\n"); next }; if (exists $options{perm_rw}) { chmod(oct($options{perm_rw}), $man) or do { warn("chmod $options{perm_rw} $man: $!\n"); next }; } }} while @ARGV; return 1; } =item B<warn_if_old_packlist> perl "-MExtUtils::Command::MM" -e warn_if_old_packlist <somefile> Displays a warning that an old packlist file was found. Reads the filename from @ARGV. =cut sub warn_if_old_packlist { my $packlist = $ARGV[0]; return unless -f $packlist; print <<"PACKLIST_WARNING"; WARNING: I have found an old package in $packlist. Please make sure the two installations are not conflicting PACKLIST_WARNING } =item B<perllocal_install> perl "-MExtUtils::Command::MM" -e perllocal_install <type> <module name> <key> <value> ... # VMS only, key|value pairs come on STDIN perl "-MExtUtils::Command::MM" -e perllocal_install <type> <module name> < <key>|<value> ... Prints a fragment of POD suitable for appending to perllocal.pod. Arguments are read from @ARGV. 'type' is the type of what you're installing. Usually 'Module'. 'module name' is simply the name of your module. (Foo::Bar) Key/value pairs are extra information about the module. Fields include: installed into which directory your module was out into LINKTYPE dynamic or static linking VERSION module version number EXE_FILES any executables installed in a space separated list =cut sub perllocal_install { my($type, $name) = splice(@ARGV, 0, 2); # VMS feeds args as a piped file on STDIN since it usually can't # fit all the args on a single command line. my @mod_info = $Is_VMS ? split /\|/, <STDIN> : @ARGV; my $pod; my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time); $pod = sprintf <<'POD', scalar($time), $type, $name, $name; =head2 %s: C<%s> L<%s|%s> =over 4 POD do { my($key, $val) = splice(@mod_info, 0, 2); $pod .= <<POD =item * C<$key: $val> POD } while(@mod_info); $pod .= "=back\n\n"; $pod =~ s/^ //mg; print $pod; return 1; } =item B<uninstall> perl "-MExtUtils::Command::MM" -e uninstall <packlist> A wrapper around ExtUtils::Install::uninstall(). Warns that uninstallation is deprecated and doesn't actually perform the uninstallation. =cut sub uninstall { my($packlist) = shift @ARGV; require ExtUtils::Install; print <<'WARNING'; Uninstall is unsafe and deprecated, the uninstallation was not performed. We will show what would have been done. WARNING ExtUtils::Install::uninstall($packlist, 1, 1); print <<'WARNING'; Uninstall is unsafe and deprecated, the uninstallation was not performed. Please check the list above carefully, there may be errors. Remove the appropriate files manually. Sorry for the inconvenience. WARNING } =item B<test_s> perl "-MExtUtils::Command::MM" -e test_s <file> Tests if a file exists and is not empty (size > 0). I<Exits> with 0 if it does, 1 if it does not. =cut sub test_s { exit(-s $ARGV[0] ? 0 : 1); } =item B<cp_nonempty> perl "-MExtUtils::Command::MM" -e cp_nonempty <srcfile> <dstfile> <perm> Tests if the source file exists and is not empty (size > 0). If it is not empty it copies it to the given destination with the given permissions. =back =cut sub cp_nonempty { my @args = @ARGV; return 0 unless -s $args[0]; require ExtUtils::Command; { local @ARGV = @args[0,1]; ExtUtils::Command::cp(@ARGV); } { local @ARGV = @args[2,1]; ExtUtils::Command::chmod(@ARGV); } } 1; perl5/ExtUtils/MakeMaker/version.pm 0000444 00000004525 14711217677 0013255 0 ustar 00 #--------------------------------------------------------------------------# # This is a modified copy of version.pm 0.9909, bundled exclusively for # use by ExtUtils::Makemaker and its dependencies to bootstrap when # version.pm is not available. It should not be used by ordinary modules. # # When loaded, it will try to load version.pm. If that fails, it will load # ExtUtils::MakeMaker::version::vpp and alias various *version functions # to functions in that module. It will also override UNIVERSAL::VERSION. #--------------------------------------------------------------------------# package ExtUtils::MakeMaker::version; use 5.006001; use strict; use warnings; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); $VERSION = '7.62'; $VERSION =~ tr/_//d; $CLASS = 'version'; { local $SIG{'__DIE__'}; eval "use version"; if ( $@ ) { # don't have any version.pm installed eval "use ExtUtils::MakeMaker::version::vpp"; die "$@" if ( $@ ); no warnings; delete $INC{'version.pm'}; $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'}; push @version::ISA, "ExtUtils::MakeMaker::version::vpp"; $version::VERSION = $VERSION; *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv; *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare; *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION; *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp; *version::new = \&ExtUtils::MakeMaker::version::vpp::new; if ("$]" >= 5.009000) { no strict 'refs'; *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify; *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify; *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp; *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse; } require ExtUtils::MakeMaker::version::regex; *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; } elsif ( ! version->can('is_qv') ) { *version::is_qv = sub { exists $_[0]->{qv} }; } } 1; perl5/ExtUtils/MakeMaker/Tutorial.pod 0000444 00000012563 14711217700 0013525 0 ustar 00 package ExtUtils::MakeMaker::Tutorial; our $VERSION = '7.62'; $VERSION =~ tr/_//d; =head1 NAME ExtUtils::MakeMaker::Tutorial - Writing a module with MakeMaker =head1 SYNOPSIS use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Your::Module', VERSION_FROM => 'lib/Your/Module.pm' ); =head1 DESCRIPTION This is a short tutorial on writing a simple module with MakeMaker. It's really not that hard. =head2 The Mantra MakeMaker modules are installed using this simple mantra perl Makefile.PL make make test make install There are lots more commands and options, but the above will do it. =head2 The Layout The basic files in a module look something like this. Makefile.PL MANIFEST lib/Your/Module.pm That's all that's strictly necessary. There's additional files you might want: lib/Your/Other/Module.pm t/some_test.t t/some_other_test.t Changes README INSTALL MANIFEST.SKIP bin/some_program =over 4 =item Makefile.PL When you run Makefile.PL, it makes a Makefile. That's the whole point of MakeMaker. The Makefile.PL is a simple program which loads ExtUtils::MakeMaker and runs the WriteMakefile() function to generate a Makefile. Here's an example of what you need for a simple module: use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Your::Module', VERSION_FROM => 'lib/Your/Module.pm' ); NAME is the top-level namespace of your module. VERSION_FROM is the file which contains the $VERSION variable for the entire distribution. Typically this is the same as your top-level module. =item MANIFEST A simple listing of all the files in your distribution. Makefile.PL MANIFEST lib/Your/Module.pm File paths in a MANIFEST always use Unix conventions (ie. /) even if you're not on Unix. You can write this by hand or generate it with 'make manifest'. See L<ExtUtils::Manifest> for more details. =item lib/ This is the directory where the .pm and .pod files you wish to have installed go. They are laid out according to namespace. So Foo::Bar is F<lib/Foo/Bar.pm>. =item t/ Tests for your modules go here. Each test filename ends with a .t. So F<t/foo.t> 'make test' will run these tests. Typically, the F<t/> test directory is flat, with all test files located directly within it. However, you can nest tests within subdirectories, for example: t/foo/subdir_test.t To do this, you need to inform C<WriteMakeFile()> in your I<Makefile.PL> file in the following fashion: test => {TESTS => 't/*.t t/*/*.t'} That will run all tests in F<t/>, as well as all tests in all subdirectories that reside under F<t/>. You can nest as deeply as makes sense for your project. Simply add another entry in the test location string. For example, to test: t/foo/bar/subdir_test.t You would use the following C<test> directive: test => {TESTS => 't/*.t t/*/*/*.t'} Note that in the above example, tests in the first subdirectory will not be run. To run all tests in the intermediary subdirectory preceding the one the test files are in, you need to explicitly note it: test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'} You don't need to specify wildcards if you only want to test within specific subdirectories. The following example will only run tests in F<t/foo>: test => {TESTS => 't/foo/*.t'} Tests are run from the top level of your distribution. So inside a test you would refer to ./lib to enter the lib directory, for example. =item Changes A log of changes you've made to this module. The layout is free-form. Here's an example: 1.01 Fri Apr 11 00:21:25 PDT 2003 - thing() does some stuff now - fixed the wiggy bug in withit() 1.00 Mon Apr 7 00:57:15 PDT 2003 - "Rain of Frogs" now supported =item README A short description of your module, what it does, why someone would use it and its limitations. CPAN automatically pulls your README file out of the archive and makes it available to CPAN users, it is the first thing they will read to decide if your module is right for them. =item INSTALL Instructions on how to install your module along with any dependencies. Suggested information to include here: any extra modules required for use the minimum version of Perl required if only works on certain operating systems =item MANIFEST.SKIP A file full of regular expressions to exclude when using 'make manifest' to generate the MANIFEST. These regular expressions are checked against each file path found in the distribution (so you're matching against "t/foo.t" not "foo.t"). Here's a sample: ~$ # ignore emacs and vim backup files .bak$ # ignore manual backups \# # ignore CVS old revision files and emacs temp files Since # can be used for comments, # must be escaped. MakeMaker comes with a default MANIFEST.SKIP to avoid things like version control directories and backup files. Specifying your own will override this default. =item bin/ =back =head1 SEE ALSO L<perlmodstyle> gives stylistic help writing a module. L<perlnewmod> gives more information about how to write a module. There are modules to help you through the process of writing a module: L<ExtUtils::ModuleMaker>, L<Module::Starter>, L<Minilla::Tutorial>, L<Dist::Milla::Tutorial>, L<Dist::Zilla::Starter> =cut 1; perl5/ExtUtils/MakeMaker/Locale.pm 0000444 00000032044 14711217701 0012750 0 ustar 00 package ExtUtils::MakeMaker::Locale; use strict; use warnings; our $VERSION = "7.62"; $VERSION =~ tr/_//d; use base 'Exporter'; our @EXPORT_OK = qw( decode_argv env $ENCODING_LOCALE $ENCODING_LOCALE_FS $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT ); use Encode (); use Encode::Alias (); our $ENCODING_LOCALE; our $ENCODING_LOCALE_FS; our $ENCODING_CONSOLE_IN; our $ENCODING_CONSOLE_OUT; sub DEBUG () { 0 } sub _init { if ($^O eq "MSWin32") { unless ($ENCODING_LOCALE) { # Try to obtain what the Windows ANSI code page is eval { unless (defined &GetConsoleCP) { require Win32; # manually "import" it since Win32->import refuses *GetConsoleCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; } unless (defined &GetConsoleCP) { require Win32::API; Win32::API->Import('kernel32', 'int GetConsoleCP()'); } if (defined &GetConsoleCP) { my $cp = GetConsoleCP(); $ENCODING_LOCALE = "cp$cp" if $cp; } }; } unless ($ENCODING_CONSOLE_IN) { # only test one since set together unless (defined &GetInputCP) { eval { require Win32; eval { local $SIG{__WARN__} = sub {} if ( "$]" < 5.014 ); # suppress deprecation warning for inherited AUTOLOAD of Win32::GetConsoleCP() Win32::GetConsoleCP(); }; # manually "import" it since Win32->import refuses *GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP; *GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP; }; unless (defined &GetInputCP) { eval { # try Win32::Console module for codepage to use require Win32::Console; *GetInputCP = sub { &Win32::Console::InputCP } if defined &Win32::Console::InputCP; *GetOutputCP = sub { &Win32::Console::OutputCP } if defined &Win32::Console::OutputCP; }; } unless (defined &GetInputCP) { # final fallback *GetInputCP = *GetOutputCP = sub { # another fallback that could work is: # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP ((qx(chcp) || '') =~ /^Active code page: (\d+)/) ? $1 : (); }; } } my $cp = GetInputCP(); $ENCODING_CONSOLE_IN = "cp$cp" if $cp; $cp = GetOutputCP(); $ENCODING_CONSOLE_OUT = "cp$cp" if $cp; } } unless ($ENCODING_LOCALE) { eval { require I18N::Langinfo; $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); # Workaround of Encode < v2.25. The "646" encoding alias was # introduced in Encode-2.25, but we don't want to require that version # quite yet. Should avoid the CPAN testers failure reported from # openbsd-4.7/perl-5.10.0 combo. $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646"; # https://rt.cpan.org/Ticket/Display.html?id=66373 $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"; }; $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN; } # Workaround of Encode < v2.71 for "cp65000" and "cp65001" # The "cp65000" and "cp65001" aliases were added in [Encode v2.71](https://github.com/dankogai/p5-encode/commit/7874bd95aa10967a3b5dbae333d16bcd703ac6c6) # via commit <https://github.com/dankogai/p5-encode/commit/84b9c1101d5251d37e226f80d1c6781718779047>. # This will avoid test failures for Win32 machines using the UTF-7 or UTF-8 code pages. $ENCODING_LOCALE = 'UTF-7' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65000"; $ENCODING_LOCALE = 'utf-8-strict' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65001"; if ($^O eq "darwin") { $ENCODING_LOCALE_FS ||= "UTF-8"; } # final fallback $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8"; $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE; $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE; $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN; unless (Encode::find_encoding($ENCODING_LOCALE)) { my $foundit; if (lc($ENCODING_LOCALE) eq "gb18030") { eval { require Encode::HanExtra; }; if ($@) { die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"; } $foundit++ if Encode::find_encoding($ENCODING_LOCALE); } die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" unless $foundit; } # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT; } _init(); Encode::Alias::define_alias(sub { no strict 'refs'; no warnings 'once'; return ${"ENCODING_" . uc(shift)}; }, "locale"); sub _flush_aliases { no strict 'refs'; for my $a (sort keys %Encode::Alias::Alias) { if (defined ${"ENCODING_" . uc($a)}) { delete $Encode::Alias::Alias{$a}; warn "Flushed alias cache for $a" if DEBUG; } } } sub reinit { $ENCODING_LOCALE = shift; $ENCODING_LOCALE_FS = shift; $ENCODING_CONSOLE_IN = $ENCODING_LOCALE; $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE; _init(); _flush_aliases(); } sub decode_argv { die if defined wantarray; for (@ARGV) { $_ = Encode::decode(locale => $_, @_); } } sub env { my $k = Encode::encode(locale => shift); my $old = $ENV{$k}; if (@_) { my $v = shift; if (defined $v) { $ENV{$k} = Encode::encode(locale => $v); } else { delete $ENV{$k}; } } return Encode::decode(locale => $old) if defined wantarray; } 1; __END__ =head1 NAME ExtUtils::MakeMaker::Locale - bundled Encode::Locale =head1 SYNOPSIS use Encode::Locale; use Encode; $string = decode(locale => $bytes); $bytes = encode(locale => $string); if (-t) { binmode(STDIN, ":encoding(console_in)"); binmode(STDOUT, ":encoding(console_out)"); binmode(STDERR, ":encoding(console_out)"); } # Processing file names passed in as arguments my $uni_filename = decode(locale => $ARGV[0]); open(my $fh, "<", encode(locale_fs => $uni_filename)) || die "Can't open '$uni_filename': $!"; binmode($fh, ":encoding(locale)"); ... =head1 DESCRIPTION In many applications it's wise to let Perl use Unicode for the strings it processes. Most of the interfaces Perl has to the outside world are still byte based. Programs therefore need to decode byte strings that enter the program from the outside and encode them again on the way out. The POSIX locale system is used to specify both the language conventions requested by the user and the preferred character set to consume and output. The C<Encode::Locale> module looks up the charset and encoding (called a CODESET in the locale jargon) and arranges for the L<Encode> module to know this encoding under the name "locale". It means bytes obtained from the environment can be converted to Unicode strings by calling C<< Encode::encode(locale => $bytes) >> and converted back again with C<< Encode::decode(locale => $string) >>. Where file systems interfaces pass file names in and out of the program we also need care. The trend is for operating systems to use a fixed file encoding that don't actually depend on the locale; and this module determines the most appropriate encoding for file names. The L<Encode> module will know this encoding under the name "locale_fs". For traditional Unix systems this will be an alias to the same encoding as "locale". For programs running in a terminal window (called a "Console" on some systems) the "locale" encoding is usually a good choice for what to expect as input and output. Some systems allows us to query the encoding set for the terminal and C<Encode::Locale> will do that if available and make these encodings known under the C<Encode> aliases "console_in" and "console_out". For systems where we can't determine the terminal encoding these will be aliased as the same encoding as "locale". The advice is to use "console_in" for input known to come from the terminal and "console_out" for output to the terminal. In addition to arranging for various Encode aliases the following functions and variables are provided: =over =item decode_argv( ) =item decode_argv( Encode::FB_CROAK ) This will decode the command line arguments to perl (the C<@ARGV> array) in-place. The function will by default replace characters that can't be decoded by "\x{FFFD}", the Unicode replacement character. Any argument provided is passed as CHECK to underlying Encode::decode() call. Pass the value C<Encode::FB_CROAK> to have the decoding croak if not all the command line arguments can be decoded. See L<Encode/"Handling Malformed Data"> for details on other options for CHECK. =item env( $uni_key ) =item env( $uni_key => $uni_value ) Interface to get/set environment variables. Returns the current value as a Unicode string. The $uni_key and $uni_value arguments are expected to be Unicode strings as well. Passing C<undef> as $uni_value deletes the environment variable named $uni_key. The returned value will have the characters that can't be decoded replaced by "\x{FFFD}", the Unicode replacement character. There is no interface to request alternative CHECK behavior as for decode_argv(). If you need that you need to call encode/decode yourself. For example: my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK); my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK); =item reinit( ) =item reinit( $encoding ) Reinitialize the encodings from the locale. You want to call this function if you changed anything in the environment that might influence the locale. This function will croak if the determined encoding isn't recognized by the Encode module. With argument force $ENCODING_... variables to set to the given value. =item $ENCODING_LOCALE The encoding name determined to be suitable for the current locale. L<Encode> know this encoding as "locale". =item $ENCODING_LOCALE_FS The encoding name determined to be suitable for file system interfaces involving file names. L<Encode> know this encoding as "locale_fs". =item $ENCODING_CONSOLE_IN =item $ENCODING_CONSOLE_OUT The encodings to be used for reading and writing output to the a console. L<Encode> know these encodings as "console_in" and "console_out". =back =head1 NOTES This table summarizes the mapping of the encodings set up by the C<Encode::Locale> module: Encode | | | Alias | Windows | Mac OS X | POSIX ------------+---------+--------------+------------ locale | ANSI | nl_langinfo | nl_langinfo locale_fs | ANSI | UTF-8 | nl_langinfo console_in | OEM | nl_langinfo | nl_langinfo console_out | OEM | nl_langinfo | nl_langinfo =head2 Windows Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16 strings) and a byte based API based a character set called ANSI. The regular Perl interfaces to the OS currently only uses the ANSI APIs. Unfortunately ANSI is not a single character set. The encoding that corresponds to ANSI varies between different editions of Windows. For many western editions of Windows ANSI corresponds to CP-1252 which is a character set similar to ISO-8859-1. Conceptually the ANSI character set is a similar concept to the POSIX locale CODESET so this module figures out what the ANSI code page is and make this available as $ENCODING_LOCALE and the "locale" Encoding alias. Windows systems also operate with another byte based character set. It's called the OEM code page. This is the encoding that the Console takes as input and output. It's common for the OEM code page to differ from the ANSI code page. =head2 Mac OS X On Mac OS X the file system encoding is always UTF-8 while the locale can otherwise be set up as normal for POSIX systems. File names on Mac OS X will at the OS-level be converted to NFD-form. A file created by passing a NFC-filename will come in NFD-form from readdir(). See L<Unicode::Normalize> for details of NFD/NFC. Actually, Apple does not follow the Unicode NFD standard since not all character ranges are decomposed. The claim is that this avoids problems with round trip conversions from old Mac text encodings. See L<Encode::UTF8Mac> for details. =head2 POSIX (Linux and other Unixes) File systems might vary in what encoding is to be used for filenames. Since this module has no way to actually figure out what the is correct it goes with the best guess which is to assume filenames are encoding according to the current locale. Users are advised to always specify UTF-8 as the locale charset. =head1 SEE ALSO L<I18N::Langinfo>, L<Encode>, L<Term::Encoding> =head1 AUTHOR Copyright 2010 Gisle Aas <gisle@aas.no>. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/ExtUtils/MakeMaker/version/vpp.pm 0000444 00000055021 14711217702 0014044 0 ustar 00 #--------------------------------------------------------------------------# # This is a modified copy of version.pm 0.9909, bundled exclusively for # use by ExtUtils::Makemaker and its dependencies to bootstrap when # version.pm is not available. It should not be used by ordinary modules. #--------------------------------------------------------------------------# package ExtUtils::MakeMaker::charstar; # a little helper class to emulate C char* semantics in Perl # so that prescan_version can use the same code as in C use overload ( '""' => \&thischar, '0+' => \&thischar, '++' => \&increment, '--' => \&decrement, '+' => \&plus, '-' => \&minus, '*' => \&multiply, 'cmp' => \&cmp, '<=>' => \&spaceship, 'bool' => \&thischar, '=' => \&clone, ); sub new { my ($self, $string) = @_; my $class = ref($self) || $self; my $obj = { string => [split(//,$string)], current => 0, }; return bless $obj, $class; } sub thischar { my ($self) = @_; my $last = $#{$self->{string}}; my $curr = $self->{current}; if ($curr >= 0 && $curr <= $last) { return $self->{string}->[$curr]; } else { return ''; } } sub increment { my ($self) = @_; $self->{current}++; } sub decrement { my ($self) = @_; $self->{current}--; } sub plus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} += $offset; return $rself; } sub minus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} -= $offset; return $rself; } sub multiply { my ($left, $right, $swapped) = @_; my $char = $left->thischar(); return $char * $right; } sub spaceship { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already $right = $left->new($right); } return $left->{current} <=> $right->{current}; } sub cmp { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already if (length($right) == 1) { # comparing single character only return $left->thischar cmp $right; } $right = $left->new($right); } return $left->currstr cmp $right->currstr; } sub bool { my ($self) = @_; my $char = $self->thischar; return ($char ne ''); } sub clone { my ($left, $right, $swapped) = @_; $right = { string => [@{$left->{string}}], current => $left->{current}, }; return bless $right, ref($left); } sub currstr { my ($self, $s) = @_; my $curr = $self->{current}; my $last = $#{$self->{string}}; if (defined($s) && $s->{current} < $last) { $last = $s->{current}; } my $string = join('', @{$self->{string}}[$curr..$last]); return $string; } package ExtUtils::MakeMaker::version::vpp; use 5.006001; use strict; use warnings; use Config; use vars qw($VERSION $CLASS @ISA $LAX $STRICT); $VERSION = '7.62'; $VERSION =~ tr/_//d; $CLASS = 'ExtUtils::MakeMaker::version::vpp'; require ExtUtils::MakeMaker::version::regex; *ExtUtils::MakeMaker::version::vpp::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; *ExtUtils::MakeMaker::version::vpp::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, '+' => \&vnoop, '-' => \&vnoop, '*' => \&vnoop, '/' => \&vnoop, '+=' => \&vnoop, '-=' => \&vnoop, '*=' => \&vnoop, '/=' => \&vnoop, 'abs' => \&vnoop, ); eval "use warnings"; if ($@) { eval ' package warnings; sub enabled {return $^W;} 1; '; } sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { no warnings; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { no warnings; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } my $VERSION_MAX = 0x7FFFFFFF; # implement prescan_version as closely to the C version as possible use constant TRUE => 1; use constant FALSE => 0; sub isDIGIT { my ($char) = shift->thischar(); return ($char =~ /\d/); } sub isALPHA { my ($char) = shift->thischar(); return ($char =~ /[a-zA-Z]/); } sub isSPACE { my ($char) = shift->thischar(); return ($char =~ /\s/); } sub BADVERSION { my ($s, $errstr, $error) = @_; if ($errstr) { $$errstr = $error; } return $s; } sub prescan_version { my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; my $qv = defined $sqv ? $$sqv : FALSE; my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; my $width = defined $swidth ? $$swidth : 3; my $alpha = defined $salpha ? $$salpha : FALSE; my $d = $s; if ($qv && isDIGIT($d)) { goto dotted_decimal_version; } if ($d eq 'v') { # explicit v-string $d++; if (isDIGIT($d)) { $qv = TRUE; } else { # degenerate v-string # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)) { # no leading zeros allowed return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } while (isDIGIT($d)) { # integer part $d++; } if ($d eq '.') { $saw_decimal++; $d++; # decimal point } else { if ($strict) { # require v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } else { goto version_prescan_finish; } } { my $i = 0; my $j = 0; while (isDIGIT($d)) { # just keep reading $i++; while (isDIGIT($d)) { $d++; $j++; # maximum 3 digits between decimal if ($strict && $j > 3) { return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); } } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } $d++; $alpha = TRUE; } elsif ($d eq '.') { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } $saw_decimal++; $d++; } elsif (!isDIGIT($d)) { last; } $j = 0; } if ($strict && $i < 2) { # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } } } # end if dotted-decimal else { # decimal versions my $j = 0; # special $strict case for leading '.' or '0' if ($strict) { if ($d eq '.') { return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); } if ($d eq '0' && isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } } # and we never support negative version numbers if ($d eq '-') { return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); } # consume all of the integer part while (isDIGIT($d)) { $d++; } # look for a fractional part if ($d eq '.') { # we found it, so consume it $saw_decimal++; $d++; } elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { if ( $d == $s ) { # found nothing return BADVERSION($s,$errstr,"Invalid version format (version required)"); } # found just an integer goto version_prescan_finish; } elsif ( $d == $s ) { # didn't find either integer or period return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } elsif ($d eq '_') { # underscore can't come after integer part if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } elsif (isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); } else { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } } elsif ($d) { # anything else after integer part is just invalid data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } # scan the fractional part after the decimal point if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { # $strict or lax-but-not-the-end return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); } while (isDIGIT($d)) { $d++; $j++; if ($d eq '.' && isDIGIT($d-1)) { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); } $d = $s; # start all over again $qv = TRUE; goto dotted_decimal_version; } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } if ( ! isDIGIT($d+1) ) { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } $width = $j; $d++; $alpha = TRUE; } } } version_prescan_finish: while (isSPACE($d)) { $d++; } if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { # trailing non-numeric data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } if (defined $sqv) { $$sqv = $qv; } if (defined $swidth) { $$swidth = $width; } if (defined $ssaw_decimal) { $$ssaw_decimal = $saw_decimal; } if (defined $salpha) { $$salpha = $alpha; } return $d; } sub scan_version { my ($s, $rv, $qv) = @_; my $start; my $pos; my $last; my $errstr; my $saw_decimal = 0; my $width = 3; my $alpha = FALSE; my $vinf = FALSE; my @av; $s = new ExtUtils::MakeMaker::charstar $s; while (isSPACE($s)) { # leading whitespace is OK $s++; } $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, \$width, \$alpha); if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { require Carp; Carp::croak($errstr); } } $start = $s; if ($s eq 'v') { $s++; } $pos = $s; if ( $qv ) { $$rv->{qv} = $qv; } if ( $alpha ) { $$rv->{alpha} = $alpha; } if ( !$qv && $width < 3 ) { $$rv->{width} = $width; } while (isDIGIT($pos)) { $pos++; } if (!isALPHA($pos)) { my $rev; for (;;) { $rev = 0; { # this is atoi() that delimits on underscores my $end = $pos; my $mult = 1; my $orev; # the following if() will only be true after the decimal # point of a version originally created with a bare # floating point number, i.e. not quoted in any way # if ( !$qv && $s > $start && $saw_decimal == 1 ) { $mult *= 100; while ( $s < $end ) { $orev = $rev; $rev += $s * $mult; $mult /= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version %d", $VERSION_MAX); $s = $end - 1; $rev = $VERSION_MAX; $vinf = 1; } $s++; if ( $s eq '_' ) { $s++; } } } else { while (--$end >= $s) { $orev = $rev; $rev += $end * $mult; $mult *= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version"); $end = $s - 1; $rev = $VERSION_MAX; $vinf = 1; } } } } # Append revision push @av, $rev; if ( $vinf ) { $s = $last; last; } elsif ( $pos eq '.' ) { $s = ++$pos; } elsif ( $pos eq '_' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( $pos eq ',' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( isDIGIT($pos) ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( isDIGIT($pos) ) { $pos++; } } else { my $digits = 0; while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { if ( $pos ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = $#av; # This for loop appears to trigger a compiler bug on OS X, as it # loops infinitely. Yes, len is negative. No, it makes no sense. # Compiler in question is: # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) # for ( len = 2 - len; len > 0; len-- ) # av_push(MUTABLE_AV(sv), newSViv(0)); # $len = 2 - $len; while ($len-- > 0) { push @av, 0; } } # need to save off the current version string for later if ( $vinf ) { $$rv->{original} = "v.Inf"; $$rv->{vinf} = 1; } elsif ( $s > $start ) { $$rv->{original} = $start->currstr($s); if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { # need to insert a v to be consistent $$rv->{original} = 'v' . $$rv->{original}; } } else { $$rv->{original} = '0'; push(@av, 0); } # And finally, store the AV in the hash $$rv->{version} = \@av; # fix RT#19517 - special case 'undef' as string if ($s eq 'undef') { $s += 5; } return $s; } sub new { my $class = shift; unless (defined $class or $#_ > 1) { require Carp; Carp::croak('Usage: version::new(class, version)'); } my $self = bless ({}, ref ($class) || $class); my $qv = FALSE; if ( $#_ == 1 ) { # must be CVS-style $qv = TRUE; } my $value = pop; # always going to be the last element if ( ref($value) && eval('$value->isa("version")') ) { # Can copy the elements directly $self->{version} = [ @{$value->{version} } ]; $self->{qv} = 1 if $value->{qv}; $self->{alpha} = 1 if $value->{alpha}; $self->{original} = ''.$value->{original}; return $self; } if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison # or someone forgot to pass a value push @{$self->{version}}, 0; $self->{original} = "0"; return ($self); } if (ref($value) =~ m/ARRAY|HASH/) { require Carp; Carp::croak("Invalid version format (non-numeric data)"); } $value = _un_vstring($value); if ($Config{d_setlocale} && eval { require POSIX } ) { require locale; my $currlocale = POSIX::setlocale(&POSIX::LC_ALL); # if the current locale uses commas for decimal points, we # just replace commas with decimal places, rather than changing # locales if ( POSIX::localeconv()->{decimal_point} eq ',' ) { $value =~ tr/,/./; } } # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } my $s = scan_version($value, \$self, $qv); if ($s) { # must be something left over warn("Version string '%s' contains invalid data; " ."ignoring: '%s'", $value, $s); } return ($self); } *parse = \&new; sub numify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $width = $self->{width} || 3; my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("%d.", $digit ); for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; if ( $width < 3 ) { my $denom = 10**(3-$width); my $quot = int($digit/$denom); my $rem = $digit - ($quot * $denom); $string .= sprintf("%0".$width."d_%d", $quot, $rem); } else { $string .= sprintf("%03d", $digit); } } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha && $width == 3 ) { $string .= "_"; } $string .= sprintf("%0".$width."d", $digit); } else # $len = 0 { $string .= sprintf("000"); } return $string; } sub normal { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("v%d", $digit ); for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf(".%d", $digit); } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha ) { $string .= sprintf("_%0d", $digit); } else { $string .= sprintf(".%0d", $digit); } } if ( $len <= 2 ) { for ( $len = 2 - $len; $len != 0; $len-- ) { $string .= sprintf(".%0d", 0); } } return $string; } sub stringify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } return exists $self->{original} ? $self->{original} : exists $self->{qv} ? $self->normal : $self->numify; } sub vcmp { require UNIVERSAL; my ($left,$right,$swap) = @_; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } if ( $swap ) { ($left, $right) = ($right, $left); } unless (_verify($left)) { require Carp; Carp::croak("Invalid version object"); } unless (_verify($right)) { require Carp; Carp::croak("Invalid version format"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; my $m = $l < $r ? $l : $r; my $lalpha = $left->is_alpha; my $ralpha = $right->is_alpha; my $retval = 0; my $i = 0; while ( $i <= $m && $retval == 0 ) { $retval = $left->{version}[$i] <=> $right->{version}[$i]; $i++; } # tiebreaker for alpha with identical terms if ( $retval == 0 && $l == $r && $left->{version}[$m] == $right->{version}[$m] && ( $lalpha || $ralpha ) ) { if ( $lalpha && !$ralpha ) { $retval = -1; } elsif ( $ralpha && !$lalpha) { $retval = +1; } } # possible match except for trailing 0's if ( $retval == 0 && $l != $r ) { if ( $l < $r ) { while ( $i <= $r && $retval == 0 ) { if ( $right->{version}[$i] != 0 ) { $retval = -1; # not a match after all } $i++; } } else { while ( $i <= $l && $retval == 0 ) { if ( $left->{version}[$i] != 0 ) { $retval = +1; # not a match after all } $i++; } } } return $retval; } sub vbool { my ($self) = @_; return vcmp($self,$self->new("0"),1); } sub vnoop { require Carp; Carp::croak("operation not supported with version object"); } sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); } sub qv { my $value = shift; my $class = $CLASS; if (@_) { $class = ref($value) || $value; $value = shift; } $value = _un_vstring($value); $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; my $obj = $CLASS->new($value); return bless $obj, $class; } *declare = \&qv; sub is_qv { my ($self) = @_; return (exists $self->{qv}); } sub _verify { my ($self) = @_; if ( ref($self) && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; } else { return 0; } } sub _is_non_alphanumeric { my $s = shift; $s = new ExtUtils::MakeMaker::charstar $s; while ($s) { return 0 if isSPACE($s); # early out return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); $s++; } return 0; } sub _un_vstring { my $value = shift; # may be a v-string if ( length($value) >= 3 && $value !~ /[._]/ && _is_non_alphanumeric($value)) { my $tvalue; if ( "$]" >= 5.008_001 ) { $tvalue = _find_magic_vstring($value); $value = $tvalue if length $tvalue; } elsif ( "$]" >= 5.006_000 ) { $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) { # must be a v-string $value = $tvalue; } } } return $value; } sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } sub _VERSION { my ($obj, $req) = @_; my $class = ref($obj) || $obj; no strict 'refs'; if ( exists $INC{"$class.pm"} and not %{"$class\::"} and "$]" >= 5.008) { # file but no package require Carp; Carp::croak( "$class defines neither package nor VERSION" ."--version check failed"); } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { local $^W if "$]" <= 5.008; $version = ExtUtils::MakeMaker::version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { require Carp; my $msg = "$]" < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed"; if ( $ENV{VERSION_DEBUG} ) { Carp::confess($msg); } else { Carp::croak($msg); } } $req = ExtUtils::MakeMaker::version::vpp->new($req); if ( $req > $version ) { require Carp; if ( $req->is_qv ) { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->normal, $version->normal) ); } else { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->stringify, $version->stringify) ); } } } return defined $version ? $version->stringify : undef; } 1; #this line is important and will help the module return a true value perl5/ExtUtils/MakeMaker/version/regex.pm 0000444 00000010656 14711217707 0014363 0 ustar 00 #--------------------------------------------------------------------------# # This is a modified copy of version.pm 0.9909, bundled exclusively for # use by ExtUtils::Makemaker and its dependencies to bootstrap when # version.pm is not available. It should not be used by ordinary modules. #--------------------------------------------------------------------------# package ExtUtils::MakeMaker::version::regex; use strict; use warnings; use vars qw($VERSION $CLASS $STRICT $LAX); $VERSION = '7.62'; $VERSION =~ tr/_//d; #--------------------------------------------------------------------------# # Version regexp components #--------------------------------------------------------------------------# # Fraction part of a decimal version number. This is a common part of # both strict and lax decimal versions my $FRACTION_PART = qr/\.[0-9]+/; # First part of either decimal or dotted-decimal strict version number. # Unsigned integer with no leading zeroes (except for zero itself) to # avoid confusion with octal. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; # First part of either decimal or dotted-decimal lax version number. # Unsigned integer, but allowing leading zeros. Always interpreted # as decimal. However, some forms of the resulting syntax give odd # results if used as ordinary Perl expressions, due to how perl treats # octals. E.g. # version->new("010" ) == 10 # version->new( 010 ) == 8 # version->new( 010.2) == 82 # "8" . "2" my $LAX_INTEGER_PART = qr/[0-9]+/; # Second and subsequent part of a strict dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. # Limited to three digits to avoid overflow when converting to decimal # form and also avoid problematic style with excessive leading zeroes. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; # Second and subsequent part of a lax dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. No # limit on the numerical value or number of digits, so there is the # possibility of overflow when converting to decimal form. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; # Alpha suffix part of lax version number syntax. Acts like a # dotted-decimal part. my $LAX_ALPHA_PART = qr/_[0-9]+/; #--------------------------------------------------------------------------# # Strict version regexp definitions #--------------------------------------------------------------------------# # Strict decimal version number. my $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; # Strict dotted-decimal version number. Must have both leading "v" and # at least three parts, to avoid confusion with decimal syntax. my $STRICT_DOTTED_DECIMAL_VERSION = qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; # Complete strict version number syntax -- should generally be used # anchored: qr/ \A $STRICT \z /x $STRICT = qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Lax version regexp definitions #--------------------------------------------------------------------------# # Lax decimal version number. Just like the strict one except for # allowing an alpha suffix or allowing a leading or trailing # decimal-point my $LAX_DECIMAL_VERSION = qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | $FRACTION_PART $LAX_ALPHA_PART? /x; # Lax dotted-decimal version number. Distinguished by having either # leading "v" or at least three non-alpha parts. Alpha part is only # permitted if there are at least two non-alpha parts. Strangely # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, # so when there is no "v", the leading part is optional my $LAX_DOTTED_DECIMAL_VERSION = qr/ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? /x; # Complete lax version number syntax -- should generally be used # anchored: qr/ \A $LAX \z /x # # The string 'undef' is a special case to make for easier handling # of return values from ExtUtils::MM->parse_version $LAX = qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Preloaded methods go here. sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } 1; perl5/ExtUtils/MakeMaker/Config.pm 0000444 00000001132 14711217710 0012750 0 ustar 00 package ExtUtils::MakeMaker::Config; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use Config (); # Give us an overridable config. our %Config = %Config::Config; sub import { my $caller = caller; no strict 'refs'; ## no critic *{$caller.'::Config'} = \%Config; } 1; =head1 NAME ExtUtils::MakeMaker::Config - Wrapper around Config.pm =head1 SYNOPSIS use ExtUtils::MakeMaker::Config; print $Config{installbin}; # or whatever =head1 DESCRIPTION B<FOR INTERNAL USE ONLY> A very thin wrapper around Config.pm so MakeMaker is easier to test. =cut perl5/ExtUtils/MakeMaker/FAQ.pod 0000444 00000047512 14711217712 0012336 0 ustar 00 package ExtUtils::MakeMaker::FAQ; our $VERSION = '7.62'; $VERSION =~ tr/_//d; 1; __END__ =head1 NAME ExtUtils::MakeMaker::FAQ - Frequently Asked Questions About MakeMaker =head1 DESCRIPTION FAQs, tricks and tips for L<ExtUtils::MakeMaker>. =head2 Module Installation =over 4 =item How do I install a module into my home directory? If you're not the Perl administrator you probably don't have permission to install a module to its default location. Ways of handling this with a B<lot> less manual effort on your part are L<perlbrew> and L<local::lib>. Otherwise, you can install it for your own use into your home directory like so: # Non-unix folks, replace ~ with /path/to/your/home/dir perl Makefile.PL INSTALL_BASE=~ This will put modules into F<~/lib/perl5>, man pages into F<~/man> and programs into F<~/bin>. To ensure your Perl programs can see these newly installed modules, set your C<PERL5LIB> environment variable to F<~/lib/perl5> or tell each of your programs to look in that directory with the following: use lib "$ENV{HOME}/lib/perl5"; or if $ENV{HOME} isn't set and you don't want to set it for some reason, do it the long way. use lib "/path/to/your/home/dir/lib/perl5"; =item How do I get MakeMaker and Module::Build to install to the same place? Module::Build, as of 0.28, supports two ways to install to the same location as MakeMaker. We highly recommend the install_base method, its the simplest and most closely approximates the expected behavior of an installation prefix. 1) Use INSTALL_BASE / C<--install_base> MakeMaker (as of 6.31) and Module::Build (as of 0.28) both can install to the same locations using the "install_base" concept. See L<ExtUtils::MakeMaker/INSTALL_BASE> for details. To get MM and MB to install to the same location simply set INSTALL_BASE in MM and C<--install_base> in MB to the same location. perl Makefile.PL INSTALL_BASE=/whatever perl Build.PL --install_base /whatever This works most like other language's behavior when you specify a prefix. We recommend this method. 2) Use PREFIX / C<--prefix> Module::Build 0.28 added support for C<--prefix> which works like MakeMaker's PREFIX. perl Makefile.PL PREFIX=/whatever perl Build.PL --prefix /whatever We highly discourage this method. It should only be used if you know what you're doing and specifically need the PREFIX behavior. The PREFIX algorithm is complicated and focused on matching the system installation. =item How do I keep from installing man pages? Recent versions of MakeMaker will only install man pages on Unix-like operating systems by default. To generate manpages on non-Unix operating systems, make the "manifypods" target. For an individual module: perl Makefile.PL INSTALLMAN1DIR=none INSTALLMAN3DIR=none If you want to suppress man page installation for all modules you have to reconfigure Perl and tell it 'none' when it asks where to install man pages. =item How do I use a module without installing it? Two ways. One is to build the module normally... perl Makefile.PL make make test ...and then use L<blib> to point Perl at the built but uninstalled module: perl -Mblib script.pl perl -Mblib -e '...' The other is to install the module in a temporary location. perl Makefile.PL INSTALL_BASE=~/tmp make make test make install And then set PERL5LIB to F<~/tmp/lib/perl5>. This works well when you have multiple modules to work with. It also ensures that the module goes through its full installation process which may modify it. Again, L<local::lib> may assist you here. =item How can I organize tests into subdirectories and have them run? Let's take the following test directory structure: t/foo/sometest.t t/bar/othertest.t t/bar/baz/anothertest.t Now, inside of the C<WriteMakeFile()> function in your F<Makefile.PL>, specify where your tests are located with the C<test> directive: test => {TESTS => 't/*.t t/*/*.t t/*/*/*.t'} The first entry in the string will run all tests in the top-level F<t/> directory. The second will run all test files located in any subdirectory under F<t/>. The third, runs all test files within any subdirectory within any other subdirectory located under F<t/>. Note that you do not have to use wildcards. You can specify explicitly which subdirectories to run tests in: test => {TESTS => 't/*.t t/foo/*.t t/bar/baz/*.t'} =item PREFIX vs INSTALL_BASE from Module::Build::Cookbook The behavior of PREFIX is complicated and depends closely on how your Perl is configured. The resulting installation locations will vary from machine to machine and even different installations of Perl on the same machine. Because of this, its difficult to document where prefix will place your modules. In contrast, INSTALL_BASE has predictable, easy to explain installation locations. Now that Module::Build and MakeMaker both have INSTALL_BASE there is little reason to use PREFIX other than to preserve your existing installation locations. If you are starting a fresh Perl installation we encourage you to use INSTALL_BASE. If you have an existing installation installed via PREFIX, consider moving it to an installation structure matching INSTALL_BASE and using that instead. =item Generating *.pm files with substitutions eg of $VERSION If you want to configure your module files for local conditions, or to automatically insert a version number, you can use EUMM's C<PL_FILES> capability, where it will automatically run each F<*.PL> it finds to generate its basename. For instance: # Makefile.PL: require 'common.pl'; my $version = get_version(); my @pms = qw(Foo.pm); WriteMakefile( NAME => 'Foo', VERSION => $version, PM => { map { ($_ => "\$(INST_LIB)/$_") } @pms }, clean => { FILES => join ' ', @pms }, ); # common.pl: sub get_version { '0.04' } sub process { my $v = get_version(); s/__VERSION__/$v/g; } 1; # Foo.pm.PL: require 'common.pl'; $_ = join '', <DATA>; process(); my $file = shift; open my $fh, '>', $file or die "$file: $!"; print $fh $_; __DATA__ package Foo; our $VERSION = '__VERSION__'; 1; You may notice that C<PL_FILES> is not specified above, since the default of mapping each .PL file to its basename works well. If the generated module were architecture-specific, you could replace C<$(INST_LIB)> above with C<$(INST_ARCHLIB)>, although if you locate modules under F<lib>, that would involve ensuring any C<lib/> in front of the module location were removed. =back =head2 Common errors and problems =over 4 =item "No rule to make target `/usr/lib/perl5/CORE/config.h', needed by `Makefile'" Just what it says, you're missing that file. MakeMaker uses it to determine if perl has been rebuilt since the Makefile was made. It's a bit of a bug that it halts installation. Some operating systems don't ship the CORE directory with their base perl install. To solve the problem, you likely need to install a perl development package such as perl-devel (CentOS, Fedora and other Redhat systems) or perl (Ubuntu and other Debian systems). =back =head2 Philosophy and History =over 4 =item Why not just use <insert other build config tool here>? Why did MakeMaker reinvent the build configuration wheel? Why not just use autoconf or automake or ppm or Ant or ... There are many reasons, but the major one is cross-platform compatibility. Perl is one of the most ported pieces of software ever. It works on operating systems I've never even heard of (see perlport for details). It needs a build tool that can work on all those platforms and with any wacky C compilers and linkers they might have. No such build tool exists. Even make itself has wildly different dialects. So we have to build our own. =item What is Module::Build and how does it relate to MakeMaker? Module::Build is a project by Ken Williams to supplant MakeMaker. Its primary advantages are: =over 8 =item * pure perl. no make, no shell commands =item * easier to customize =item * cleaner internals =item * less cruft =back Module::Build was long the official heir apparent to MakeMaker. The rate of both its development and adoption has slowed in recent years, though, and it is unclear what the future holds for it. That said, Module::Build set the stage for I<something> to become the heir to MakeMaker. MakeMaker's maintainers have long said that it is a dead end and should be kept functioning, while being cautious about extending with new features. =back =head2 Module Writing =over 4 =item How do I keep my $VERSION up to date without resetting it manually? Often you want to manually set the $VERSION in the main module distribution because this is the version that everybody sees on CPAN and maybe you want to customize it a bit. But for all the other modules in your dist, $VERSION is really just bookkeeping and all that's important is it goes up every time the module is changed. Doing this by hand is a pain and you often forget. Probably the easiest way to do this is using F<perl-reversion> in L<Perl::Version>: perl-reversion -bump If your version control system supports revision numbers (git doesn't easily), the simplest way to do it automatically is to use its revision number (you are using version control, right?). In CVS, RCS and SVN you use $Revision$ (see the documentation of your version control system for details). Every time the file is checked in the $Revision$ will be updated, updating your $VERSION. SVN uses a simple integer for $Revision$ so you can adapt it for your $VERSION like so: ($VERSION) = q$Revision$ =~ /(\d+)/; In CVS and RCS version 1.9 is followed by 1.10. Since CPAN compares version numbers numerically we use a sprintf() to convert 1.9 to 1.009 and 1.10 to 1.010 which compare properly. $VERSION = sprintf "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/g; If branches are involved (ie. $Revision: 1.5.3.4$) it's a little more complicated. # must be all on one line or MakeMaker will get confused. $VERSION = do { my @r = (q$Revision$ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r }; In SVN, $Revision$ should be the same for every file in the project so they would all have the same $VERSION. CVS and RCS have a different $Revision$ per file so each file will have a different $VERSION. Distributed version control systems, such as SVK, may have a different $Revision$ based on who checks out the file, leading to a different $VERSION on each machine! Finally, some distributed version control systems, such as darcs, have no concept of revision number at all. =item What's this F<META.yml> thing and how did it get in my F<MANIFEST>?! F<META.yml> is a module meta-data file pioneered by Module::Build and automatically generated as part of the 'distdir' target (and thus 'dist'). See L<ExtUtils::MakeMaker/"Module Meta-Data">. To shut off its generation, pass the C<NO_META> flag to C<WriteMakefile()>. =item How do I delete everything not in my F<MANIFEST>? Some folks are surprised that C<make distclean> does not delete everything not listed in their MANIFEST (thus making a clean distribution) but only tells them what they need to delete. This is done because it is considered too dangerous. While developing your module you might write a new file, not add it to the MANIFEST, then run a C<distclean> and be sad because your new work was deleted. If you really want to do this, you can use C<ExtUtils::Manifest::manifind()> to read the MANIFEST and File::Find to delete the files. But you have to be careful. Here's a script to do that. Use at your own risk. Have fun blowing holes in your foot. #!/usr/bin/perl -w use strict; use File::Spec; use File::Find; use ExtUtils::Manifest qw(maniread); my %manifest = map {( $_ => 1 )} grep { File::Spec->canonpath($_) } keys %{ maniread() }; if( !keys %manifest ) { print "No files found in MANIFEST. Stopping.\n"; exit; } find({ wanted => sub { my $path = File::Spec->canonpath($_); return unless -f $path; return if exists $manifest{ $path }; print "unlink $path\n"; unlink $path; }, no_chdir => 1 }, "." ); =item Which tar should I use on Windows? We recommend ptar from Archive::Tar not older than 1.66 with '-C' option. =item Which zip should I use on Windows for '[ndg]make zipdist'? We recommend InfoZIP: L<http://www.info-zip.org/Zip.html> =back =head2 XS =over 4 =item How do I prevent "object version X.XX does not match bootstrap parameter Y.YY" errors? XS code is very sensitive to the module version number and will complain if the version number in your Perl module doesn't match. If you change your module's version # without rerunning Makefile.PL the old version number will remain in the Makefile, causing the XS code to be built with the wrong number. To avoid this, you can force the Makefile to be rebuilt whenever you change the module containing the version number by adding this to your WriteMakefile() arguments. depend => { '$(FIRST_MAKEFILE)' => '$(VERSION_FROM)' } =item How do I make two or more XS files coexist in the same directory? Sometimes you need to have two and more XS files in the same package. There are three ways: C<XSMULTI>, separate directories, and bootstrapping one XS from another. =over 8 =item XSMULTI Structure your modules so they are all located under F<lib>, such that C<Foo::Bar> is in F<lib/Foo/Bar.pm> and F<lib/Foo/Bar.xs>, etc. Have your top-level C<WriteMakefile> set the variable C<XSMULTI> to a true value. Er, that's it. =item Separate directories Put each XS files into separate directories, each with their own F<Makefile.PL>. Make sure each of those F<Makefile.PL>s has the correct C<CFLAGS>, C<INC>, C<LIBS> etc. You will need to make sure the top-level F<Makefile.PL> refers to each of these using C<DIR>. =item Bootstrapping Let's assume that we have a package C<Cool::Foo>, which includes C<Cool::Foo> and C<Cool::Bar> modules each having a separate XS file. First we use the following I<Makefile.PL>: use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Cool::Foo', VERSION_FROM => 'Foo.pm', OBJECT => q/$(O_FILES)/, # ... other attrs ... ); Notice the C<OBJECT> attribute. MakeMaker generates the following variables in I<Makefile>: # Handy lists of source code files: XS_FILES= Bar.xs \ Foo.xs C_FILES = Bar.c \ Foo.c O_FILES = Bar.o \ Foo.o Therefore we can use the C<O_FILES> variable to tell MakeMaker to use these objects into the shared library. That's pretty much it. Now write I<Foo.pm> and I<Foo.xs>, I<Bar.pm> and I<Bar.xs>, where I<Foo.pm> bootstraps the shared library and I<Bar.pm> simply loading I<Foo.pm>. The only issue left is to how to bootstrap I<Bar.xs>. This is done from I<Foo.xs>: MODULE = Cool::Foo PACKAGE = Cool::Foo BOOT: # boot the second XS file boot_Cool__Bar(aTHX_ cv); If you have more than two files, this is the place where you should boot extra XS files from. The following four files sum up all the details discussed so far. Foo.pm: ------- package Cool::Foo; require DynaLoader; our @ISA = qw(DynaLoader); our $VERSION = '0.01'; bootstrap Cool::Foo $VERSION; 1; Bar.pm: ------- package Cool::Bar; use Cool::Foo; # bootstraps Bar.xs 1; Foo.xs: ------- #include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = Cool::Foo PACKAGE = Cool::Foo BOOT: # boot the second XS file boot_Cool__Bar(aTHX_ cv); MODULE = Cool::Foo PACKAGE = Cool::Foo PREFIX = cool_foo_ void cool_foo_perl_rules() CODE: fprintf(stderr, "Cool::Foo says: Perl Rules\n"); Bar.xs: ------- #include "EXTERN.h" #include "perl.h" #include "XSUB.h" MODULE = Cool::Bar PACKAGE = Cool::Bar PREFIX = cool_bar_ void cool_bar_perl_rules() CODE: fprintf(stderr, "Cool::Bar says: Perl Rules\n"); And of course a very basic test: t/cool.t: -------- use Test; BEGIN { plan tests => 1 }; use Cool::Foo; use Cool::Bar; Cool::Foo::perl_rules(); Cool::Bar::perl_rules(); ok 1; This tip has been brought to you by Nick Ing-Simmons and Stas Bekman. An alternative way to achieve this can be seen in L<Gtk2::CodeGen> and L<Glib::CodeGen>. =back =back =head1 DESIGN =head2 MakeMaker object hierarchy (simplified) What most people need to know (superclasses on top.) ExtUtils::MM_Any | ExtUtils::MM_Unix | ExtUtils::MM_{Current OS} | ExtUtils::MakeMaker | MY The object actually used is of the class L<MY|ExtUtils::MY> which allows you to override bits of MakeMaker inside your Makefile.PL by declaring MY::foo() methods. =head2 MakeMaker object hierarchy (real) Here's how it really works: ExtUtils::MM_Any | ExtUtils::MM_Unix | ExtUtils::Liblist::Kid ExtUtils::MM_{Current OS} (if necessary) | | ExtUtils::Liblist ExtUtils::MakeMaker | | | | | | |----------------------- ExtUtils::MM | | ExtUtils::MY MM (created by ExtUtils::MM) | | MY (created by ExtUtils::MY) | . | (mixin) | . | PACK### (created each call to ExtUtils::MakeMaker->new) NOTE: Yes, this is a mess. See L<http://archive.develooper.com/makemaker@perl.org/msg00134.html> for some history. NOTE: When L<ExtUtils::MM> is loaded it chooses a superclass for MM from amongst the ExtUtils::MM_* modules based on the current operating system. NOTE: ExtUtils::MM_{Current OS} represents one of the ExtUtils::MM_* modules except L<ExtUtils::MM_Any> chosen based on your operating system. NOTE: The main object used by MakeMaker is a PACK### object, *not* L<ExtUtils::MakeMaker>. It is, effectively, a subclass of L<MY|ExtUtils::MY>, L<ExtUtils::MakeMaker>, L<ExtUtils::Liblist> and ExtUtils::MM_{Current OS} NOTE: The methods in L<MY|ExtUtils::MY> are simply copied into PACK### rather than MY being a superclass of PACK###. I don't remember the rationale. NOTE: L<ExtUtils::Liblist> should be removed from the inheritance hiearchy and simply be called as functions. NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity. =head2 The MM_* hierarchy MM_Win95 MM_NW5 \ / MM_BeOS MM_Cygwin MM_OS2 MM_VMS MM_Win32 MM_DOS MM_UWIN \ | | | / / / ------------------------------------------------ | | MM_Unix | | | MM_Any NOTE: Each direct L<MM_Unix|ExtUtils::MM_Unix> subclass is also an L<MM_Any|ExtUtils::MM_Any> subclass. This is a temporary hack because MM_Unix overrides some MM_Any methods with Unix specific code. It allows the non-Unix modules to see the original MM_Any implementations. NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity. =head1 PATCHING If you have a question you'd like to see added to the FAQ (whether or not you have the answer) please either: =over 2 =item * make a pull request on the MakeMaker github repository =item * raise a issue on the MakeMaker github repository =item * file an RT ticket =item * email makemaker@perl.org =back =head1 AUTHOR The denizens of makemaker@perl.org. =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut perl5/ExtUtils/MM_MacOS.pm 0000444 00000001605 14711217714 0011252 0 ustar 00 package ExtUtils::MM_MacOS; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; sub new { die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker'; } =head1 NAME ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic =head1 SYNOPSIS # MM_MacOS no longer contains any code. This is just a stub. =head1 DESCRIPTION Once upon a time, MakeMaker could produce an approximation of a correct Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this fell out of sync with the rest of MakeMaker and hadn't worked in years. Since there's little chance of it being repaired, MacOS Classic is fading away, and the code was icky to begin with, the code has been deleted to make maintenance easier. Anyone interested in resurrecting this file should pull the old version from the MakeMaker CVS repository and contact makemaker@perl.org. =cut 1; perl5/ExtUtils/MM_OS390.pm 0000444 00000004335 14711217714 0011070 0 ustar 00 package ExtUtils::MM_OS390; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); =head1 NAME ExtUtils::MM_OS390 - OS390 specific subclass of ExtUtils::MM_Unix =head1 SYNOPSIS Don't use this module directly. Use ExtUtils::MM and let it choose. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for OS390. Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overriden methods =over =item xs_make_dynamic_lib Defines the recipes for the C<dynamic_lib> section. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_; $exportlist = '' if $exportlist ne '$(EXPORT_LIST)'; my $armaybe = $self->_xs_armaybe($attribs); my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || ''); my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; push(@m," \$(ARMAYBE) cr $ldfrom $object\n"); push(@m," \$(RANLIB) $ldfrom\n"); } # For example in AIX the shared objects/libraries from previous builds # linger quite a while in the shared dynalinker cache even when nobody # is using them. This is painful if one for instance tries to restart # a failed build because the link command will fail unnecessarily 'cos # the shared object/library is 'busy'. push(@m," \$(RM_F) \$\@\n"); my $libs = '$(LDLOADLIBS)'; my $ld_run_path_shell = ""; if ($self->{LD_RUN_PATH} ne "") { $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" '; } push @m, sprintf <<'MAKE', $ld_run_path_shell, $dlsyms_arg, $self->xs_obj_opt('$@'), $ldfrom, $libs, $exportlist; %s$(LD) $(LDDLFLAGS) %s $(OTHERLDFLAGS) %s $(MYEXTLIB) %s \ $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \ $(INST_DYNAMIC_FIX) $(CHMOD) $(PERM_RWX) $@ MAKE join '', @m; } 1; =back =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut __END__ perl5/ExtUtils/Mksymlists.pm 0000444 00000025405 14711217715 0012103 0 ustar 00 package ExtUtils::Mksymlists; use 5.006; use strict qw[ subs refs ]; # no strict 'vars'; # until filehandles are exempted use warnings; use Carp; use Exporter; use Config; our @ISA = qw(Exporter); our @EXPORT = qw(&Mksymlists); our $VERSION = '7.62'; $VERSION =~ tr/_//d; sub Mksymlists { my(%spec) = @_; my($osname) = $^O; croak("Insufficient information specified to Mksymlists") unless ( $spec{NAME} or ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) ); $spec{DL_VARS} = [] unless $spec{DL_VARS}; ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; $spec{DL_FUNCS} = { $spec{NAME} => [] } unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or @{$spec{FUNCLIST}}); if (defined $spec{DL_FUNCS}) { foreach my $package (sort keys %{$spec{DL_FUNCS}}) { my($packprefix,$bootseen); ($packprefix = $package) =~ s/\W/_/g; foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) { if ($sym =~ /^boot_/) { push(@{$spec{FUNCLIST}},$sym); $bootseen++; } else { push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym"); } } push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen; } } # We'll need this if we ever add any OS which uses mod2fname # not as pseudo-builtin. # require DynaLoader; if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) { $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]); } if ($osname eq 'aix') { _write_aix(\%spec); } elsif ($osname eq 'MacOS'){ _write_aix(\%spec) } elsif ($osname eq 'VMS') { _write_vms(\%spec) } elsif ($osname eq 'os2') { _write_os2(\%spec) } elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } else { croak("Don't know how to create linker option file for $osname\n"); } } sub _write_aix { my($data) = @_; rename "$data->{FILE}.exp", "$data->{FILE}.exp_old"; open( my $exp, ">", "$data->{FILE}.exp") or croak("Can't create $data->{FILE}.exp: $!\n"); print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; close $exp; } sub _write_os2 { my($data) = @_; require Config; my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); if (not $data->{DLBASE}) { ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; } my $distname = $data->{DISTNAME} || $data->{NAME}; $distname = "Distribution $distname"; my $patchlevel = " pl$Config{perl_patchlevel}" || ''; my $comment = sprintf "Perl (v%s%s%s) module %s", $Config::Config{version}, $threaded, $patchlevel, $data->{NAME}; chomp $comment; if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') { $distname = 'perl5-porters@perl.org'; $comment = "Core $comment"; } $comment = "$comment (Perl-config: $Config{config_args})"; $comment = substr($comment, 0, 200) . "...)" if length $comment > 203; rename "$data->{FILE}.def", "$data->{FILE}_def.old"; open(my $def, ">", "$data->{FILE}.def") or croak("Can't create $data->{FILE}.def: $!\n"); print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n"; print $def "CODE LOADONCALL\n"; print $def "DATA LOADONCALL NONSHARED MULTIPLE\n"; print $def "EXPORTS\n "; print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; _print_imports($def, $data); close $def; } sub _print_imports { my ($def, $data)= @_; my $imports= $data->{IMPORTS} or return; if ( keys %$imports ) { print $def "IMPORTS\n"; foreach my $name (sort keys %$imports) { print $def " $name=$imports->{$name}\n"; } } } sub _write_win32 { my($data) = @_; require Config; if (not $data->{DLBASE}) { ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; } rename "$data->{FILE}.def", "$data->{FILE}_def.old"; open( my $def, ">", "$data->{FILE}.def" ) or croak("Can't create $data->{FILE}.def: $!\n"); # put library name in quotes (it could be a keyword, like 'Alias') if ($Config::Config{'cc'} !~ /\bgcc/i) { print $def "LIBRARY \"$data->{DLBASE}\"\n"; } print $def "EXPORTS\n "; my @syms; # Export public symbols both with and without underscores to # ensure compatibility between DLLs from Borland C and Visual C # NOTE: DynaLoader itself only uses the names without underscores, # so this is only to cover the case when the extension DLL may be # linked to directly from C. GSAR 97-07-10 #bcc dropped in 5.16, so dont create useless extra symbols for export table unless("$]" >= 5.016) { if ($Config::Config{'cc'} =~ /^bcc/i) { push @syms, "_$_", "$_ = _$_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); } else { push @syms, "$_", "_$_ = $_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); } } else { push @syms, "$_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); } print $def join("\n ",@syms, "\n") if @syms; _print_imports($def, $data); close $def; } sub _write_vms { my($data) = @_; require Config; # a reminder for once we do $^O require ExtUtils::XSSymSet; my($isvax) = $Config::Config{'archname'} =~ /VAX/i; my($set) = new ExtUtils::XSSymSet; rename "$data->{FILE}.opt", "$data->{FILE}.opt_old"; open(my $opt,">", "$data->{FILE}.opt") or croak("Can't create $data->{FILE}.opt: $!\n"); # Options file declaring universal symbols # Used when linking shareable image for dynamic extension, # or when linking PerlShr into which we've added this package # as a static extension # We don't do anything to preserve order, so we won't relax # the GSMATCH criteria for a dynamic extension print $opt "case_sensitive=yes\n" if $Config::Config{d_vms_case_sensitive_symbols}; foreach my $sym (@{$data->{FUNCLIST}}) { my $safe = $set->addsym($sym); if ($isvax) { print $opt "UNIVERSAL=$safe\n" } else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; } } foreach my $sym (@{$data->{DL_VARS}}) { my $safe = $set->addsym($sym); print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; if ($isvax) { print $opt "UNIVERSAL=$safe\n" } else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; } } close $opt; } 1; __END__ =head1 NAME ExtUtils::Mksymlists - write linker options files for dynamic extension =head1 SYNOPSIS use ExtUtils::Mksymlists; Mksymlists( NAME => $name , DL_VARS => [ $var1, $var2, $var3 ], DL_FUNCS => { $pkg1 => [ $func1, $func2 ], $pkg2 => [ $func3 ] ); =head1 DESCRIPTION C<ExtUtils::Mksymlists> produces files used by the linker under some OSs during the creation of shared libraries for dynamic extensions. It is normally called from a MakeMaker-generated Makefile when the extension is built. The linker option file is generated by calling the function C<Mksymlists>, which is exported by default from C<ExtUtils::Mksymlists>. It takes one argument, a list of key-value pairs, in which the following keys are recognized: =over 4 =item DLBASE This item specifies the name by which the linker knows the extension, which may be different from the name of the extension itself (for instance, some linkers add an '_' to the name of the extension). If it is not specified, it is derived from the NAME attribute. It is presently used only by OS2 and Win32. =item DL_FUNCS This is identical to the DL_FUNCS attribute available via MakeMaker, from which it is usually taken. Its value is a reference to an associative array, in which each key is the name of a package, and each value is an a reference to an array of function names which should be exported by the extension. For instance, one might say C<DL_FUNCS =E<gt> { Homer::Iliad =E<gt> [ qw(trojans greeks) ], Homer::Odyssey =E<gt> [ qw(travellers family suitors) ] }>. The function names should be identical to those in the XSUB code; C<Mksymlists> will alter the names written to the linker option file to match the changes made by F<xsubpp>. In addition, if none of the functions in a list begin with the string B<boot_>, C<Mksymlists> will add a bootstrap function for that package, just as xsubpp does. (If a B<boot_E<lt>pkgE<gt>> function is present in the list, it is passed through unchanged.) If DL_FUNCS is not specified, it defaults to the bootstrap function for the extension specified in NAME. =item DL_VARS This is identical to the DL_VARS attribute available via MakeMaker, and, like DL_FUNCS, it is usually specified via MakeMaker. Its value is a reference to an array of variable names which should be exported by the extension. =item FILE This key can be used to specify the name of the linker option file (minus the OS-specific extension), if for some reason you do not want to use the default value, which is the last word of the NAME attribute (I<e.g.> for C<Tk::Canvas>, FILE defaults to C<Canvas>). =item FUNCLIST This provides an alternate means to specify function names to be exported from the extension. Its value is a reference to an array of function names to be exported by the extension. These names are passed through unaltered to the linker options file. Specifying a value for the FUNCLIST attribute suppresses automatic generation of the bootstrap function for the package. To still create the bootstrap name you have to specify the package name in the DL_FUNCS hash: Mksymlists( NAME => $name , FUNCLIST => [ $func1, $func2 ], DL_FUNCS => { $pkg => [] } ); =item IMPORTS This attribute is used to specify names to be imported into the extension. It is currently only used by OS/2 and Win32. =item NAME This gives the name of the extension (I<e.g.> C<Tk::Canvas>) for which the linker option file will be produced. =back When calling C<Mksymlists>, one should always specify the NAME attribute. In most cases, this is all that's necessary. In the case of unusual extensions, however, the other attributes can be used to provide additional information to the linker. =head1 AUTHOR Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> =head1 REVISION Last revised 14-Feb-1996, for Perl 5.002. perl5/ExtUtils/Typemaps/InputMap.pm 0000444 00000003642 14711217721 0013257 0 ustar 00 package ExtUtils::Typemaps::InputMap; use 5.006001; use strict; use warnings; our $VERSION = '3.35'; =head1 NAME ExtUtils::Typemaps::InputMap - Entry in the INPUT section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $input = $typemap->get_input_map('T_NV'); my $code = $input->code(); $input->code("..."); =head1 DESCRIPTION Refer to L<ExtUtils::Typemaps> for details. =head1 METHODS =cut =head2 new Requires C<xstype> and C<code> parameters. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{code}) { die("Need xstype and code parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{code} = $args{code} if defined $args{code}; $self->{code} =~ s/^(?=\S)/\t/mg; return $self; } =head2 code Returns or sets the INPUT mapping code for this entry. =cut sub code { $_[0]->{code} = $_[1] if @_ > 1; return $_[0]->{code}; } =head2 xstype Returns the name of the XS type of the INPUT map. =cut sub xstype { return $_[0]->{xstype}; } =head2 cleaned_code Returns a cleaned-up copy of the code to which certain transformations have been applied to make it more ANSI compliant. =cut sub cleaned_code { my $self = shift; my $code = $self->code; $code =~ s/(?:;+\s*|;*\s+)\z//s; # Move C pre-processor instructions to column 1 to be strictly ANSI # conformant. Some pre-processors are fussy about this. $code =~ s/^\s+#/#/mg; $code =~ s/\s*\z/\n/; return $code; } =head1 SEE ALSO L<ExtUtils::Typemaps> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; perl5/ExtUtils/Typemaps/Cmd.pm 0000444 00000010045 14711217722 0012221 0 ustar 00 package ExtUtils::Typemaps::Cmd; use 5.006001; use strict; use warnings; our $VERSION = '3.35'; use ExtUtils::Typemaps; require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(embeddable_typemap); our %EXPORT_TAGS = (all => \@EXPORT); sub embeddable_typemap { my @tms = @_; # Get typemap objects my @tm_objs = map [$_, _intuit_typemap_source($_)], @tms; # merge or short-circuit my $final_tm; if (@tm_objs == 1) { # just one, merge would be pointless $final_tm = shift(@tm_objs)->[1]; } else { # multiple, need merge $final_tm = ExtUtils::Typemaps->new; foreach my $other_tm (@tm_objs) { my ($tm_ident, $tm_obj) = @$other_tm; eval { $final_tm->merge(typemap => $tm_obj); 1 } or do { my $err = $@ || 'Zombie error'; die "Failed to merge typ"; } } } # stringify for embedding return $final_tm->as_embedded_typemap(); } sub _load_module { my $name = shift; return eval "require $name; 1"; } SCOPE: { my %sources = ( module => sub { my $ident = shift; my $tm; if (/::/) { # looks like FQ module name, try that first foreach my $module ($ident, "ExtUtils::Typemaps::$ident") { if (_load_module($module)) { eval { $tm = $module->new } and return $tm; } } } else { foreach my $module ("ExtUtils::Typemaps::$ident", "$ident") { if (_load_module($module)) { eval { $tm = $module->new } and return $tm; } } } return(); }, file => sub { my $ident = shift; return unless -e $ident and -r _; return ExtUtils::Typemaps->new(file => $ident); }, ); # Try to find typemap either from module or file sub _intuit_typemap_source { my $identifier = shift; my @locate_attempts; if ($identifier =~ /::/ || $identifier !~ /[^\w_]/) { @locate_attempts = qw(module file); } else { @locate_attempts = qw(file module); } foreach my $source (@locate_attempts) { my $tm = $sources{$source}->($identifier); return $tm if defined $tm; } die "Unable to find typemap for '$identifier': " . "Tried to load both as file or module and failed.\n"; } } # end SCOPE =head1 NAME ExtUtils::Typemaps::Cmd - Quick commands for handling typemaps =head1 SYNOPSIS From XS: INCLUDE_COMMAND: $^X -MExtUtils::Typemaps::Cmd \ -e "print embeddable_typemap(q{Excommunicated})" Loads C<ExtUtils::Typemaps::Excommunicated>, instantiates an object, and dumps it as an embeddable typemap for use directly in your XS file. =head1 DESCRIPTION This is a helper module for L<ExtUtils::Typemaps> for quick one-liners, specifically for inclusion of shared typemaps that live on CPAN into an XS file (see SYNOPSIS). For this reason, the following functions are exported by default: =head1 EXPORTED FUNCTIONS =head2 embeddable_typemap Given a list of identifiers, C<embeddable_typemap> tries to load typemaps from a file of the given name(s), or from a module that is an C<ExtUtils::Typemaps> subclass. Returns a string representation of the merged typemaps that can be included verbatim into XS. Example: print embeddable_typemap( "Excommunicated", "ExtUtils::Typemaps::Basic", "./typemap" ); This will try to load a module C<ExtUtils::Typemaps::Excommunicated> and use it as an C<ExtUtils::Typemaps> subclass. If that fails, it'll try loading C<Excommunicated> as a module, if that fails, it'll try to read a file called F<Excommunicated>. It'll work similarly for the second argument, but the third will be loaded as a file first. After loading all typemap files or modules, it will merge them in the specified order and dump the result as an embeddable typemap. =head1 SEE ALSO L<ExtUtils::Typemaps> L<perlxs> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; perl5/ExtUtils/Typemaps/Type.pm 0000444 00000004045 14711217724 0012444 0 ustar 00 package ExtUtils::Typemaps::Type; use 5.006001; use strict; use warnings; require ExtUtils::Typemaps; our $VERSION = '3.35'; =head1 NAME ExtUtils::Typemaps::Type - Entry in the TYPEMAP section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $type = $typemap->get_type_map('char*'); my $input = $typemap->get_input_map($type->xstype); =head1 DESCRIPTION Refer to L<ExtUtils::Typemaps> for details. Object associates C<ctype> with C<xstype>, which is the index into the in- and output mapping tables. =head1 METHODS =cut =head2 new Requires C<xstype> and C<ctype> parameters. Optionally takes C<prototype> parameter. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{ctype}) { die("Need xstype and ctype parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {proto => ''}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{ctype} = $args{ctype} if defined $args{ctype}; $self->{tidy_ctype} = ExtUtils::Typemaps::tidy_type($self->{ctype}); $self->{proto} = $args{'prototype'} if defined $args{'prototype'}; return $self; } =head2 proto Returns or sets the prototype. =cut sub proto { $_[0]->{proto} = $_[1] if @_ > 1; return $_[0]->{proto}; } =head2 xstype Returns the name of the XS type that this C type is associated to. =cut sub xstype { return $_[0]->{xstype}; } =head2 ctype Returns the name of the C type as it was set on construction. =cut sub ctype { return defined($_[0]->{ctype}) ? $_[0]->{ctype} : $_[0]->{tidy_ctype}; } =head2 tidy_ctype Returns the canonicalized name of the C type. =cut sub tidy_ctype { return $_[0]->{tidy_ctype}; } =head1 SEE ALSO L<ExtUtils::Typemaps> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; perl5/ExtUtils/Typemaps/OutputMap.pm 0000444 00000010514 14711217726 0013461 0 ustar 00 package ExtUtils::Typemaps::OutputMap; use 5.006001; use strict; use warnings; our $VERSION = '3.35'; =head1 NAME ExtUtils::Typemaps::OutputMap - Entry in the OUTPUT section of a typemap =head1 SYNOPSIS use ExtUtils::Typemaps; ... my $output = $typemap->get_output_map('T_NV'); my $code = $output->code(); $output->code("..."); =head1 DESCRIPTION Refer to L<ExtUtils::Typemaps> for details. =head1 METHODS =cut =head2 new Requires C<xstype> and C<code> parameters. =cut sub new { my $prot = shift; my $class = ref($prot)||$prot; my %args = @_; if (!ref($prot)) { if (not defined $args{xstype} or not defined $args{code}) { die("Need xstype and code parameters"); } } my $self = bless( (ref($prot) ? {%$prot} : {}) => $class ); $self->{xstype} = $args{xstype} if defined $args{xstype}; $self->{code} = $args{code} if defined $args{code}; $self->{code} =~ s/^(?=\S)/\t/mg; return $self; } =head2 code Returns or sets the OUTPUT mapping code for this entry. =cut sub code { $_[0]->{code} = $_[1] if @_ > 1; return $_[0]->{code}; } =head2 xstype Returns the name of the XS type of the OUTPUT map. =cut sub xstype { return $_[0]->{xstype}; } =head2 cleaned_code Returns a cleaned-up copy of the code to which certain transformations have been applied to make it more ANSI compliant. =cut sub cleaned_code { my $self = shift; my $code = $self->code; # Move C pre-processor instructions to column 1 to be strictly ANSI # conformant. Some pre-processors are fussy about this. $code =~ s/^\s+#/#/mg; $code =~ s/\s*\z/\n/; return $code; } =head2 targetable This is an obscure but effective optimization that used to live in C<ExtUtils::ParseXS> directly. Not implementing it should never result in incorrect use of typemaps, just less efficient code. In a nutshell, this will check whether the output code involves calling C<sv_setiv>, C<sv_setuv>, C<sv_setnv>, C<sv_setpv> or C<sv_setpvn> to set the special C<$arg> placeholder to a new value B<AT THE END OF THE OUTPUT CODE>. If that is the case, the code is eligible for using the C<TARG>-related macros to optimize this. Thus the name of the method: C<targetable>. If this optimization is applicable, C<ExtUtils::ParseXS> will emit a C<dXSTARG;> definition at the start of the generated XSUB code, and type (see below) dependent code to set C<TARG> and push it on the stack at the end of the generated XSUB code. If the optimization can not be applied, this returns undef. If it can be applied, this method returns a hash reference containing the following information: type: Any of the characters i, u, n, p with_size: Bool indicating whether this is the sv_setpvn variant what: The code that actually evaluates to the output scalar what_size: If "with_size", this has the string length (as code, not constant, including leading comma) =cut sub targetable { my $self = shift; return $self->{targetable} if exists $self->{targetable}; our $bal; # ()-balanced $bal = qr[ (?: (?>[^()]+) | \( (??{ $bal }) \) )* ]x; my $bal_no_comma = qr[ (?: (?>[^(),]+) | \( (??{ $bal }) \) )+ ]x; # matches variations on (SV*) my $sv_cast = qr[ (?: \( \s* SV \s* \* \s* \) \s* )? ]x; my $size = qr[ # Third arg (to setpvn) , \s* (??{ $bal }) ]xo; my $code = $self->code; # We can still bootstrap compile 're', because in code re.pm is # available to miniperl, and does not attempt to load the XS code. use re 'eval'; my ($type, $with_size, $arg, $sarg) = ($code =~ m[^ \s+ sv_set([iunp])v(n)? # Type, is_setpvn \s* \( \s* $sv_cast \$arg \s* , \s* ( $bal_no_comma ) # Set from ( $size )? # Possible sizeof set-from \s* \) \s* ; \s* $ ]xo ); my $rv = undef; if ($type) { $rv = { type => $type, with_size => $with_size, what => $arg, what_size => $sarg, }; } $self->{targetable} = $rv; return $rv; } =head1 SEE ALSO L<ExtUtils::Typemaps> =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; perl5/ExtUtils/Packlist.pm 0000444 00000020565 14711217730 0011475 0 ustar 00 package ExtUtils::Packlist; use 5.00503; use strict; use Carp qw(); use Config; use vars qw($VERSION $Relocations); $VERSION = '2.06'; $VERSION = eval $VERSION; # Used for generating filehandle globs. IO::File might not be available! my $fhname = "FH1"; =begin _undocumented =over =item mkfh() Make a filehandle. Same kind of idea as Symbol::gensym(). =cut sub mkfh() { no strict; local $^W; my $fh = \*{$fhname++}; use strict; return($fh); } =item __find_relocations Works out what absolute paths in the configuration have been located at run time relative to $^X, and generates a regexp that matches them =back =end _undocumented =cut sub __find_relocations { my %paths; while (my ($raw_key, $raw_val) = each %Config) { my $exp_key = $raw_key . "exp"; next unless exists $Config{$exp_key}; next unless $raw_val =~ m!\.\.\./!; $paths{$Config{$exp_key}}++; } # Longest prefixes go first in the alternatives my $alternations = join "|", map {quotemeta $_} sort {length $b <=> length $a} keys %paths; qr/^($alternations)/o; } sub new($$) { my ($class, $packfile) = @_; $class = ref($class) || $class; my %self; tie(%self, $class, $packfile); return(bless(\%self, $class)); } sub TIEHASH { my ($class, $packfile) = @_; my $self = { packfile => $packfile }; bless($self, $class); $self->read($packfile) if (defined($packfile) && -f $packfile); return($self); } sub STORE { $_[0]->{data}->{$_[1]} = $_[2]; } sub FETCH { return($_[0]->{data}->{$_[1]}); } sub FIRSTKEY { my $reset = scalar(keys(%{$_[0]->{data}})); return(each(%{$_[0]->{data}})); } sub NEXTKEY { return(each(%{$_[0]->{data}})); } sub EXISTS { return(exists($_[0]->{data}->{$_[1]})); } sub DELETE { return(delete($_[0]->{data}->{$_[1]})); } sub CLEAR { %{$_[0]->{data}} = (); } sub DESTROY { } sub read($;$) { my ($self, $packfile) = @_; $self = tied(%$self) || $self; if (defined($packfile)) { $self->{packfile} = $packfile; } else { $packfile = $self->{packfile}; } Carp::croak("No packlist filename specified") if (! defined($packfile)); my $fh = mkfh(); open($fh, "<$packfile") || Carp::croak("Can't open file $packfile: $!"); $self->{data} = {}; my ($line); while (defined($line = <$fh>)) { chomp $line; my ($key, $data) = $line; if ($key =~ /^(.*?)( \w+=.*)$/) { $key = $1; $data = { map { split('=', $_) } split(' ', $2)}; if ($Config{userelocatableinc} && $data->{relocate_as}) { require File::Spec; require Cwd; my ($vol, $dir) = File::Spec->splitpath($packfile); my $newpath = File::Spec->catpath($vol, $dir, $data->{relocate_as}); $key = Cwd::realpath($newpath); } } $key =~ s!/\./!/!g; # Some .packlists have spurious '/./' bits in the paths $self->{data}->{$key} = $data; } close($fh); } sub write($;$) { my ($self, $packfile) = @_; $self = tied(%$self) || $self; if (defined($packfile)) { $self->{packfile} = $packfile; } else { $packfile = $self->{packfile}; } Carp::croak("No packlist filename specified") if (! defined($packfile)); my $fh = mkfh(); open($fh, ">$packfile") || Carp::croak("Can't open file $packfile: $!"); foreach my $key (sort(keys(%{$self->{data}}))) { my $data = $self->{data}->{$key}; if ($Config{userelocatableinc}) { $Relocations ||= __find_relocations(); if ($packfile =~ $Relocations) { # We are writing into a subdirectory of a run-time relocated # path. Figure out if the this file is also within a subdir. my $prefix = $1; if (File::Spec->no_upwards(File::Spec->abs2rel($key, $prefix))) { # The relocated path is within the found prefix my $packfile_prefix; (undef, $packfile_prefix) = File::Spec->splitpath($packfile); my $relocate_as = File::Spec->abs2rel($key, $packfile_prefix); if (!ref $data) { $data = {}; } $data->{relocate_as} = $relocate_as; } } } print $fh ("$key"); if (ref($data)) { foreach my $k (sort(keys(%$data))) { print $fh (" $k=$data->{$k}"); } } print $fh ("\n"); } close($fh); } sub validate($;$) { my ($self, $remove) = @_; $self = tied(%$self) || $self; my @missing; foreach my $key (sort(keys(%{$self->{data}}))) { if (! -e $key) { push(@missing, $key); delete($self->{data}{$key}) if ($remove); } } return(@missing); } sub packlist_file($) { my ($self) = @_; $self = tied(%$self) || $self; return($self->{packfile}); } 1; __END__ =head1 NAME ExtUtils::Packlist - manage .packlist files =head1 SYNOPSIS use ExtUtils::Packlist; my ($pl) = ExtUtils::Packlist->new('.packlist'); $pl->read('/an/old/.packlist'); my @missing_files = $pl->validate(); $pl->write('/a/new/.packlist'); $pl->{'/some/file/name'}++; or $pl->{'/some/other/file/name'} = { type => 'file', from => '/some/file' }; =head1 DESCRIPTION ExtUtils::Packlist provides a standard way to manage .packlist files. Functions are provided to read and write .packlist files. The original .packlist format is a simple list of absolute pathnames, one per line. In addition, this package supports an extended format, where as well as a filename each line may contain a list of attributes in the form of a space separated list of key=value pairs. This is used by the installperl script to differentiate between files and links, for example. =head1 USAGE The hash reference returned by the new() function can be used to examine and modify the contents of the .packlist. Items may be added/deleted from the .packlist by modifying the hash. If the value associated with a hash key is a scalar, the entry written to the .packlist by any subsequent write() will be a simple filename. If the value is a hash, the entry written will be the filename followed by the key=value pairs from the hash. Reading back the .packlist will recreate the original entries. =head1 FUNCTIONS =over 4 =item new() This takes an optional parameter, the name of a .packlist. If the file exists, it will be opened and the contents of the file will be read. The new() method returns a reference to a hash. This hash holds an entry for each line in the .packlist. In the case of old-style .packlists, the value associated with each key is undef. In the case of new-style .packlists, the value associated with each key is a hash containing the key=value pairs following the filename in the .packlist. =item read() This takes an optional parameter, the name of the .packlist to be read. If no file is specified, the .packlist specified to new() will be read. If the .packlist does not exist, Carp::croak will be called. =item write() This takes an optional parameter, the name of the .packlist to be written. If no file is specified, the .packlist specified to new() will be overwritten. =item validate() This checks that every file listed in the .packlist actually exists. If an argument which evaluates to true is given, any missing files will be removed from the internal hash. The return value is a list of the missing files, which will be empty if they all exist. =item packlist_file() This returns the name of the associated .packlist file =back =head1 EXAMPLE Here's C<modrm>, a little utility to cleanly remove an installed module. #!/usr/local/bin/perl -w use strict; use IO::Dir; use ExtUtils::Packlist; use ExtUtils::Installed; sub emptydir($) { my ($dir) = @_; my $dh = IO::Dir->new($dir) || return(0); my @count = $dh->read(); $dh->close(); return(@count == 2 ? 1 : 0); } # Find all the installed packages print("Finding all installed modules...\n"); my $installed = ExtUtils::Installed->new(); foreach my $module (grep(!/^Perl$/, $installed->modules())) { my $version = $installed->version($module) || "???"; print("Found module $module Version $version\n"); print("Do you want to delete $module? [n] "); my $r = <STDIN>; chomp($r); if ($r && $r =~ /^y/i) { # Remove all the files foreach my $file (sort($installed->files($module))) { print("rm $file\n"); unlink($file); } my $pf = $installed->packlist($module)->packlist_file(); print("rm $pf\n"); unlink($pf); foreach my $dir (sort($installed->directory_tree($module))) { if (emptydir($dir)) { print("rmdir $dir\n"); rmdir($dir); } } } } =head1 AUTHOR Alan Burlison <Alan.Burlison@uk.sun.com> =cut perl5/ExtUtils/MM_QNX.pm 0000444 00000001613 14711217732 0010755 0 ustar 00 package ExtUtils::MM_QNX; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); =head1 NAME ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix =head1 SYNOPSIS Don't use this module directly. Use ExtUtils::MM and let it choose. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for QNX. Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods =head3 extra_clean_files Add .err files corresponding to each .c file. =cut sub extra_clean_files { my $self = shift; my @errfiles = @{$self->{C}}; for ( @errfiles ) { s/.c$/.err/; } return( @errfiles, 'perlmain.err' ); } =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut 1; perl5/ExtUtils/xsubpp 0000444 00000011717 14711217734 0010634 0 ustar 00 #!perl use 5.006; BEGIN { pop @INC if $INC[-1] eq '.' } use strict; eval { require ExtUtils::ParseXS; 1; } or do { my $err = $@ || 'Zombie error'; my $v = $ExtUtils::ParseXS::VERSION; $v = '<undef>' if not defined $v; die "Failed to load or import from ExtUtils::ParseXS (version $v). Please check that ExtUtils::ParseXS is installed correctly and that the newest version will be found in your \@INC path: $err"; }; use Getopt::Long; my %args = (); my $usage = "Usage: xsubpp [-v] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-strip|s pattern] [-typemap typemap]... file.xs\n"; Getopt::Long::Configure qw(no_auto_abbrev no_ignore_case); @ARGV = grep {$_ ne '-C++'} @ARGV; # Allow -C++ for backward compatibility GetOptions(\%args, qw(hiertype! prototypes! versioncheck! linenumbers! optimize! inout! argtypes! object_capi! except! v typemap=s@ output=s s|strip=s csuffix=s )) or die $usage; if ($args{v}) { print "xsubpp version $ExtUtils::ParseXS::VERSION\n"; exit; } @ARGV == 1 or die $usage; $args{filename} = shift @ARGV; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file(%args); exit( $pxs->report_error_count() ? 1 : 0 ); __END__ =head1 NAME xsubpp - compiler to convert Perl XS code into C code =head1 SYNOPSIS B<xsubpp> [B<-v>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] [B<-output filename>]... file.xs =head1 DESCRIPTION This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker> or by L<Module::Build> or other Perl module build tools. I<xsubpp> will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to determine how to map C function parameters and variables to Perl values. The compiler will search for typemap files called I<typemap>. It will use the following search path to find default typemaps, with the rightmost typemap taking precedence. ../../../typemap:../../typemap:../typemap:typemap It will also use a default typemap installed as C<ExtUtils::typemap>. =head1 OPTIONS Note that the C<XSOPT> MakeMaker option may be used to add these options to any makefiles generated by MakeMaker. =over 5 =item B<-hiertype> Retains '::' in type names so that C++ hierarchical types can be mapped. =item B<-except> Adds exception handling stubs to the C code. =item B<-typemap typemap> Indicates that a user-supplied typemap should take precedence over the default typemaps. This option may be used multiple times, with the last typemap having the highest precedence. =item B<-output filename> Specifies the name of the output file to generate. If no file is specified, output will be written to standard output. =item B<-v> Prints the I<xsubpp> version number to standard output, then exits. =item B<-prototypes> By default I<xsubpp> will not automatically generate prototype code for all xsubs. This flag will enable prototypes. =item B<-noversioncheck> Disables the run time test that determines if the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. =item B<-nolinenumbers> Prevents the inclusion of '#line' directives in the output. =item B<-nooptimize> Disables certain optimizations. The only optimization that is currently affected is the use of I<target>s by the output C code (see L<perlguts>). This may significantly slow down the generated code, but this is the way B<xsubpp> of 5.005 and earlier operated. =item B<-noinout> Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. =item B<-noargtypes> Disable recognition of ANSI-like descriptions of function signature. =item B<-C++> Currently doesn't do anything at all. This flag has been a no-op for many versions of perl, at least as far back as perl5.003_07. It's allowed here for backwards compatibility. =item B<-s=...> or B<-strip=...> I<This option is obscure and discouraged.> If specified, the given string will be stripped off from the beginning of the C function name in the generated XS functions (if it starts with that prefix). This only applies to XSUBs without C<CODE> or C<PPCODE> blocks. For example, the XS: void foo_bar(int i); when C<xsubpp> is invoked with C<-s foo_> will install a C<foo_bar> function in Perl, but really call C<bar(i)> in C. Most of the time, this is the opposite of what you want and failure modes are somewhat obscure, so please avoid this option where possible. =back =head1 ENVIRONMENT No environment variables are used. =head1 AUTHOR Originally by Larry Wall. Turned into the C<ExtUtils::ParseXS> module by Ken Williams. =head1 MODIFICATION HISTORY See the file F<Changes>. =head1 SEE ALSO perl(1), perlxs(1), perlxstut(1), ExtUtils::ParseXS =cut perl5/ExtUtils/Command.pm 0000444 00000017203 14711217735 0011301 0 ustar 00 package ExtUtils::Command; use 5.00503; use strict; use warnings; require Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); @ISA = qw(Exporter); @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod dos2unix); $VERSION = '7.62'; $VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; my $Is_VMS_mode = $Is_VMS; my $Is_VMS_noefs = $Is_VMS; my $Is_Win32 = $^O eq 'MSWin32'; if( $Is_VMS ) { my $vms_unix_rpt; my $vms_efs; my $vms_case; if (eval { local $SIG{__DIE__}; local @INC = @INC; pop @INC if $INC[-1] eq '.'; require VMS::Feature; }) { $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); $vms_efs = VMS::Feature::current("efs_charset"); $vms_case = VMS::Feature::current("efs_case_preserve"); } else { my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; $vms_efs = $efs_charset =~ /^[ET1]/i; $vms_case = $efs_case =~ /^[ET1]/i; } $Is_VMS_mode = 0 if $vms_unix_rpt; $Is_VMS_noefs = 0 if ($vms_efs); } =head1 NAME ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. =head1 SYNOPSIS perl -MExtUtils::Command -e cat files... > destination perl -MExtUtils::Command -e mv source... destination perl -MExtUtils::Command -e cp source... destination perl -MExtUtils::Command -e touch files... perl -MExtUtils::Command -e rm_f files... perl -MExtUtils::Command -e rm_rf directories... perl -MExtUtils::Command -e mkpath directories... perl -MExtUtils::Command -e eqtime source destination perl -MExtUtils::Command -e test_f file perl -MExtUtils::Command -e test_d directory perl -MExtUtils::Command -e chmod mode files... ... =head1 DESCRIPTION The module is used to replace common UNIX commands. In all cases the functions work from @ARGV rather than taking arguments. This makes them easier to deal with in Makefiles. Call them like this: perl -MExtUtils::Command -e some_command some files to work on and I<NOT> like this: perl -MExtUtils::Command -e 'some_command qw(some files to work on)' For that use L<Shell::Command>. Filenames with * and ? will be glob expanded. =head2 FUNCTIONS =over 4 =cut # VMS uses % instead of ? to mean "one character" my $wild_regex = $Is_VMS ? '*%' : '*?'; sub expand_wildcards { @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); } =item cat cat file ... Concatenates all files mentioned on command line to STDOUT. =cut sub cat () { expand_wildcards(); print while (<>); } =item eqtime eqtime source destination Sets modified time of destination to that of source. =cut sub eqtime { my ($src,$dst) = @ARGV; local @ARGV = ($dst); touch(); # in case $dst doesn't exist utime((stat($src))[8,9],$dst); } =item rm_rf rm_rf files or directories ... Removes files and directories - recursively (even if readonly) =cut sub rm_rf { expand_wildcards(); require File::Path; File::Path::rmtree([grep -e $_,@ARGV],0,0); } =item rm_f rm_f file ... Removes files (even if readonly) =cut sub rm_f { expand_wildcards(); foreach my $file (@ARGV) { next unless -f $file; next if _unlink($file); chmod(0777, $file); next if _unlink($file); require Carp; Carp::carp("Cannot delete $file: $!"); } } sub _unlink { my $files_unlinked = 0; foreach my $file (@_) { my $delete_count = 0; $delete_count++ while unlink $file; $files_unlinked++ if $delete_count; } return $files_unlinked; } =item touch touch file ... Makes files exist, with current timestamp =cut sub touch { my $t = time; expand_wildcards(); foreach my $file (@ARGV) { open(FILE,">>$file") || die "Cannot write $file:$!"; close(FILE); utime($t,$t,$file); } } =item mv mv source_file destination_file mv source_file source_file destination_dir Moves source to destination. Multiple sources are allowed if destination is an existing directory. Returns true if all moves succeeded, false otherwise. =cut sub mv { expand_wildcards(); my @src = @ARGV; my $dst = pop @src; if (@src > 1 && ! -d $dst) { require Carp; Carp::croak("Too many arguments"); } require File::Copy; my $nok = 0; foreach my $src (@src) { $nok ||= !File::Copy::move($src,$dst); } return !$nok; } =item cp cp source_file destination_file cp source_file source_file destination_dir Copies sources to the destination. Multiple sources are allowed if destination is an existing directory. Returns true if all copies succeeded, false otherwise. =cut sub cp { expand_wildcards(); my @src = @ARGV; my $dst = pop @src; if (@src > 1 && ! -d $dst) { require Carp; Carp::croak("Too many arguments"); } require File::Copy; my $nok = 0; foreach my $src (@src) { $nok ||= !File::Copy::copy($src,$dst); # Win32 does not update the mod time of a copied file, just the # created time which make does not look at. utime(time, time, $dst) if $Is_Win32; } return $nok; } =item chmod chmod mode files ... Sets UNIX like permissions 'mode' on all the files. e.g. 0666 =cut sub chmod { local @ARGV = @ARGV; my $mode = shift(@ARGV); expand_wildcards(); if( $Is_VMS_mode && $Is_VMS_noefs) { require File::Spec; foreach my $idx (0..$#ARGV) { my $path = $ARGV[$idx]; next unless -d $path; # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do # chmod 0777, [.foo]bar.dir my @dirs = File::Spec->splitdir( $path ); $dirs[-1] .= '.dir'; $path = File::Spec->catfile(@dirs); $ARGV[$idx] = $path; } } chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; } =item mkpath mkpath directory ... Creates directories, including any parent directories. =cut sub mkpath { expand_wildcards(); require File::Path; File::Path::mkpath([@ARGV],0,0777); } =item test_f test_f file Tests if a file exists. I<Exits> with 0 if it does, 1 if it does not (ie. shell's idea of true and false). =cut sub test_f { exit(-f $ARGV[0] ? 0 : 1); } =item test_d test_d directory Tests if a directory exists. I<Exits> with 0 if it does, 1 if it does not (ie. shell's idea of true and false). =cut sub test_d { exit(-d $ARGV[0] ? 0 : 1); } =item dos2unix dos2unix files or dirs ... Converts DOS and OS/2 linefeeds to Unix style recursively. =cut sub dos2unix { require File::Find; File::Find::find(sub { return if -d; return unless -w _; return unless -r _; return if -B _; local $\; my $orig = $_; my $temp = '.dos2unix_tmp'; open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; open TEMP, ">$temp" or do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; binmode ORIG; binmode TEMP; while (my $line = <ORIG>) { $line =~ s/\015\012/\012/g; print TEMP $line; } close ORIG; close TEMP; rename $temp, $orig; }, @ARGV); } =back =head1 SEE ALSO Shell::Command which is these same functions but take arguments normally. =head1 AUTHOR Nick Ing-Simmons C<ni-s@cpan.org> Maintained by Michael G Schwern C<schwern@pobox.com> within the ExtUtils-MakeMaker package and, as a separate CPAN package, by Randy Kobes C<r.kobes@uwinnipeg.ca>. =cut perl5/ExtUtils/Installed.pm 0000444 00000034033 14711217737 0011644 0 ustar 00 package ExtUtils::Installed; use 5.00503; use strict; #use warnings; # XXX requires 5.6 use Carp qw(); use ExtUtils::Packlist; use ExtUtils::MakeMaker; use Config; use File::Find; use File::Basename; use File::Spec; my $Is_VMS = $^O eq 'VMS'; my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/); require VMS::Filespec if $Is_VMS; use vars qw($VERSION); $VERSION = '2.06'; $VERSION = eval $VERSION; sub _is_prefix { my ($self, $path, $prefix) = @_; return unless defined $prefix && defined $path; if( $Is_VMS ) { $prefix = VMS::Filespec::unixify($prefix); $path = VMS::Filespec::unixify($path); } # Unix path normalization. $prefix = File::Spec->canonpath($prefix); return 1 if substr($path, 0, length($prefix)) eq $prefix; if ($DOSISH) { $path =~ s|\\|/|g; $prefix =~ s|\\|/|g; return 1 if $path =~ m{^\Q$prefix\E}i; } return(0); } sub _is_doc { my ($self, $path) = @_; my $man1dir = $self->{':private:'}{Config}{man1direxp}; my $man3dir = $self->{':private:'}{Config}{man3direxp}; return(($man1dir && $self->_is_prefix($path, $man1dir)) || ($man3dir && $self->_is_prefix($path, $man3dir)) ? 1 : 0) } sub _is_type { my ($self, $path, $type) = @_; return 1 if $type eq "all"; return($self->_is_doc($path)) if $type eq "doc"; my $conf= $self->{':private:'}{Config}; if ($type eq "prog") { return($self->_is_prefix($path, $conf->{prefix} || $conf->{prefixexp}) && !($self->_is_doc($path)) ? 1 : 0); } return(0); } sub _is_under { my ($self, $path, @under) = @_; $under[0] = "" if (! @under); foreach my $dir (@under) { return(1) if ($self->_is_prefix($path, $dir)); } return(0); } sub _fix_dirs { my ($self, @dirs)= @_; # File::Find does not know how to deal with VMS filepaths. if( $Is_VMS ) { $_ = VMS::Filespec::unixify($_) for @dirs; } if ($DOSISH) { s|\\|/|g for @dirs; } return wantarray ? @dirs : $dirs[0]; } sub _make_entry { my ($self, $module, $packlist_file, $modfile)= @_; my $data= { module => $module, packlist => scalar(ExtUtils::Packlist->new($packlist_file)), packlist_file => $packlist_file, }; if (!$modfile) { $data->{version} = $self->{':private:'}{Config}{version}; } else { $data->{modfile} = $modfile; # Find the top-level module file in @INC $data->{version} = ''; foreach my $dir (@{$self->{':private:'}{INC}}) { my $p = File::Spec->catfile($dir, $modfile); if (-r $p) { $module = _module_name($p, $module) if $Is_VMS; $data->{version} = MM->parse_version($p); $data->{version_from} = $p; $data->{packlist_valid} = exists $data->{packlist}{$p}; last; } } } $self->{$module}= $data; } our $INSTALLED; sub new { my ($class) = shift(@_); $class = ref($class) || $class; my %args = @_; return $INSTALLED if $INSTALLED and ($args{default_get} || $args{default}); my $self = bless {}, $class; $INSTALLED= $self if $args{default_set} || $args{default}; if ($args{config_override}) { eval { $self->{':private:'}{Config} = { %{$args{config_override}} }; } or Carp::croak( "The 'config_override' parameter must be a hash reference." ); } else { $self->{':private:'}{Config} = \%Config; } for my $tuple ([inc_override => INC => [ @INC ] ], [ extra_libs => EXTRA => [] ]) { my ($arg,$key,$val)=@$tuple; if ( $args{$arg} ) { eval { $self->{':private:'}{$key} = [ @{$args{$arg}} ]; } or Carp::croak( "The '$arg' parameter must be an array reference." ); } elsif ($val) { $self->{':private:'}{$key} = $val; } } { my %dupe; @{$self->{':private:'}{LIBDIRS}} = grep { $_ ne '.' || ! $args{skip_cwd} } grep { -e $_ && !$dupe{$_}++ } @{$self->{':private:'}{EXTRA}}, @{$self->{':private:'}{INC}}; } my @dirs= $self->_fix_dirs(@{$self->{':private:'}{LIBDIRS}}); # Read the core packlist my $archlib = $self->_fix_dirs($self->{':private:'}{Config}{archlibexp}); $self->_make_entry("Perl",File::Spec->catfile($archlib, '.packlist')); my $root; # Read the module packlists my $sub = sub { # Only process module .packlists return if $_ ne ".packlist" || $File::Find::dir eq $archlib; # Hack of the leading bits of the paths & convert to a module name my $module = $File::Find::name; my $found = $module =~ s!^.*?/auto/(.*)/.packlist!$1!s or do { # warn "Woah! \$_=$_\n\$module=$module\n\$File::Find::dir=$File::Find::dir\n", # join ("\n",@dirs); return; }; my $modfile = "$module.pm"; $module =~ s!/!::!g; return if $self->{$module}; #shadowing? $self->_make_entry($module,$File::Find::name,$modfile); }; while (@dirs) { $root= shift @dirs; next if !-d $root; find($sub,$root); } return $self; } # VMS's non-case preserving file-system means the package name can't # be reconstructed from the filename. sub _module_name { my($file, $orig_module) = @_; my $module = ''; if (open PACKFH, $file) { while (<PACKFH>) { if (/package\s+(\S+)\s*;/) { my $pack = $1; # Make a sanity check, that lower case $module # is identical to lowercase $pack before # accepting it if (lc($pack) eq lc($orig_module)) { $module = $pack; last; } } } close PACKFH; } print STDERR "Couldn't figure out the package name for $file\n" unless $module; return $module; } sub modules { my ($self) = @_; $self= $self->new(default=>1) if !ref $self; # Bug/feature of sort in scalar context requires this. return wantarray ? sort grep { not /^:private:$/ } keys %$self : grep { not /^:private:$/ } keys %$self; } sub files { my ($self, $module, $type, @under) = @_; $self= $self->new(default=>1) if !ref $self; # Validate arguments Carp::croak("$module is not installed") if (! exists($self->{$module})); $type = "all" if (! defined($type)); Carp::croak('type must be "all", "prog" or "doc"') if ($type ne "all" && $type ne "prog" && $type ne "doc"); my (@files); foreach my $file (keys(%{$self->{$module}{packlist}})) { push(@files, $file) if ($self->_is_type($file, $type) && $self->_is_under($file, @under)); } return(@files); } sub directories { my ($self, $module, $type, @under) = @_; $self= $self->new(default=>1) if !ref $self; my (%dirs); foreach my $file ($self->files($module, $type, @under)) { $dirs{dirname($file)}++; } return sort keys %dirs; } sub directory_tree { my ($self, $module, $type, @under) = @_; $self= $self->new(default=>1) if !ref $self; my (%dirs); foreach my $dir ($self->directories($module, $type, @under)) { $dirs{$dir}++; my ($last) = (""); while ($last ne $dir) { $last = $dir; $dir = dirname($dir); last if !$self->_is_under($dir, @under); $dirs{$dir}++; } } return(sort(keys(%dirs))); } sub validate { my ($self, $module, $remove) = @_; $self= $self->new(default=>1) if !ref $self; Carp::croak("$module is not installed") if (! exists($self->{$module})); return($self->{$module}{packlist}->validate($remove)); } sub packlist { my ($self, $module) = @_; $self= $self->new(default=>1) if !ref $self; Carp::croak("$module is not installed") if (! exists($self->{$module})); return($self->{$module}{packlist}); } sub version { my ($self, $module) = @_; $self= $self->new(default=>1) if !ref $self; Carp::croak("$module is not installed") if (! exists($self->{$module})); return($self->{$module}{version}); } sub debug_dump { my ($self, $module) = @_; $self= $self->new(default=>1) if !ref $self; local $self->{":private:"}{Config}; require Data::Dumper; print Data::Dumper->new([$self])->Sortkeys(1)->Indent(1)->Dump(); } 1; __END__ =head1 NAME ExtUtils::Installed - Inventory management of installed modules =head1 SYNOPSIS use ExtUtils::Installed; my ($inst) = ExtUtils::Installed->new( skip_cwd => 1 ); my (@modules) = $inst->modules(); my (@missing) = $inst->validate("DBI"); my $all_files = $inst->files("DBI"); my $files_below_usr_local = $inst->files("DBI", "all", "/usr/local"); my $all_dirs = $inst->directories("DBI"); my $dirs_below_usr_local = $inst->directory_tree("DBI", "prog"); my $packlist = $inst->packlist("DBI"); =head1 DESCRIPTION ExtUtils::Installed provides a standard way to find out what core and module files have been installed. It uses the information stored in .packlist files created during installation to provide this information. In addition it provides facilities to classify the installed files and to extract directory information from the .packlist files. =head1 USAGE The new() function searches for all the installed .packlists on the system, and stores their contents. The .packlists can be queried with the functions described below. Where it searches by default is determined by the settings found in C<%Config::Config>, and what the value is of the PERL5LIB environment variable. =head1 METHODS Unless specified otherwise all method can be called as class methods, or as object methods. If called as class methods then the "default" object will be used, and if necessary created using the current processes %Config and @INC. See the 'default' option to new() for details. =over 4 =item new() This takes optional named parameters. Without parameters, this searches for all the installed .packlists on the system using information from C<%Config::Config> and the default module search paths C<@INC>. The packlists are read using the L<ExtUtils::Packlist> module. If the named parameter C<skip_cwd> is true, the current directory C<.> will be stripped from C<@INC> before searching for .packlists. This keeps ExtUtils::Installed from finding modules installed in other perls that happen to be located below the current directory. If the named parameter C<config_override> is specified, it should be a reference to a hash which contains all information usually found in C<%Config::Config>. For example, you can obtain the configuration information for a separate perl installation and pass that in. my $yoda_cfg = get_fake_config('yoda'); my $yoda_inst = ExtUtils::Installed->new(config_override=>$yoda_cfg); Similarly, the parameter C<inc_override> may be a reference to an array which is used in place of the default module search paths from C<@INC>. use Config; my @dirs = split(/\Q$Config{path_sep}\E/, $ENV{PERL5LIB}); my $p5libs = ExtUtils::Installed->new(inc_override=>\@dirs); B<Note>: You probably do not want to use these options alone, almost always you will want to set both together. The parameter C<extra_libs> can be used to specify B<additional> paths to search for installed modules. For instance my $installed = ExtUtils::Installed->new(extra_libs=>["/my/lib/path"]); This should only be necessary if F</my/lib/path> is not in PERL5LIB. Finally there is the 'default', and the related 'default_get' and 'default_set' options. These options control the "default" object which is provided by the class interface to the methods. Setting C<default_get> to true tells the constructor to return the default object if it is defined. Setting C<default_set> to true tells the constructor to make the default object the constructed object. Setting the C<default> option is like setting both to true. This is used primarily internally and probably isn't interesting to any real user. =item modules() This returns a list of the names of all the installed modules. The perl 'core' is given the special name 'Perl'. =item files() This takes one mandatory parameter, the name of a module. It returns a list of all the filenames from the package. To obtain a list of core perl files, use the module name 'Perl'. Additional parameters are allowed. The first is one of the strings "prog", "doc" or "all", to select either just program files, just manual files or all files. The remaining parameters are a list of directories. The filenames returned will be restricted to those under the specified directories. =item directories() This takes one mandatory parameter, the name of a module. It returns a list of all the directories from the package. Additional parameters are allowed. The first is one of the strings "prog", "doc" or "all", to select either just program directories, just manual directories or all directories. The remaining parameters are a list of directories. The directories returned will be restricted to those under the specified directories. This method returns only the leaf directories that contain files from the specified module. =item directory_tree() This is identical in operation to directories(), except that it includes all the intermediate directories back up to the specified directories. =item validate() This takes one mandatory parameter, the name of a module. It checks that all the files listed in the modules .packlist actually exist, and returns a list of any missing files. If an optional second argument which evaluates to true is given any missing files will be removed from the .packlist =item packlist() This returns the ExtUtils::Packlist object for the specified module. =item version() This returns the version number for the specified module. =back =head1 EXAMPLE See the example in L<ExtUtils::Packlist>. =head1 AUTHOR Alan Burlison <Alan.Burlison@uk.sun.com> =cut perl5/ExtUtils/Typemaps.pm 0000444 00000064253 14711217743 0011533 0 ustar 00 package ExtUtils::Typemaps; use 5.006001; use strict; use warnings; our $VERSION = '3.35'; require ExtUtils::ParseXS; require ExtUtils::ParseXS::Constants; require ExtUtils::Typemaps::InputMap; require ExtUtils::Typemaps::OutputMap; require ExtUtils::Typemaps::Type; =head1 NAME ExtUtils::Typemaps - Read/Write/Modify Perl/XS typemap files =head1 SYNOPSIS # read/create file my $typemap = ExtUtils::Typemaps->new(file => 'typemap'); # alternatively create an in-memory typemap # $typemap = ExtUtils::Typemaps->new(); # alternatively create an in-memory typemap by parsing a string # $typemap = ExtUtils::Typemaps->new(string => $sometypemap); # add a mapping $typemap->add_typemap(ctype => 'NV', xstype => 'T_NV'); $typemap->add_inputmap( xstype => 'T_NV', code => '$var = ($type)SvNV($arg);' ); $typemap->add_outputmap( xstype => 'T_NV', code => 'sv_setnv($arg, (NV)$var);' ); $typemap->add_string(string => $typemapstring); # will be parsed and merged # remove a mapping (same for remove_typemap and remove_outputmap...) $typemap->remove_inputmap(xstype => 'SomeType'); # save a typemap to a file $typemap->write(file => 'anotherfile.map'); # merge the other typemap into this one $typemap->merge(typemap => $another_typemap); =head1 DESCRIPTION This module can read, modify, create and write Perl XS typemap files. If you don't know what a typemap is, please confer the L<perlxstut> and L<perlxs> manuals. The module is not entirely round-trip safe: For example it currently simply strips all comments. The order of entries in the maps is, however, preserved. We check for duplicate entries in the typemap, but do not check for missing C<TYPEMAP> entries for C<INPUTMAP> or C<OUTPUTMAP> entries since these might be hidden in a different typemap. =head1 METHODS =cut =head2 new Returns a new typemap object. Takes an optional C<file> parameter. If set, the given file will be read. If the file doesn't exist, an empty typemap is returned. Alternatively, if the C<string> parameter is given, the supplied string will be parsed instead of a file. =cut sub new { my $class = shift; my %args = @_; if (defined $args{file} and defined $args{string}) { die("Cannot handle both 'file' and 'string' arguments to constructor"); } my $self = bless { file => undef, %args, typemap_section => [], typemap_lookup => {}, input_section => [], input_lookup => {}, output_section => [], output_lookup => {}, } => $class; $self->_init(); return $self; } sub _init { my $self = shift; if (defined $self->{string}) { $self->_parse(\($self->{string}), $self->{lineno_offset}, $self->{fake_filename}); delete $self->{string}; } elsif (defined $self->{file} and -e $self->{file}) { open my $fh, '<', $self->{file} or die "Cannot open typemap file '" . $self->{file} . "' for reading: $!"; local $/ = undef; my $string = <$fh>; $self->_parse(\$string, $self->{lineno_offset}, $self->{file}); } } =head2 file Get/set the file that the typemap is written to when the C<write> method is called. =cut sub file { $_[0]->{file} = $_[1] if @_ > 1; $_[0]->{file} } =head2 add_typemap Add a C<TYPEMAP> entry to the typemap. Required named arguments: The C<ctype> (e.g. C<ctype =E<gt> 'double'>) and the C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>). Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of existing C<TYPEMAP> entries of the same C<ctype>. C<skip =E<gt> 1> triggers a I<"first come first serve"> logic by which new entries that conflict with existing entries are silently ignored. As an alternative to the named parameters usage, you may pass in an C<ExtUtils::Typemaps::Type> object as first argument, a copy of which will be added to the typemap. In that case, only the C<replace> or C<skip> named parameters may be used after the object. Example: $map->add_typemap($type_obj, replace => 1); =cut sub add_typemap { my $self = shift; my $type; my %args; if ((@_ % 2) == 1) { my $orig = shift; $type = $orig->new(); %args = @_; } else { %args = @_; my $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; $type = ExtUtils::Typemaps::Type->new( xstype => $xstype, 'prototype' => $args{'prototype'}, ctype => $ctype, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_typemap(ctype => $type->ctype); } elsif ($args{skip}) { return() if exists $self->{typemap_lookup}{$type->ctype}; } else { $self->validate(typemap_xstype => $type->xstype, ctype => $type->ctype); } # store push @{$self->{typemap_section}}, $type; # remember type for lookup, too. $self->{typemap_lookup}{$type->tidy_ctype} = $#{$self->{typemap_section}}; return 1; } =head2 add_inputmap Add an C<INPUT> entry to the typemap. Required named arguments: The C<xstype> (e.g. C<xstype =E<gt> 'T_NV'>) and the C<code> to associate with it for input. Optional named arguments: C<replace =E<gt> 1> forces removal/replacement of existing C<INPUT> entries of the same C<xstype>. C<skip =E<gt> 1> triggers a I<"first come first serve"> logic by which new entries that conflict with existing entries are silently ignored. As an alternative to the named parameters usage, you may pass in an C<ExtUtils::Typemaps::InputMap> object as first argument, a copy of which will be added to the typemap. In that case, only the C<replace> or C<skip> named parameters may be used after the object. Example: $map->add_inputmap($type_obj, replace => 1); =cut sub add_inputmap { my $self = shift; my $input; my %args; if ((@_ % 2) == 1) { my $orig = shift; $input = $orig->new(); %args = @_; } else { %args = @_; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; my $code = $args{code}; die("Need code argument") if not defined $code; $input = ExtUtils::Typemaps::InputMap->new( xstype => $xstype, code => $code, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_inputmap(xstype => $input->xstype); } elsif ($args{skip}) { return() if exists $self->{input_lookup}{$input->xstype}; } else { $self->validate(inputmap_xstype => $input->xstype); } # store push @{$self->{input_section}}, $input; # remember type for lookup, too. $self->{input_lookup}{$input->xstype} = $#{$self->{input_section}}; return 1; } =head2 add_outputmap Add an C<OUTPUT> entry to the typemap. Works exactly the same as C<add_inputmap>. =cut sub add_outputmap { my $self = shift; my $output; my %args; if ((@_ % 2) == 1) { my $orig = shift; $output = $orig->new(); %args = @_; } else { %args = @_; my $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; my $code = $args{code}; die("Need code argument") if not defined $code; $output = ExtUtils::Typemaps::OutputMap->new( xstype => $xstype, code => $code, ); } if ($args{skip} and $args{replace}) { die("Cannot use both 'skip' and 'replace'"); } if ($args{replace}) { $self->remove_outputmap(xstype => $output->xstype); } elsif ($args{skip}) { return() if exists $self->{output_lookup}{$output->xstype}; } else { $self->validate(outputmap_xstype => $output->xstype); } # store push @{$self->{output_section}}, $output; # remember type for lookup, too. $self->{output_lookup}{$output->xstype} = $#{$self->{output_section}}; return 1; } =head2 add_string Parses a string as a typemap and merge it into the typemap object. Required named argument: C<string> to specify the string to parse. =cut sub add_string { my $self = shift; my %args = @_; die("Need 'string' argument") if not defined $args{string}; # no, this is not elegant. my $other = ExtUtils::Typemaps->new(string => $args{string}); $self->merge(typemap => $other); } =head2 remove_typemap Removes a C<TYPEMAP> entry from the typemap. Required named argument: C<ctype> to specify the entry to remove from the typemap. Alternatively, you may pass a single C<ExtUtils::Typemaps::Type> object. =cut sub remove_typemap { my $self = shift; my $ctype; if (@_ > 1) { my %args = @_; $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; $ctype = tidy_type($ctype); } else { $ctype = $_[0]->tidy_ctype; } return $self->_remove($ctype, $self->{typemap_section}, $self->{typemap_lookup}); } =head2 remove_inputmap Removes an C<INPUT> entry from the typemap. Required named argument: C<xstype> to specify the entry to remove from the typemap. Alternatively, you may pass a single C<ExtUtils::Typemaps::InputMap> object. =cut sub remove_inputmap { my $self = shift; my $xstype; if (@_ > 1) { my %args = @_; $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; } else { $xstype = $_[0]->xstype; } return $self->_remove($xstype, $self->{input_section}, $self->{input_lookup}); } =head2 remove_inputmap Removes an C<OUTPUT> entry from the typemap. Required named argument: C<xstype> to specify the entry to remove from the typemap. Alternatively, you may pass a single C<ExtUtils::Typemaps::OutputMap> object. =cut sub remove_outputmap { my $self = shift; my $xstype; if (@_ > 1) { my %args = @_; $xstype = $args{xstype}; die("Need xstype argument") if not defined $xstype; } else { $xstype = $_[0]->xstype; } return $self->_remove($xstype, $self->{output_section}, $self->{output_lookup}); } sub _remove { my $self = shift; my $rm = shift; my $array = shift; my $lookup = shift; # Just fetch the index of the item from the lookup table my $index = $lookup->{$rm}; return() if not defined $index; # Nuke the item from storage splice(@$array, $index, 1); # Decrement the storage position of all items thereafter foreach my $key (keys %$lookup) { if ($lookup->{$key} > $index) { $lookup->{$key}--; } } return(); } =head2 get_typemap Fetches an entry of the TYPEMAP section of the typemap. Mandatory named arguments: The C<ctype> of the entry. Returns the C<ExtUtils::Typemaps::Type> object for the entry if found. =cut sub get_typemap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $ctype = $args{ctype}; die("Need ctype argument") if not defined $ctype; $ctype = tidy_type($ctype); my $index = $self->{typemap_lookup}{$ctype}; return() if not defined $index; return $self->{typemap_section}[$index]; } =head2 get_inputmap Fetches an entry of the INPUT section of the typemap. Mandatory named arguments: The C<xstype> of the entry or the C<ctype> of the typemap that can be used to find the C<xstype>. To wit, the following pieces of code are equivalent: my $type = $typemap->get_typemap(ctype => $ctype) my $input_map = $typemap->get_inputmap(xstype => $type->xstype); my $input_map = $typemap->get_inputmap(ctype => $ctype); Returns the C<ExtUtils::Typemaps::InputMap> object for the entry if found. =cut sub get_inputmap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $xstype = $args{xstype}; my $ctype = $args{ctype}; die("Need xstype or ctype argument") if not defined $xstype and not defined $ctype; die("Need xstype OR ctype arguments, not both") if defined $xstype and defined $ctype; if (defined $ctype) { my $tm = $self->get_typemap(ctype => $ctype); $xstype = $tm && $tm->xstype; return() if not defined $xstype; } my $index = $self->{input_lookup}{$xstype}; return() if not defined $index; return $self->{input_section}[$index]; } =head2 get_outputmap Fetches an entry of the OUTPUT section of the typemap. Mandatory named arguments: The C<xstype> of the entry or the C<ctype> of the typemap that can be used to resolve the C<xstype>. (See above for an example.) Returns the C<ExtUtils::Typemaps::InputMap> object for the entry if found. =cut sub get_outputmap { my $self = shift; die("Need named parameters, got uneven number") if @_ % 2; my %args = @_; my $xstype = $args{xstype}; my $ctype = $args{ctype}; die("Need xstype or ctype argument") if not defined $xstype and not defined $ctype; die("Need xstype OR ctype arguments, not both") if defined $xstype and defined $ctype; if (defined $ctype) { my $tm = $self->get_typemap(ctype => $ctype); $xstype = $tm && $tm->xstype; return() if not defined $xstype; } my $index = $self->{output_lookup}{$xstype}; return() if not defined $index; return $self->{output_section}[$index]; } =head2 write Write the typemap to a file. Optionally takes a C<file> argument. If given, the typemap will be written to the specified file. If not, the typemap is written to the currently stored file name (see L</file> above, this defaults to the file it was read from if any). =cut sub write { my $self = shift; my %args = @_; my $file = defined $args{file} ? $args{file} : $self->file(); die("write() needs a file argument (or set the file name of the typemap using the 'file' method)") if not defined $file; open my $fh, '>', $file or die "Cannot open typemap file '$file' for writing: $!"; print $fh $self->as_string(); close $fh; } =head2 as_string Generates and returns the string form of the typemap. =cut sub as_string { my $self = shift; my $typemap = $self->{typemap_section}; my @code; push @code, "TYPEMAP\n"; foreach my $entry (@$typemap) { # type kind proto # /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o push @code, $entry->ctype . "\t" . $entry->xstype . ($entry->proto ne '' ? "\t".$entry->proto : '') . "\n"; } my $input = $self->{input_section}; if (@$input) { push @code, "\nINPUT\n"; foreach my $entry (@$input) { push @code, $entry->xstype, "\n", $entry->code, "\n"; } } my $output = $self->{output_section}; if (@$output) { push @code, "\nOUTPUT\n"; foreach my $entry (@$output) { push @code, $entry->xstype, "\n", $entry->code, "\n"; } } return join '', @code; } =head2 as_embedded_typemap Generates and returns the string form of the typemap with the appropriate prefix around it for verbatim inclusion into an XS file as an embedded typemap. This will return a string like TYPEMAP: <<END_OF_TYPEMAP ... typemap here (see as_string) ... END_OF_TYPEMAP The method takes care not to use a HERE-doc end marker that appears in the typemap string itself. =cut sub as_embedded_typemap { my $self = shift; my $string = $self->as_string; my @ident_cand = qw(END_TYPEMAP END_OF_TYPEMAP END); my $icand = 0; my $cand_suffix = ""; while ($string =~ /^\Q$ident_cand[$icand]$cand_suffix\E\s*$/m) { $icand++; if ($icand == @ident_cand) { $icand = 0; ++$cand_suffix; } } my $marker = "$ident_cand[$icand]$cand_suffix"; return "TYPEMAP: <<$marker;\n$string\n$marker\n"; } =head2 merge Merges a given typemap into the object. Note that a failed merge operation leaves the object in an inconsistent state so clone it if necessary. Mandatory named arguments: Either C<typemap =E<gt> $another_typemap_obj> or C<file =E<gt> $path_to_typemap_file> but not both. Optional arguments: C<replace =E<gt> 1> to force replacement of existing typemap entries without warning or C<skip =E<gt> 1> to skip entries that exist already in the typemap. =cut sub merge { my $self = shift; my %args = @_; if (exists $args{typemap} and exists $args{file}) { die("Need {file} OR {typemap} argument. Not both!"); } elsif (not exists $args{typemap} and not exists $args{file}) { die("Need {file} or {typemap} argument!"); } my @params; push @params, 'replace' => $args{replace} if exists $args{replace}; push @params, 'skip' => $args{skip} if exists $args{skip}; my $typemap = $args{typemap}; if (not defined $typemap) { $typemap = ref($self)->new(file => $args{file}, @params); } # FIXME breaking encapsulation. Add accessor code. foreach my $entry (@{$typemap->{typemap_section}}) { $self->add_typemap( $entry, @params ); } foreach my $entry (@{$typemap->{input_section}}) { $self->add_inputmap( $entry, @params ); } foreach my $entry (@{$typemap->{output_section}}) { $self->add_outputmap( $entry, @params ); } return 1; } =head2 is_empty Returns a bool indicating whether this typemap is entirely empty. =cut sub is_empty { my $self = shift; return @{ $self->{typemap_section} } == 0 && @{ $self->{input_section} } == 0 && @{ $self->{output_section} } == 0; } =head2 list_mapped_ctypes Returns a list of the C types that are mappable by this typemap object. =cut sub list_mapped_ctypes { my $self = shift; return sort keys %{ $self->{typemap_lookup} }; } =head2 _get_typemap_hash Returns a hash mapping the C types to the XS types: { 'char **' => 'T_PACKEDARRAY', 'bool_t' => 'T_IV', 'AV *' => 'T_AVREF', 'InputStream' => 'T_IN', 'double' => 'T_DOUBLE', # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_typemap_hash { my $self = shift; my $lookup = $self->{typemap_lookup}; my $storage = $self->{typemap_section}; my %rv; foreach my $ctype (keys %$lookup) { $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->xstype; } return \%rv; } =head2 _get_inputmap_hash Returns a hash mapping the XS types (identifiers) to the corresponding INPUT code: { 'T_CALLBACK' => ' $var = make_perl_cb_$type($arg) ', 'T_OUT' => ' $var = IoOFP(sv_2io($arg)) ', 'T_REF_IV_PTR' => ' if (sv_isa($arg, \\"${ntype}\\")) { # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_inputmap_hash { my $self = shift; my $lookup = $self->{input_lookup}; my $storage = $self->{input_section}; my %rv; foreach my $xstype (keys %$lookup) { $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; # Squash trailing whitespace to one line break # This isn't strictly necessary, but makes the output more similar # to the original ExtUtils::ParseXS. $rv{$xstype} =~ s/\s*\z/\n/; } return \%rv; } =head2 _get_outputmap_hash Returns a hash mapping the XS types (identifiers) to the corresponding OUTPUT code: { 'T_CALLBACK' => ' sv_setpvn($arg, $var.context.value().chp(), $var.context.value().size()); ', 'T_OUT' => ' { GV *gv = newGVgen("$Package"); if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) ) sv_setsv( $arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)) ); else $arg = &PL_sv_undef; } ', # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_outputmap_hash { my $self = shift; my $lookup = $self->{output_lookup}; my $storage = $self->{output_section}; my %rv; foreach my $xstype (keys %$lookup) { $rv{$xstype} = $storage->[ $lookup->{$xstype} ]->code; # Squash trailing whitespace to one line break # This isn't strictly necessary, but makes the output more similar # to the original ExtUtils::ParseXS. $rv{$xstype} =~ s/\s*\z/\n/; } return \%rv; } =head2 _get_prototype_hash Returns a hash mapping the C types of the typemap to their corresponding prototypes. { 'char **' => '$', 'bool_t' => '$', 'AV *' => '$', 'InputStream' => '$', 'double' => '$', # ... } This is documented because it is used by C<ExtUtils::ParseXS>, but it's not intended for general consumption. May be removed at any time. =cut sub _get_prototype_hash { my $self = shift; my $lookup = $self->{typemap_lookup}; my $storage = $self->{typemap_section}; my %rv; foreach my $ctype (keys %$lookup) { $rv{$ctype} = $storage->[ $lookup->{$ctype} ]->proto || '$'; } return \%rv; } # make sure that the provided types wouldn't collide with what's # in the object already. sub validate { my $self = shift; my %args = @_; if ( exists $args{ctype} and exists $self->{typemap_lookup}{tidy_type($args{ctype})} ) { die("Multiple definition of ctype '$args{ctype}' in TYPEMAP section"); } if ( exists $args{inputmap_xstype} and exists $self->{input_lookup}{$args{inputmap_xstype}} ) { die("Multiple definition of xstype '$args{inputmap_xstype}' in INPUTMAP section"); } if ( exists $args{outputmap_xstype} and exists $self->{output_lookup}{$args{outputmap_xstype}} ) { die("Multiple definition of xstype '$args{outputmap_xstype}' in OUTPUTMAP section"); } return 1; } =head2 clone Creates and returns a clone of a full typemaps object. Takes named parameters: If C<shallow> is true, the clone will share the actual individual type/input/outputmap objects, but not share their storage. Use with caution. Without C<shallow>, the clone will be fully independent. =cut sub clone { my $proto = shift; my %args = @_; my $self; if ($args{shallow}) { $self = bless( { %$proto, typemap_section => [@{$proto->{typemap_section}}], typemap_lookup => {%{$proto->{typemap_lookup}}}, input_section => [@{$proto->{input_section}}], input_lookup => {%{$proto->{input_lookup}}}, output_section => [@{$proto->{output_section}}], output_lookup => {%{$proto->{output_lookup}}}, } => ref($proto) ); } else { $self = bless( { %$proto, typemap_section => [map $_->new, @{$proto->{typemap_section}}], typemap_lookup => {%{$proto->{typemap_lookup}}}, input_section => [map $_->new, @{$proto->{input_section}}], input_lookup => {%{$proto->{input_lookup}}}, output_section => [map $_->new, @{$proto->{output_section}}], output_lookup => {%{$proto->{output_lookup}}}, } => ref($proto) ); } return $self; } =head2 tidy_type Function to (heuristically) canonicalize a C type. Works to some degree with C++ types. $halfway_canonical_type = tidy_type($ctype); Moved from C<ExtUtils::ParseXS>. =cut sub tidy_type { local $_ = shift; # for templated C++ types, do some bit of flawed canonicalization # wrt. templates at least if (/[<>]/) { s/\s*([<>])\s*/$1/g; s/>>/> >/g; } # rationalise any '*' by joining them into bunches and removing whitespace s#\s*(\*+)\s*#$1#g; s#(\*+)# $1 #g ; # trim leading & trailing whitespace s/^\s+//; s/\s+$//; # change multiple whitespace into a single space s/\s+/ /g; $_; } sub _parse { my $self = shift; my $stringref = shift; my $lineno_offset = shift; $lineno_offset = 0 if not defined $lineno_offset; my $filename = shift; $filename = '<string>' if not defined $filename; my $replace = $self->{replace}; my $skip = $self->{skip}; die "Can only replace OR skip" if $replace and $skip; my @add_params; push @add_params, replace => 1 if $replace; push @add_params, skip => 1 if $skip; # TODO comments should round-trip, currently ignoring # TODO order of sections, multiple sections of same type # Heavily influenced by ExtUtils::ParseXS my $section = 'typemap'; my $lineno = $lineno_offset; my $junk = ""; my $current = \$junk; my @input_expr; my @output_expr; while ($$stringref =~ /^(.*)$/gcm) { local $_ = $1; ++$lineno; chomp; next if /^\s*#/; if (/^INPUT\s*$/) { $section = 'input'; $current = \$junk; next; } elsif (/^OUTPUT\s*$/) { $section = 'output'; $current = \$junk; next; } elsif (/^TYPEMAP\s*$/) { $section = 'typemap'; $current = \$junk; next; } if ($section eq 'typemap') { my $line = $_; s/^\s+//; s/\s+$//; next if $_ eq '' or /^#/; my($type, $kind, $proto) = /^(.*?\S)\s+(\S+)\s*($ExtUtils::ParseXS::Constants::PrototypeRegexp*)$/o or warn("Warning: File '$filename' Line $lineno '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; # prototype defaults to '$' $proto = '$' unless $proto; warn("Warning: File '$filename' Line $lineno '$line' Invalid prototype '$proto'\n") unless _valid_proto_string($proto); $self->add_typemap( ExtUtils::Typemaps::Type->new( xstype => $kind, proto => $proto, ctype => $type ), @add_params ); } elsif (/^\s/) { s/\s+$//; $$current .= $$current eq '' ? $_ : "\n".$_; } elsif ($_ eq '') { next; } elsif ($section eq 'input') { s/\s+$//; push @input_expr, {xstype => $_, code => ''}; $current = \$input_expr[-1]{code}; } else { # output section s/\s+$//; push @output_expr, {xstype => $_, code => ''}; $current = \$output_expr[-1]{code}; } } # end while lines foreach my $inexpr (@input_expr) { $self->add_inputmap( ExtUtils::Typemaps::InputMap->new(%$inexpr), @add_params ); } foreach my $outexpr (@output_expr) { $self->add_outputmap( ExtUtils::Typemaps::OutputMap->new(%$outexpr), @add_params ); } return 1; } # taken from ExtUtils::ParseXS sub _valid_proto_string { my $string = shift; if ($string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/o) { return $string; } return 0 ; } # taken from ExtUtils::ParseXS (C_string) sub _escape_backslashes { my $string = shift; $string =~ s[\\][\\\\]g; $string; } =head1 CAVEATS Inherits some evil code from C<ExtUtils::ParseXS>. =head1 SEE ALSO The parser is heavily inspired from the one in L<ExtUtils::ParseXS>. For details on typemaps: L<perlxstut>, L<perlxs>. =head1 AUTHOR Steffen Mueller C<<smueller@cpan.org>> =head1 COPYRIGHT & LICENSE Copyright 2009, 2010, 2011, 2012, 2013 Steffen Mueller This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; perl5/ExtUtils/MM_VOS.pm 0000444 00000001372 14711217751 0010761 0 ustar 00 package ExtUtils::MM_VOS; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); =head1 NAME ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix =head1 SYNOPSIS Don't use this module directly. Use ExtUtils::MM and let it choose. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for VOS. Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods =head3 extra_clean_files Cleanup VOS core files =cut sub extra_clean_files { return qw(*.kp); } =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut 1; perl5/ExtUtils/MM_AIX.pm 0000444 00000002730 14711217753 0010734 0 ustar 00 package ExtUtils::MM_AIX; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); =head1 NAME ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix =head1 SYNOPSIS Don't use this module directly. Use ExtUtils::MM and let it choose. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for AIX. Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods =head3 dlsyms Define DL_FUNCS and DL_VARS and write the *.exp files. =cut sub dlsyms { my($self,%attribs) = @_; return '' unless $self->needs_linking; join "\n", $self->xs_dlsyms_iterator(\%attribs); } =head3 xs_dlsyms_ext On AIX, is C<.exp>. =cut sub xs_dlsyms_ext { '.exp'; } sub xs_dlsyms_arg { my($self, $file) = @_; my $arg = qq{-bE:${file}}; $arg = '-Wl,'.$arg if $Config{lddlflags} =~ /-Wl,-bE:/; return $arg; } sub init_others { my $self = shift; $self->SUPER::init_others; # perl "hints" add -bE:$(BASEEXT).exp to LDDLFLAGS. strip that out # so right value can be added by xs_make_dynamic_lib to work for XSMULTI $self->{LDDLFLAGS} ||= $Config{lddlflags}; $self->{LDDLFLAGS} =~ s#(\s*)\S*\Q$(BASEEXT)\E\S*(\s*)#$1$2#; return; } =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut 1; perl5/ExtUtils/MM_DOS.pm 0000444 00000002051 14711217754 0010735 0 ustar 00 package ExtUtils::MM_DOS; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); =head1 NAME ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix =head1 SYNOPSIS Don't use this module directly. Use ExtUtils::MM and let it choose. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for DOS. Unless otherwise stated, it works just like ExtUtils::MM_Unix. =head2 Overridden methods =over 4 =item os_flavor =cut sub os_flavor { return('DOS'); } =item B<replace_manpage_separator> Generates Foo__Bar.3 style man page names =cut sub replace_manpage_separator { my($self, $man) = @_; $man =~ s,/+,__,g; return $man; } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =back =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MM_Unix>, L<ExtUtils::MakeMaker> =cut 1; perl5/ExtUtils/MM_NW5.pm 0000444 00000012550 14711217756 0010730 0 ustar 00 package ExtUtils::MM_NW5; =head1 NAME ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 SYNOPSIS use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed =head1 DESCRIPTION See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. =over =cut use strict; use warnings; use ExtUtils::MakeMaker::Config; use File::Basename; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Win32; our @ISA = qw(ExtUtils::MM_Win32); use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562); $ENV{EMXSHELL} = 'sh'; # to run `commands` my $BORLAND = $Config{'cc'} =~ /\bbcc/i; my $GCC = $Config{'cc'} =~ /\bgcc/i; =item os_flavor We're Netware in addition to being Windows. =cut sub os_flavor { my $self = shift; return ($self->SUPER::os_flavor, 'Netware'); } =item init_platform Add Netware macros. LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL, NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION =item platform_constants Add Netware macros initialized above to the Makefile. =cut sub init_platform { my($self) = shift; # To get Win32's setup. $self->SUPER::init_platform; # incpath is copied to makefile var INCLUDE in constants sub, here just # make it empty my $libpth = $Config{'libpth'}; $libpth =~ s( )(;); $self->{'LIBPTH'} = $libpth; $self->{'BASE_IMPORT'} = $Config{'base_import'}; # Additional import file specified from Makefile.pl if($self->{'base_import'}) { $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'}; } $self->{'NLM_VERSION'} = $Config{'nlm_version'}; $self->{'MPKTOOL'} = $Config{'mpktool'}; $self->{'TOOLPATH'} = $Config{'toolpath'}; (my $boot = $self->{'NAME'}) =~ s/:/_/g; $self->{'BOOT_SYMBOL'}=$boot; # If the final binary name is greater than 8 chars, # truncate it here. if(length($self->{'BASEEXT'}) > 8) { $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8); } # Get the include path and replace the spaces with ; # Copy this to makefile as INCLUDE = d:\...;d:\; ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; # Set the path to CodeWarrior binaries which might not have been set in # any other place $self->{PATH} = '$(PATH);$(TOOLPATH)'; $self->{MM_NW5_VERSION} = $VERSION; } sub platform_constants { my($self) = shift; my $make_frag = ''; # Setup Win32's constants. $make_frag .= $self->SUPER::platform_constants; foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH MM_NW5_VERSION )) { next unless defined $self->{$macro}; $make_frag .= "$macro = $self->{$macro}\n"; } return $make_frag; } =item static_lib_pure_cmd Defines how to run the archive utility =cut sub static_lib_pure_cmd { my ($self, $src) = @_; $src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src : ($GCC ? '-ru $@ ' . $src : '-type library -o $@ ' . $src)); } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =item dynamic_lib Override of utility methods for OS-specific work. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; my @m; # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc if ($to =~ /^\$/) { if ($self->{NLM_SHORT_NAME}) { # deal with shortnames my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)}; push @m, "$to: $newto\n\n"; $to = $newto; } } else { my ($v, $d, $f) = File::Spec->splitpath($to); # relies on $f having a literal "." in it, unlike for $(OBJ_EXT) if ($f =~ /[^\.]{9}\./) { # 9+ chars before '.', need to shorten $f = substr $f, 0, 8; } my $newto = File::Spec->catpath($v, $d, $f); push @m, "$to: $newto\n\n"; $to = $newto; } # bits below should be in dlsyms, not here # 1 2 3 4 push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist; # Create xdc data for an MT safe NLM in case of mpk build %1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s $(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s MAKE_FRAG if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { (my $xdc = $exportlist) =~ s#def\z#xdc#; $xdc = '$(BASEEXT).xdc'; push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist; $(MPKTOOL) $(XDCFLAGS) %s $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s MAKE_FRAG } # Reconstruct the X.Y.Z version. my $version = join '.', map { sprintf "%d", $_ } "$]" =~ /(\d)\.(\d{3})(\d{2})/; push @m, sprintf <<'EOF', $from, $version, $to, $exportlist; $(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s $(CHMOD) 755 $@ EOF join '', @m; } 1; __END__ =back =cut perl5/ExtUtils/Liblist.pm 0000444 00000022445 14711217760 0011327 0 ustar 00 package ExtUtils::Liblist; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use File::Spec; require ExtUtils::Liblist::Kid; our @ISA = qw(ExtUtils::Liblist::Kid File::Spec); # Backwards compatibility with old interface. sub ext { goto &ExtUtils::Liblist::Kid::ext; } sub lsdir { shift; my $rex = qr/$_[1]/; opendir my $dir_fh, $_[0]; my @out = grep /$rex/, readdir $dir_fh; closedir $dir_fh; return @out; } __END__ =head1 NAME ExtUtils::Liblist - determine libraries to use and how to use them =head1 SYNOPSIS require ExtUtils::Liblist; $MM->ext($potential_libs, $verbose, $need_names); # Usually you can get away with: ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names) =head1 DESCRIPTION This utility takes a list of libraries in the form C<-llib1 -llib2 -llib3> and returns lines suitable for inclusion in an extension Makefile. Extra library paths may be included with the form C<-L/another/path> this will affect the searches for all subsequent libraries. It returns an array of four or five scalar values: EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to the array of the filenames of actual libraries. Some of these don't mean anything unless on Unix. See the details about those platform specifics below. The list of the filenames is returned only if $need_names argument is true. Dependent libraries can be linked in one of three ways: =over 2 =item * For static extensions by the ld command when the perl binary is linked with the extension library. See EXTRALIBS below. =item * For dynamic extensions at build/link time by the ld command when the shared object is built/linked. See LDLOADLIBS below. =item * For dynamic extensions at load time by the DynaLoader when the shared object is loaded. See BSLOADLIBS below. =back =head2 EXTRALIBS List of libraries that need to be linked with when linking a perl binary which includes this extension. Only those libraries that actually exist are included. These are written to a file and used when linking perl. =head2 LDLOADLIBS and LD_RUN_PATH List of those libraries which can or must be linked into the shared library when created using ld. These may be static or dynamic libraries. LD_RUN_PATH is a colon separated list of the directories in LDLOADLIBS. It is passed as an environment variable to the process that links the shared library. =head2 BSLOADLIBS List of those libraries that are needed but can be linked in dynamically at run time on this platform. SunOS/Solaris does not need this because ld records the information (from LDLOADLIBS) into the object file. This list is used to create a .bs (bootstrap) file. =head1 PORTABILITY This module deals with a lot of system dependencies and has quite a few architecture specific C<if>s in the code. =head2 VMS implementation The version of ext() which is executed under VMS differs from the Unix-OS/2 version in several respects: =over 2 =item * Input library and path specifications are accepted with or without the C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is present, a token is considered a directory to search if it is in fact a directory, and a library to search for otherwise. Authors who wish their extensions to be portable to Unix or OS/2 should use the Unix prefixes, since the Unix-OS/2 version of ext() requires them. =item * Wherever possible, shareable images are preferred to object libraries, and object libraries to plain object files. In accordance with VMS naming conventions, ext() looks for files named I<lib>shr and I<lib>rtl; it also looks for I<lib>lib and libI<lib> to accommodate Unix conventions used in some ported software. =item * For each library that is found, an appropriate directive for a linker options file is generated. The return values are space-separated strings of these directives, rather than elements used on the linker command line. =item * LDLOADLIBS contains both the libraries found based on C<$potential_libs> and the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH are always empty. =back In addition, an attempt is made to recognize several common Unix library names, and filter them out or convert them to their VMS equivalents, as appropriate. In general, the VMS version of ext() should properly handle input from extensions originally designed for a Unix or VMS environment. If you encounter problems, or discover cases where the search could be improved, please let us know. =head2 Win32 implementation The version of ext() which is executed under Win32 differs from the Unix-OS/2 version in several respects: =over 2 =item * If C<$potential_libs> is empty, the return value will be empty. Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) will be appended to the list of C<$potential_libs>. The libraries will be searched for in the directories specified in C<$potential_libs>, C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. For each library that is found, a space-separated list of fully qualified library pathnames is generated. =item * Input library and path specifications are accepted with or without the C<-l> and C<-L> prefixes used by Unix linkers. An entry of the form C<-La:\foo> specifies the C<a:\foo> directory to look for the libraries that follow. An entry of the form C<-lfoo> specifies the library C<foo>, which may be spelled differently depending on what kind of compiler you are using. If you are using GCC, it gets translated to C<libfoo.a>, but for other win32 compilers, it becomes C<foo.lib>. If no files are found by those translated names, one more attempt is made to find them using either C<foo.a> or C<libfoo.lib>, depending on whether GCC or some other win32 compiler is being used, respectively. If neither the C<-L> or C<-l> prefix is present in an entry, the entry is considered a directory to search if it is in fact a directory, and a library to search for otherwise. The C<$Config{lib_ext}> suffix will be appended to any entries that are not directories and don't already have the suffix. Note that the C<-L> and C<-l> prefixes are B<not required>, but authors who wish their extensions to be portable to Unix or OS/2 should use the prefixes, since the Unix-OS/2 version of ext() requires them. =item * Entries cannot be plain object files, as many Win32 compilers will not handle object files in the place of libraries. =item * Entries in C<$potential_libs> beginning with a colon and followed by alphanumeric characters are treated as flags. Unknown flags will be ignored. An entry that matches C</:nodefault/i> disables the appending of default libraries found in C<$Config{perllibs}> (this should be only needed very rarely). An entry that matches C</:nosearch/i> disables all searching for the libraries specified after it. Translation of C<-Lfoo> and C<-lfoo> still happens as appropriate (depending on compiler being used, as reflected by C<$Config{cc}>), but the entries are not verified to be valid files or directories. An entry that matches C</:search/i> reenables searching for the libraries specified after it. You can put it at the end to enable searching for default libraries specified by C<$Config{perllibs}>. =item * The libraries specified may be a mixture of static libraries and import libraries (to link with DLLs). Since both kinds are used pretty transparently on the Win32 platform, we do not attempt to distinguish between them. =item * LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS and LD_RUN_PATH are always empty (this may change in future). =item * You must make sure that any paths and path components are properly surrounded with double-quotes if they contain spaces. For example, C<$potential_libs> could be (literally): "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" Note how the first and last entries are protected by quotes in order to protect the spaces. =item * Since this module is most often used only indirectly from extension C<Makefile.PL> files, here is an example C<Makefile.PL> entry to add a library to the build process for an extension: LIBS => ['-lgl'] When using GCC, that entry specifies that MakeMaker should first look for C<libgl.a> (followed by C<gl.a>) in all the locations specified by C<$Config{libpth}>. When using a compiler other than GCC, the above entry will search for C<gl.lib> (followed by C<libgl.lib>). If the library happens to be in a location not in C<$Config{libpth}>, you need: LIBS => ['-Lc:\gllibs -lgl'] Here is a less often used example: LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32'] This specifies a search for library C<gl> as before. If that search fails to find the library, it looks at the next item in the list. The C<:nosearch> flag will prevent searching for the libraries that follow, so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>, since GCC can use that value as is with its linker. When using the Visual C compiler, the second item is returned as C<-libpath:d:\mesalibs mesa.lib user32.lib>. When using the Borland compiler, the second item is returned as C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of moving the C<-Ld:\mesalibs> to the correct place in the linker command line. =back =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut perl5/ExtUtils/MM_Cygwin.pm 0000444 00000010037 14711217764 0011554 0 ustar 00 package ExtUtils::MM_Cygwin; use strict; use warnings; use ExtUtils::MakeMaker::Config; use File::Spec; require ExtUtils::MM_Unix; require ExtUtils::MM_Win32; our @ISA = qw( ExtUtils::MM_Unix ); our $VERSION = '7.62'; $VERSION =~ tr/_//d; =head1 NAME ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 SYNOPSIS use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed =head1 DESCRIPTION See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. =over 4 =item os_flavor We're Unix and Cygwin. =cut sub os_flavor { return('Unix', 'Cygwin'); } =item cflags if configured for dynamic loading, triggers #define EXT in EXTERN.h =cut sub cflags { my($self,$libperl)=@_; return $self->{CFLAGS} if $self->{CFLAGS}; return '' unless $self->needs_linking(); my $base = $self->SUPER::cflags($libperl); foreach (split /\n/, $base) { /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; }; $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true'); return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} }; } =item replace_manpage_separator replaces strings '::' with '.' in MAN*POD man page names =cut sub replace_manpage_separator { my($self, $man) = @_; $man =~ s{/+}{.}g; return $man; } =item init_linker points to libperl.a =cut sub init_linker { my $self = shift; if ($Config{useshrplib} eq 'true') { my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}"; if( "$]" >= 5.006002 ) { $libperl =~ s/(dll\.)?a$/dll.a/; } $self->{PERL_ARCHIVE} = $libperl; } else { $self->{PERL_ARCHIVE} = '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a"); } $self->{PERL_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; $self->{EXPORT_LIST} ||= ''; } sub init_others { my $self = shift; $self->SUPER::init_others; $self->{LDLOADLIBS} ||= $Config{perllibs}; return; } =item maybe_command Determine whether a file is native to Cygwin by checking whether it resides inside the Cygwin installation (using Windows paths). If so, use L<ExtUtils::MM_Unix> to determine if it may be a command. Otherwise use the tests from L<ExtUtils::MM_Win32>. =cut sub maybe_command { my ($self, $file) = @_; my $cygpath = Cygwin::posix_to_win_path('/', 1); my $filepath = Cygwin::posix_to_win_path($file, 1); return (substr($filepath,0,length($cygpath)) eq $cygpath) ? $self->SUPER::maybe_command($file) # Unix : ExtUtils::MM_Win32->maybe_command($file); # Win32 } =item dynamic_lib Use the default to produce the *.dll's. But for new archdir dll's use the same rebase address if the old exists. =cut sub dynamic_lib { my($self, %attribs) = @_; my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs); return '' unless $s; return $s unless %{$self->{XS}}; # do an ephemeral rebase so the new DLL fits to the current rebase map $s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); $s; } =item install Rebase dll's with the global rebase database after installation. =cut sub install { my($self, %attribs) = @_; my $s = ExtUtils::MM_Unix::install($self, %attribs); return '' unless $s; return $s unless %{$self->{XS}}; my $INSTALLDIRS = $self->{INSTALLDIRS}; my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")}; my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/"; my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}"; $s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); $s; } =back =cut 1; perl5/ExtUtils/Liblist/Kid.pm 0000444 00000061347 14711217766 0012050 0 ustar 00 package ExtUtils::Liblist::Kid; # XXX Splitting this out into its own .pm is a temporary solution. # This kid package is to be used by MakeMaker. It will not work if # $self is not a Makemaker. use 5.006; # Broken out of MakeMaker from version 4.11 use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; use Cwd 'cwd'; use File::Basename; use File::Spec; sub ext { if ( $^O eq 'VMS' ) { return &_vms_ext; } elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; } else { return &_unix_os2_ext; } } sub _unix_os2_ext { my ( $self, $potential_libs, $verbose, $give_libs ) = @_; $verbose ||= 0; if ( $^O =~ /os2|android/ and $Config{perllibs} ) { # Dynamic libraries are not transitive, so we may need including # the libraries linked against perl.dll/libperl.so again. $potential_libs .= " " if $potential_libs; $potential_libs .= $Config{perllibs}; } return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs; warn "Potential libraries are '$potential_libs':\n" if $verbose; my ( $so ) = $Config{so}; my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs}; my $Config_libext = $Config{lib_ext} || ".a"; my $Config_dlext = $Config{dlext}; # compute $extralibs, $bsloadlibs and $ldloadlibs from # $potential_libs # this is a rewrite of Andy Dougherty's extliblist in perl require Text::ParseWords; my ( @searchpath ); # from "-L/path" entries in $potential_libs my ( @libpath ) = Text::ParseWords::shellwords( $Config{'libpth'} || '' ); my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen ); my ( @libs, %libs_seen ); my ( $fullname, @fullname ); my ( $pwd ) = cwd(); # from Cwd.pm my ( $found ) = 0; if ( $^O eq 'darwin' or $^O eq 'next' ) { # 'escape' Mach-O ld -framework and -F flags, so they aren't dropped later on $potential_libs =~ s/(^|\s)(-(?:weak_|reexport_|lazy_)?framework)\s+(\S+)/$1-Wl,$2 -Wl,$3/g; $potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g; } foreach my $thislib ( Text::ParseWords::shellwords($potential_libs) ) { my ( $custom_name ) = ''; # Handle possible linker path arguments. if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # save path flag type my ( $ptype ) = $1; unless ( -d $thislib ) { warn "$ptype$thislib ignored, directory does not exist\n" if $verbose; next; } my ( $rtype ) = $ptype; if ( ( $ptype eq '-R' ) or ( $ptype =~ m!^-Wl,-[Rr]! ) ) { if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) { $rtype = '-Wl,-R'; } elsif ( $Config{'lddlflags'} =~ /-R/ ) { $rtype = '-R'; } } unless ( File::Spec->file_name_is_absolute( $thislib ) ) { warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; $thislib = $self->catdir( $pwd, $thislib ); } push( @searchpath, $thislib ); $thislib = qq{"$thislib"} if $thislib =~ / /; # protect spaces if there push( @extralibs, "$ptype$thislib" ); push( @ldloadlibs, "$rtype$thislib" ); next; } if ( $thislib =~ m!^-Wl,! ) { push( @extralibs, $thislib ); push( @ldloadlibs, $thislib ); next; } # Handle possible library arguments. if ( $thislib =~ s/^-l(:)?// ) { # Handle -l:foo.so, which means that the library will # actually be called foo.so, not libfoo.so. This # is used in Android by ExtUtils::Depends to allow one XS # module to link to another. $custom_name = $1 || ''; } else { warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; next; } my ( $found_lib ) = 0; foreach my $thispth ( @searchpath, @libpath ) { # Try to find the full name of the library. We need this to # determine whether it's a dynamically-loadable library or not. # This tends to be subject to various os-specific quirks. # For gcc-2.6.2 on linux (March 1995), DLD can not load # .sa libraries, with the exception of libm.sa, so we # deliberately skip them. if ((@fullname = $self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) || (@fullname = $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) { # Take care that libfoo.so.10 wins against libfoo.so.9. # Compare two libraries to find the most recent version # number. E.g. if you have libfoo.so.9.0.7 and # libfoo.so.10.1, first convert all digits into two # decimal places. Then we'll add ".00" to the shorter # strings so that we're comparing strings of equal length # Thus we'll compare libfoo.so.09.07.00 with # libfoo.so.10.01.00. Some libraries might have letters # in the version. We don't know what they mean, but will # try to skip them gracefully -- we'll set any letter to # '0'. Finally, sort in reverse so we can take the # first element. #TODO: iterate through the directory instead of sorting $fullname = "$thispth/" . ( sort { my ( $ma ) = $a; my ( $mb ) = $b; $ma =~ tr/A-Za-z/0/s; $ma =~ s/\b(\d)\b/0$1/g; $mb =~ tr/A-Za-z/0/s; $mb =~ s/\b(\d)\b/0$1/g; while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; } while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; } # Comparison deliberately backwards $mb cmp $ma; } @fullname )[0]; } elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" ) && ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) ) { } elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" ) && ( $Config{'archname'} !~ /RM\d\d\d-svr4/ ) && ( $thislib .= "_s" ) ) { # we must explicitly use _s version } elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) { } elsif ( defined( $Config_dlext ) && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) ) { } elsif ( $^O eq 'darwin' && require DynaLoader && defined &DynaLoader::dl_load_file && DynaLoader::dl_load_file( $fullname = "$thispth/lib$thislib.$so", 0 ) ) { } elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) { } elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) { } elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) { } elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) { } elsif ($^O eq 'dgux' && -l ( $fullname = "$thispth/lib$thislib$Config_libext" ) && readlink( $fullname ) =~ /^elink:/s ) { # Some of DG's libraries look like misconnected symbolic # links, but development tools can follow them. (They # look like this: # # libm.a -> elink:${SDE_PATH:-/usr}/sde/\ # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a # # , the compilation tools expand the environment variables.) } elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) { } else { warn "$thislib not found in $thispth\n" if $verbose; next; } warn "'-l$thislib' found at $fullname\n" if $verbose; push @libs, $fullname unless $libs_seen{$fullname}++; $found++; $found_lib++; # Now update library lists # what do we know about this library... # "Sounds like we should always assume it's a dynamic library on AIX." my $is_dyna = $^O eq 'aix' ? 1 : ( $fullname !~ /\Q$Config_libext\E\z/ ); my $in_perl = ( $libs =~ /\B-l:?\Q${thislib}\E\b/s ); # include the path to the lib once in the dynamic linker path # but only if it is a dynamic lib and not in Perl itself my ( $fullnamedir ) = dirname( $fullname ); push @ld_run_path, $fullnamedir if $is_dyna && !$in_perl && !$ld_run_path_seen{$fullnamedir}++; # Do not add it into the list if it is already linked in # with the main perl executable. # We have to special-case the NeXT, because math and ndbm # are both in libsys_s unless ( $in_perl || ( $Config{'osname'} eq 'next' && ( $thislib eq 'm' || $thislib eq 'ndbm' ) ) ) { push( @extralibs, "-l$custom_name$thislib" ); } # We might be able to load this archive file dynamically if ( ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' ) || ( $Config{'dlsrc'} =~ /dl_dld/ ) ) { # We push -l$thislib instead of $fullname because # it avoids hardwiring a fixed path into the .bs file. # Mkbootstrap will automatically add dl_findfile() to # the .bs file if it sees a name in the -l format. # USE THIS, when dl_findfile() is fixed: # push(@bsloadlibs, "-l$thislib"); # OLD USE WAS while checking results against old_extliblist push( @bsloadlibs, "$fullname" ); } else { if ( $is_dyna ) { # For SunOS4, do not add in this shared library if # it is already linked in the main perl executable push( @ldloadlibs, "-l$custom_name$thislib" ) unless ( $in_perl and $^O eq 'sunos' ); } else { push( @ldloadlibs, "-l$custom_name$thislib" ); } } last; # found one here so don't bother looking further } warn "Warning (mostly harmless): " . "No library found for -l$thislib\n" unless $found_lib > 0; } unless ( $found ) { return ( '', '', '', '', ( $give_libs ? \@libs : () ) ); } else { return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) ); } } sub _win32_ext { require Text::ParseWords; my ( $self, $potential_libs, $verbose, $give_libs ) = @_; $verbose ||= 0; # If user did not supply a list, we punt. # (caller should probably use the list in $Config{libs}) return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs; # TODO: make this use MM_Win32.pm's compiler detection my %libs_seen; my @extralibs; my $cc = $Config{cc} || ''; my $VC = $cc =~ /\bcl\b/i; my $GC = $cc =~ /\bgcc\b/i; my $libext = _win32_lib_extensions(); my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs my @libpath = _win32_default_search_paths( $VC, $GC ); my $pwd = cwd(); # from Cwd.pm my $search = 1; # compute @extralibs from $potential_libs my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose ); for ( @lib_search_list ) { my $thislib = $_; # see if entry is a flag if ( /^:\w+$/ ) { $search = 0 if lc eq ':nosearch'; $search = 1 if lc eq ':search'; _debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i; next; } # if searching is disabled, do compiler-specific translations unless ( $search ) { s/^-l(.+)$/$1.lib/ unless $GC; s/^-L/-libpath:/ if $VC; push( @extralibs, $_ ); next; } # handle possible linker path arguments if ( s/^-L// and not -d ) { _debug( "$thislib ignored, directory does not exist\n", $verbose ); next; } elsif ( -d ) { unless ( File::Spec->file_name_is_absolute( $_ ) ) { warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; $_ = $self->catdir( $pwd, $_ ); } push( @searchpath, $_ ); next; } my @paths = ( @searchpath, @libpath ); my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC ); if ( !$fullname ) { warn "Warning (mostly harmless): No library found for $thislib\n"; next; } _debug( "'$thislib' found as '$fullname'\n", $verbose ); push( @extralibs, $fullname ); $libs_seen{$fullname} = 1 if $path; # why is this a special case? } my @libs = sort keys %libs_seen; return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs; # make sure paths with spaces are properly quoted @extralibs = map { qq["$_"] } @extralibs; @libs = map { qq["$_"] } @libs; my $lib = join( ' ', @extralibs ); # normalize back to backward slashes (to help braindead tools) # XXX this may break equally braindead GNU tools that don't understand # backslashes, either. Seems like one can't win here. Cursed be CP/M. $lib =~ s,/,\\,g; _debug( "Result: $lib\n", $verbose ); wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib; } sub _win32_make_lib_search_list { my ( $potential_libs, $verbose ) = @_; # If Config.pm defines a set of default libs, we always # tack them on to the user-supplied list, unless the user # specified :nodefault my $libs = $Config{'perllibs'}; $potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i; _debug( "Potential libraries are '$potential_libs':\n", $verbose ); $potential_libs =~ s,\\,/,g; # normalize to forward slashes my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs ); return @list; } sub _win32_default_search_paths { my ( $VC, $GC ) = @_; my $libpth = $Config{'libpth'} || ''; $libpth =~ s,\\,/,g; # normalize to forward slashes my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth ); push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB}; push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH}; return @libpath; } sub _win32_search_file { my ( $thislib, $libext, $paths, $verbose, $GC ) = @_; my @file_list = _win32_build_file_list( $thislib, $GC, $libext ); for my $lib_file ( @file_list ) { for my $path ( @{$paths} ) { my $fullname = $lib_file; $fullname = "$path\\$fullname" if $path; return ( $fullname, $path ) if -f $fullname; _debug( "'$thislib' not found as '$fullname'\n", $verbose ); } } return; } sub _win32_build_file_list { my ( $lib, $GC, $extensions ) = @_; my @pre_fixed = _win32_build_prefixed_list( $lib, $GC ); return map _win32_attach_extensions( $_, $extensions ), @pre_fixed; } sub _win32_build_prefixed_list { my ( $lib, $GC ) = @_; return $lib if $lib !~ s/^-l//; return $lib if $lib =~ /^lib/ and !$GC; ( my $no_prefix = $lib ) =~ s/^lib//i; $lib = "lib$lib" if $no_prefix eq $lib; return ( $lib, $no_prefix ) if $GC; return ( $no_prefix, $lib ); } sub _win32_attach_extensions { my ( $lib, $extensions ) = @_; return map _win32_try_attach_extension( $lib, $_ ), @{$extensions}; } sub _win32_try_attach_extension { my ( $lib, $extension ) = @_; return $lib if $lib =~ /\Q$extension\E$/i; return "$lib$extension"; } sub _win32_lib_extensions { my @extensions; push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'}; push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions; push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions; return \@extensions; } sub _debug { my ( $message, $verbose ) = @_; return if !$verbose; warn $message; return; } sub _vms_ext { my ( $self, $potential_libs, $verbose, $give_libs ) = @_; $verbose ||= 0; my ( @crtls, $crtlstr ); @crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' ); push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} ); push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} ); # In general, we pass through the basic libraries from %Config unchanged. # The one exception is that if we're building in the Perl source tree, and # a library spec could be resolved via a logical name, we go to some trouble # to insure that the copy in the local tree is used, rather than one to # which a system-wide logical may point. if ( $self->{PERL_SRC} ) { my ( $locspec, $type ); foreach my $lib ( @crtls ) { if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) { if ( lc $type eq '/share' ) { $locspec .= $Config{'exe_ext'}; } elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; } else { $locspec .= $Config{'obj_ext'}; } $locspec = $self->catfile( $self->{PERL_SRC}, $locspec ); $lib = "$locspec$type" if -e $locspec; } } } $crtlstr = @crtls ? join( ' ', @crtls ) : ''; unless ( $potential_libs ) { warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) ); } my ( %found, @fndlibs, $ldlib ); my $cwd = cwd(); my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' }; # List of common Unix library names and their VMS equivalents # (VMS equivalent of '' indicates that the library is automatically # searched by the linker, and should be skipped here.) my ( @flibs, %libs_seen ); my %libmap = ( 'm' => '', 'f77' => '', 'F77' => '', 'V77' => '', 'c' => '', 'malloc' => '', 'crypt' => '', 'resolv' => '', 'c_s' => '', 'socket' => '', 'X11' => 'DECW$XLIBSHR', 'Xt' => 'DECW$XTSHR', 'Xm' => 'DECW$XMLIBSHR', 'Xmu' => 'DECW$XMULIBSHR' ); warn "Potential libraries are '$potential_libs'\n" if $verbose; # First, sort out directories and library names in the input my ( @dirs, @libs ); foreach my $lib ( split ' ', $potential_libs ) { push( @dirs, $1 ), next if $lib =~ /^-L(.*)/; push( @dirs, $lib ), next if $lib =~ /[:>\]]$/; push( @dirs, $lib ), next if -d $lib; push( @libs, $1 ), next if $lib =~ /^-l(.*)/; push( @libs, $lib ); } push( @dirs, split( ' ', $Config{'libpth'} ) ); # Now make sure we've got VMS-syntax absolute directory specs # (We don't, however, check whether someone's hidden a relative # path in a logical name.) foreach my $dir ( @dirs ) { unless ( -d $dir ) { warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; $dir = ''; next; } warn "Resolving directory $dir\n" if $verbose; if ( File::Spec->file_name_is_absolute( $dir ) ) { $dir = VMS::Filespec::vmspath( $dir ); } else { $dir = $self->catdir( $cwd, $dir ); } } @dirs = grep { length( $_ ) } @dirs; unshift( @dirs, '' ); # Check each $lib without additions first LIB: foreach my $lib ( @libs ) { if ( exists $libmap{$lib} ) { next unless length $libmap{$lib}; $lib = $libmap{$lib}; } my ( @variants, $cand ); my ( $ctype ) = ''; # If we don't have a file type, consider it a possibly abbreviated name and # check for common variants. We try these first to grab libraries before # a like-named executable image (e.g. -lperl resolves to perlshr.exe # before perl.exe). if ( $lib !~ /\.[^:>\]]*$/ ) { push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" ); push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/; } push( @variants, $lib ); warn "Looking for $lib\n" if $verbose; foreach my $variant ( @variants ) { my ( $fullname, $name ); foreach my $dir ( @dirs ) { my ( $type ); $name = "$dir$variant"; warn "\tChecking $name\n" if $verbose > 2; $fullname = VMS::Filespec::rmsexpand( $name ); if ( defined $fullname and -f $fullname ) { # It's got its own suffix, so we'll have to figure out the type if ( $fullname =~ /(?:$so|exe)$/i ) { $type = 'SHR'; } elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; } elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) { warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; $type = 'OBJ'; } else { warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n"; $type = 'SHR'; } } elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) ) { $type = 'SHR'; $name = $fullname unless $fullname =~ /exe;?\d*$/i; } elsif ( not length( $ctype ) and # If we've got a lib already, # don't bother ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) ) ) { $type = 'OLB'; $name = $fullname unless $fullname =~ /olb;?\d*$/i; } elsif ( not length( $ctype ) and # If we've got a lib already, # don't bother ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) ) ) { warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; $type = 'OBJ'; $name = $fullname unless $fullname =~ /obj;?\d*$/i; } if ( defined $type ) { $ctype = $type; $cand = $name; last if $ctype eq 'SHR'; } } if ( $ctype ) { push @{ $found{$ctype} }, $cand; warn "\tFound as $cand (really $fullname), type $ctype\n" if $verbose > 1; push @flibs, $name unless $libs_seen{$fullname}++; next LIB; } } warn "Warning (mostly harmless): " . "No library found for $lib\n"; } push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ}; push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB}; push @fndlibs, map { "$_/Share" } @{ $found{SHR} } if exists $found{SHR}; my $lib = join( ' ', @fndlibs ); $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; $ldlib =~ s/^\s+|\s+$//g; warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib; } 1; perl5/ExtUtils/testlib.pm 0000444 00000001617 14711217772 0011374 0 ustar 00 package ExtUtils::testlib; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use Cwd; use File::Spec; # So the tests can chdir around and not break @INC. # We use getcwd() because otherwise rel2abs will blow up under taint # mode pre-5.8. We detaint is so @INC won't be tainted. This is # no worse, and probably better, than just shoving an untainted, # relative "blib/lib" onto @INC. my $cwd; BEGIN { ($cwd) = getcwd() =~ /(.*)/; } use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib); 1; __END__ =head1 NAME ExtUtils::testlib - add blib/* directories to @INC =head1 SYNOPSIS use ExtUtils::testlib; =head1 DESCRIPTION After an extension has been built and before it is installed it may be desirable to test it bypassing C<make test>. By adding use ExtUtils::testlib; to a test program the intermediate directories used by C<make> are added to @INC. perl5/ExtUtils/MM_VMS.pm 0000444 00000205267 14711217774 0010775 0 ustar 00 package ExtUtils::MM_VMS; use strict; use warnings; use ExtUtils::MakeMaker::Config; require Exporter; BEGIN { # so we can compile the thing on non-VMS platforms. if( $^O eq 'VMS' ) { require VMS::Filespec; VMS::Filespec->import; } } use File::Basename; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); our $Revision = $ExtUtils::MakeMaker::Revision; =head1 NAME ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 SYNOPSIS Do not use this directly. Instead, use ExtUtils::MM and it will figure out which MM_* class to use for you. =head1 DESCRIPTION See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. =head2 Methods always loaded =over 4 =item wraplist Converts a list into a string wrapped at approximately 80 columns. =cut sub wraplist { my($self) = shift; my($line,$hlen) = ('',0); foreach my $word (@_) { # Perl bug -- seems to occasionally insert extra elements when # traversing array (scalar(@array) doesn't show them, but # foreach(@array) does) (5.00307) next unless $word =~ /\w/; $line .= ' ' if length($line); if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } $line .= $word; $hlen += length($word) + 2; } $line; } # This isn't really an override. It's just here because ExtUtils::MM_VMS # appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() # in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just # mimic inheritance here and hand off to ExtUtils::Liblist::Kid. # XXX This hackery will die soon. --Schwern sub ext { require ExtUtils::Liblist::Kid; goto &ExtUtils::Liblist::Kid::ext; } =back =head2 Methods Those methods which override default MM_Unix methods are marked "(override)", while methods unique to MM_VMS are marked "(specific)". For overridden methods, documentation is limited to an explanation of why this method overrides the MM_Unix method; see the L<ExtUtils::MM_Unix> documentation for more details. =over 4 =item guess_name (override) Try to determine name of extension being built. We begin with the name of the current directory. Since VMS filenames are case-insensitive, however, we look for a F<.pm> file whose name matches that of the current directory (presumably the 'main' F<.pm> file for this extension), and try to find a C<package> statement from which to obtain the Mixed::Case package name. =cut sub guess_name { my($self) = @_; my($defname,$defpm,@pm,%xs); local *PM; $defname = basename(fileify($ENV{'DEFAULT'})); $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version $defpm = $defname; # Fallback in case for some reason a user has copied the files for an # extension into a working directory whose name doesn't reflect the # extension's name. We'll use the name of a unique .pm file, or the # first .pm file with a matching .xs file. if (not -e "${defpm}.pm") { @pm = glob('*.pm'); s/.pm$// for @pm; if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } elsif (@pm) { %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic if (keys %xs) { foreach my $pm (@pm) { $defpm = $pm, last if exists $xs{$pm}; } } } } if (open(my $pm, '<', "${defpm}.pm")){ while (<$pm>) { if (/^\s*package\s+([^;]+)/i) { $defname = $1; last; } } print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t", "defaulting package name to $defname\n" if eof($pm); close $pm; } else { print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t", "defaulting package name to $defname\n"; } $defname =~ s#[\d.\-_]+$##; $defname; } =item find_perl (override) Use VMS file specification syntax and CLI commands to find and invoke Perl images. =cut sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; my($vmsfile,@sdirs,@snames,@cand); my($rslt); my($inabs) = 0; local *TCF; if( $self->{PERL_CORE} ) { # Check in relative directories first, so we pick up the current # version of Perl if we're running MakeMaker as part of the main build. @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); my($absb) = $self->file_name_is_absolute($b); if ($absa && $absb) { return $a cmp $b } else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } } @$dirs; # Check miniperl before perl, and check names likely to contain # version numbers before "generic" names, so we pick up an # executable that's less likely to be from an old installation. @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename my($bb) = $b =~ m!([^:>\]/]+)$!; my($ahasdir) = (length($a) - length($ba) > 0); my($bhasdir) = (length($b) - length($bb) > 0); if ($ahasdir and not $bhasdir) { return 1; } elsif ($bhasdir and not $ahasdir) { return -1; } else { $bb =~ /\d/ <=> $ba =~ /\d/ or substr($ba,0,1) cmp substr($bb,0,1) or length($bb) <=> length($ba) } } @$names; } else { @sdirs = @$dirs; @snames = @$names; } # Image names containing Perl version use '_' instead of '.' under VMS s/\.(\d+)$/_$1/ for @snames; if ($trace >= 2){ print "Looking for perl $ver by these names:\n"; print "\t@snames,\n"; print "in these dirs:\n"; print "\t@sdirs\n"; } foreach my $dir (@sdirs){ next unless defined $dir; # $self->{PERL_SRC} may be undefined $inabs++ if $self->file_name_is_absolute($dir); if ($inabs == 1) { # We've covered relative dirs; everything else is an absolute # dir (probably an installed location). First, we'll try # potential command names, to see whether we can avoid a long # MCR expression. foreach my $name (@snames) { push(@cand,$name) if $name =~ /^[\w\-\$]+$/; } $inabs++; # Should happen above in next $dir, but just in case... } foreach my $name (@snames){ push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name) : $self->fixpath($name,0); } } foreach my $name (@cand) { print "Checking $name\n" if $trace >= 2; # If it looks like a potential command, try it without the MCR if ($name =~ /^[\w\-\$]+$/) { open(my $tcf, ">", "temp_mmvms.com") or die('unable to open temp file'); print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; close $tcf; $rslt = `\@temp_mmvms.com` ; unlink('temp_mmvms.com'); if ($rslt =~ /VER_OK/) { print "Using PERL=$name\n" if $trace; return $name; } } next unless $vmsfile = $self->maybe_command($name); $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well print "Executing $vmsfile\n" if ($trace >= 2); open(my $tcf, '>', "temp_mmvms.com") or die('unable to open temp file'); print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; close $tcf; $rslt = `\@temp_mmvms.com`; unlink('temp_mmvms.com'); if ($rslt =~ /VER_OK/) { print "Using PERL=MCR $vmsfile\n" if $trace; return "MCR $vmsfile"; } } print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; 0; # false and not empty } =item _fixin_replace_shebang (override) Helper routine for L<< MM->fixin()|ExtUtils::MM_Unix/fixin >>, overridden because there's no such thing as an actual shebang line that will be interpreted by the shell, so we just prepend $Config{startperl} and preserve the shebang line argument for any switches it may contain. =cut sub _fixin_replace_shebang { my ( $self, $file, $line ) = @_; my ( undef, $arg ) = split ' ', $line, 2; return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n"; } =item maybe_command (override) Follows VMS naming conventions for executable files. If the name passed in doesn't exactly match an executable file, appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> to check for DCL procedure. If this fails, checks directories in DCL$PATH and finally F<Sys$System:> for an executable file having the name specified, with or without the F<.Exe>-equivalent suffix. =cut sub maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d _; my(@dirs) = (''); my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); if ($file !~ m![/:>\]]!) { for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { my $dir = $ENV{"DCL\$PATH;$i"}; $dir .= ':' unless $dir =~ m%[\]:]$%; push(@dirs,$dir); } push(@dirs,'Sys$System:'); foreach my $dir (@dirs) { my $sysfile = "$dir$file"; foreach my $ext (@exts) { return $file if -x "$sysfile$ext" && ! -d _; } } } return 0; } =item pasthru (override) The list of macro definitions to be passed through must be specified using the /MACRO qualifier and must not add another /DEFINE qualifier. We prepend our own comma here to the contents of $(PASTHRU_DEFINE) because it is often empty and a comma always present in CCFLAGS would generate a missing qualifier value error. =cut sub pasthru { my($self) = shift; my $pasthru = $self->SUPER::pasthru; $pasthru =~ s|(PASTHRU\s*=\s*)|$1/MACRO=(|; $pasthru =~ s|\n\z|)\n|m; $pasthru =~ s|/defi?n?e?=\(?([^\),]+)\)?|,$1|ig; return $pasthru; } =item pm_to_blib (override) VMS wants a dot in every file so we can't have one called 'pm_to_blib', it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'. So in VMS its pm_to_blib.ts. =cut sub pm_to_blib { my $self = shift; my $make = $self->SUPER::pm_to_blib; $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m; $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts}; $make = <<'MAKE' . $make; # Dummy target to match Unix target name; we use pm_to_blib.ts as # timestamp file to avoid repeated invocations under VMS pm_to_blib : pm_to_blib.ts $(NOECHO) $(NOOP) MAKE return $make; } =item perl_script (override) If name passed in doesn't specify a readable file, appends F<.com> or F<.pl> and tries again, since it's customary to have file types on all files under VMS. =cut sub perl_script { my($self,$file) = @_; return $file if -r $file && ! -d _; return "$file.com" if -r "$file.com"; return "$file.pl" if -r "$file.pl"; return ''; } =item replace_manpage_separator Use as separator a character which is legal in a VMS-syntax file name. =cut sub replace_manpage_separator { my($self,$man) = @_; $man = unixify($man); $man =~ s#/+#__#g; $man; } =item init_DEST (override) Because of the difficulty concatenating VMS filepaths we must pre-expand the DEST* variables. =cut sub init_DEST { my $self = shift; $self->SUPER::init_DEST; # Expand DEST variables. foreach my $var ($self->installvars) { my $destvar = 'DESTINSTALL'.$var; $self->{$destvar} = $self->eliminate_macros($self->{$destvar}); } } =item init_DIRFILESEP No separator between a directory path and a filename on VMS. =cut sub init_DIRFILESEP { my($self) = shift; $self->{DIRFILESEP} = ''; return 1; } =item init_main (override) =cut sub init_main { my($self) = shift; $self->SUPER::init_main; $self->{DEFINE} ||= ''; if ($self->{DEFINE} ne '') { my(@terms) = split(/\s+/,$self->{DEFINE}); my(@defs,@udefs); foreach my $def (@terms) { next unless $def; my $targ = \@defs; if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition $targ = \@udefs if $1 eq 'U'; $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' $def =~ s/^'(.*)'$/$1/; # from entire term or argument } if ($def =~ /=/) { $def =~ s/"/""/g; # Protect existing " from DCL $def = qq["$def"]; # and quote to prevent parsing of = } push @$targ, $def; } $self->{DEFINE} = ''; if (@defs) { $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')'; } if (@udefs) { $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')'; } } } =item init_tools (override) Provide VMS-specific forms of various utility commands. Sets DEV_NULL to nothing because I don't know how to do it on VMS. Changes EQUALIZE_TIMESTAMP to set revision date of target file to one second later than source file, since MMK interprets precisely equal revision dates for a source and target file as a sign that the target needs to be updated. =cut sub init_tools { my($self) = @_; $self->{NOOP} = 'Continue'; $self->{NOECHO} ||= '@ '; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS'; $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE}; $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; $self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old'); # # If an extension is not specified, then MMS/MMK assumes an # an extension of .MMS. If there really is no extension, # then a trailing "." needs to be appended to specify a # a null extension. # $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./; $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./; $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./; $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./; $self->{MACROSTART} ||= '/Macro=('; $self->{MACROEND} ||= ')'; $self->{USEMAKEFILE} ||= '/Descrip='; $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"'; $self->{MOD_INSTALL} ||= $self->oneliner(<<'CODE', ['-MExtUtils::Install']); install([ from_to => {split('\|', <STDIN>)}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); CODE $self->{UMASK_NULL} = '! '; $self->SUPER::init_tools; # Use the default shell $self->{SHELL} ||= 'Posix'; # Redirection on VMS goes before the command, not after as on Unix. # $(DEV_NULL) is used once and its not worth going nuts over making # it work. However, Unix's DEV_NULL is quite wrong for VMS. $self->{DEV_NULL} = ''; return; } =item init_platform (override) Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION. MM_VMS_REVISION is for backwards compatibility before MM_VMS had a $VERSION. =cut sub init_platform { my($self) = shift; $self->{MM_VMS_REVISION} = $Revision; $self->{MM_VMS_VERSION} = $VERSION; $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS') if $self->{PERL_SRC}; } =item platform_constants =cut sub platform_constants { my($self) = shift; my $make_frag = ''; foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION)) { next unless defined $self->{$macro}; $make_frag .= "$macro = $self->{$macro}\n"; } return $make_frag; } =item init_VERSION (override) Override the *DEFINE_VERSION macros with VMS semantics. Translate the MAKEMAKER filepath to VMS style. =cut sub init_VERSION { my $self = shift; $self->SUPER::init_VERSION; $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""'; $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""'; $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'}); } =item constants (override) Fixes up numerous file and directory macros to insure VMS syntax regardless of input syntax. Also makes lists of files comma-separated. =cut sub constants { my($self) = @_; # Be kind about case for pollution for (@ARGV) { $_ = uc($_) if /POLLUTE/i; } # Cleanup paths for directories in MMS macros. foreach my $macro ( qw [ INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB PERL_LIB PERL_ARCHLIB PERL_ARCHLIBDEP PERL_INC PERL_SRC ], (map { 'INSTALL'.$_ } $self->installvars), (map { 'DESTINSTALL'.$_ } $self->installvars) ) { next unless defined $self->{$macro}; next if $macro =~ /MAN/ && $self->{$macro} eq 'none'; $self->{$macro} = $self->fixpath($self->{$macro},1); } # Cleanup paths for files in MMS macros. foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE MYEXTLIB] ) { next unless defined $self->{$macro}; $self->{$macro} = $self->fixpath($self->{$macro},0); } # Fixup files for MMS macros # XXX is this list complete? for my $macro (qw/ FULLEXT VERSION_FROM / ) { next unless defined $self->{$macro}; $self->{$macro} = $self->fixpath($self->{$macro},0); } for my $macro (qw/ OBJECT LDFROM / ) { next unless defined $self->{$macro}; # Must expand macros before splitting on unescaped whitespace. $self->{$macro} = $self->eliminate_macros($self->{$macro}); if ($self->{$macro} =~ /(?<!\^)\s/) { $self->{$macro} =~ s/(\\)?\n+\s+/ /g; $self->{$macro} = $self->wraplist( map $self->fixpath($_,0), split /,?(?<!\^)\s+/, $self->{$macro} ); } else { $self->{$macro} = $self->fixpath($self->{$macro},0); } } for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) { # Where is the space coming from? --jhi next unless $self ne " " && defined $self->{$macro}; my %tmp = (); for my $key (keys %{$self->{$macro}}) { $tmp{$self->fixpath($key,0)} = $self->fixpath($self->{$macro}{$key},0); } $self->{$macro} = \%tmp; } for my $macro (qw/ C O_FILES H /) { next unless defined $self->{$macro}; my @tmp = (); for my $val (@{$self->{$macro}}) { push(@tmp,$self->fixpath($val,0)); } $self->{$macro} = \@tmp; } # mms/k does not define a $(MAKE) macro. $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)'; return $self->SUPER::constants; } =item special_targets Clear the default .SUFFIXES and put in our own list. =cut sub special_targets { my $self = shift; my $make_frag .= <<'MAKE_FRAG'; .SUFFIXES : .SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs MAKE_FRAG return $make_frag; } =item cflags (override) Bypass shell script and produce qualifiers for CC directly (but warn user if a shell script for this extension exists). Fold multiple /Defines into one, since some C compilers pay attention to only one instance of this qualifier on the command line. =cut sub cflags { my($self,$libperl) = @_; my($quals) = $self->{CCFLAGS} || $Config{'ccflags'}; my($definestr,$undefstr,$flagoptstr) = ('','',''); my($incstr) = '/Include=($(PERL_INC)'; my($name,$sys,@m); ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}. " required to modify CC command for $self->{'BASEEXT'}\n" if ($Config{$name}); if ($quals =~ / -[DIUOg]/) { while ($quals =~ / -([Og])(\d*)\b/) { my($type,$lvl) = ($1,$2); $quals =~ s/ -$type$lvl\b\s*//; if ($type eq 'g') { $flagoptstr = '/NoOptimize'; } else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); } } while ($quals =~ / -([DIU])(\S+)/) { my($type,$def) = ($1,$2); $quals =~ s/ -$type$def\s*//; $def =~ s/"/""/g; if ($type eq 'D') { $definestr .= qq["$def",]; } elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } else { $undefstr .= qq["$def",]; } } } if (length $quals and $quals !~ m!/!) { warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n"; $quals = ''; } $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE}; if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; } if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; } # Deal with $self->{DEFINE} here since some C compilers pay attention # to only one /Define clause on command line, so we have to # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} # ($self->{DEFINE} has already been VMSified in constants() above) if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } for my $type (qw(Def Undef)) { my(@terms); while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { my $term = $1; $term =~ s:^\((.+)\)$:$1:; push @terms, $term; } if ($type eq 'Def') { push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ]; } if (@terms) { $quals =~ s:/${type}i?n?e?=[^/]+::ig; # PASTHRU_DEFINE will have its own comma $quals .= "/${type}ine=(" . join(',',@terms) . ($type eq 'Def' ? '$(PASTHRU_DEFINE)' : '') . ')'; } } $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb"; # Likewise with $self->{INC} and /Include if ($self->{'INC'}) { my(@includes) = split(/\s+/,$self->{INC}); foreach (@includes) { s/^-I//; $incstr .= ','.$self->fixpath($_,1); } } $quals .= "$incstr)"; # $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g; $self->{CCFLAGS} = $quals; $self->{PERLTYPE} ||= ''; $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; if ($self->{OPTIMIZE} !~ m!/!) { if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); } else { warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE}; $self->{OPTIMIZE} = '/Optimize'; } } return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} }; } =item const_cccmd (override) Adds directives to point C preprocessor to the right place when handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC command line a bit differently than MM_Unix method. =cut sub const_cccmd { my($self,$libperl) = @_; my(@m); return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; return '' unless $self->needs_linking(); if ($Config{'vms_cc_type'} eq 'gcc') { push @m,' .FIRST ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]'; } elsif ($Config{'vms_cc_type'} eq 'vaxc') { push @m,' .FIRST ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include'; } else { push @m,' .FIRST ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ', ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),' ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include'; } push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n"); $self->{CONST_CCCMD} = join('',@m); } =item tools_other (override) Throw in some dubious extra macros for Makefile args. Also keep around the old $(SAY) macro in case somebody's using it. =cut sub tools_other { my($self) = @_; # XXX Are these necessary? Does anyone override them? They're longer # than just typing the literal string. my $extra_tools = <<'EXTRA_TOOLS'; # Just in case anyone is using the old macro. USEMACROS = $(MACROSTART) SAY = $(ECHO) EXTRA_TOOLS return $self->SUPER::tools_other . $extra_tools; } =item init_dist (override) VMSish defaults for some values. macro description default ZIPFLAGS flags to pass to ZIP -Vu COMPRESS compression command to gzip use for tarfiles SUFFIX suffix to put on -gz compressed files SHAR shar command to use vms_share DIST_DEFAULT default target to use to tardist create a distribution DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM) VERSION for the name =cut sub init_dist { my($self) = @_; $self->{ZIPFLAGS} ||= '-Vu'; $self->{COMPRESS} ||= 'gzip'; $self->{SUFFIX} ||= '-gz'; $self->{SHAR} ||= 'vms_share'; $self->{DIST_DEFAULT} ||= 'zipdist'; $self->SUPER::init_dist; $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}" unless $self->{ARGS}{DISTVNAME}; return; } =item c_o (override) Use VMS syntax on command line. In particular, $(DEFINE) and $(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros. =cut sub c_o { my($self) = @_; return '' unless $self->needs_linking(); ' .c$(OBJ_EXT) : $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) .cpp$(OBJ_EXT) : $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) .cxx$(OBJ_EXT) : $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) '; } =item xs_c (override) Use MM[SK] macros. =cut sub xs_c { my($self) = @_; return '' unless $self->needs_linking(); ' .xs.c : $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c '; } =item xs_o (override) Use MM[SK] macros, and VMS command line for C compiler. =cut sub xs_o { my ($self) = @_; return '' unless $self->needs_linking(); my $frag = ' .xs$(OBJ_EXT) : $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) '; if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my $version = $self->parse_version("$ext.pm"); my $ccflags = $self->{CCFLAGS}; $ccflags =~ s/\$\(DEFINE_VERSION\)/\"VERSION_MACRO=\\"\"$version\\"\"/; $ccflags =~ s/\$\(XS_DEFINE_VERSION\)/\"XS_VERSION_MACRO=\\"\"$version\\"\"/; $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'INC'); $self->_xsbuild_replace_macro($ccflags, 'xs', $ext, 'DEFINE'); $frag .= _sprintf562 <<'EOF', $ext, $ccflags; %1$s$(OBJ_EXT) : %1$s.xs $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c $(CC)%2$s$(OPTIMIZE) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) EOF } } $frag; } =item _xsbuild_replace_macro (override) There is no simple replacement possible since a qualifier and all its subqualifiers must be considered together, so we use our own utility routine for the replacement. =cut sub _xsbuild_replace_macro { my ($self, undef, $xstype, $ext, $varname) = @_; my $value = $self->_xsbuild_value($xstype, $ext, $varname); return unless defined $value; $_[1] = _vms_replace_qualifier($self, $_[1], $value, $varname); } =item _xsbuild_value (override) Convert the extension spec to Unix format, as that's what will match what's in the XSBUILD data structure. =cut sub _xsbuild_value { my ($self, $xstype, $ext, $varname) = @_; $ext = unixify($ext); return $self->SUPER::_xsbuild_value($xstype, $ext, $varname); } sub _vms_replace_qualifier { my ($self, $flags, $newflag, $macro) = @_; my $qual_type; my $type_suffix; my $quote_subquals = 0; my @subquals_new = split /\s+/, $newflag; if ($macro eq 'DEFINE') { $qual_type = 'Def'; $type_suffix = 'ine'; map { $_ =~ s/^-D// } @subquals_new; $quote_subquals = 1; } elsif ($macro eq 'INC') { $qual_type = 'Inc'; $type_suffix = 'lude'; map { $_ =~ s/^-I//; $_ = $self->fixpath($_) } @subquals_new; } my @subquals = (); while ($flags =~ m:/${qual_type}\S{0,4}=([^/]+):ig) { my $term = $1; $term =~ s/\"//g; $term =~ s:^\((.+)\)$:$1:; push @subquals, split /,/, $term; } for my $new (@subquals_new) { my ($sq_new, $sqval_new) = split /=/, $new; my $replaced_old = 0; for my $old (@subquals) { my ($sq, $sqval) = split /=/, $old; if ($sq_new eq $sq) { $old = $sq_new; $old .= '=' . $sqval_new if defined($sqval_new) and length($sqval_new); $replaced_old = 1; last; } } push @subquals, $new unless $replaced_old; } if (@subquals) { $flags =~ s:/${qual_type}\S{0,4}=[^/]+::ig; # add quotes if requested but not for unexpanded macros map { $_ = qq/"$_"/ if $_ !~ m/^\$\(/ } @subquals if $quote_subquals; $flags .= "/${qual_type}$type_suffix=(" . join(',',@subquals) . ')'; } return $flags; } sub xs_dlsyms_ext { '.opt'; } =item dlsyms (override) Create VMS linker options files specifying universal symbols for this extension's shareable image(s), and listing other shareable images or libraries to which it should be linked. =cut sub dlsyms { my ($self, %attribs) = @_; return '' unless $self->needs_linking; $self->xs_dlsyms_iterator; } sub xs_make_dlsyms { my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; my @m; my $instloc; if ($self->{XSMULTI}) { my ($v, $d, $f) = File::Spec->splitpath($target); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f); push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'dynamic'}; push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'static'}; push @m, "\n", sprintf <<'EOF', $instloc, $target; %s : %s $(CP) $(MMS$SOURCE) $(MMS$TARGET) EOF } else { push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'dynamic'}; push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" unless $self->{SKIPHASH}{'static'}; push @m, "\n", sprintf <<'EOF', $target; $(INST_ARCHAUTODIR)$(BASEEXT).opt : %s $(CP) $(MMS$SOURCE) $(MMS$TARGET) EOF } push @m, "\n$target : $dep\n\t", q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name, q!', 'DLBASE' => '!,$dlbase, q!', 'DL_FUNCS' => !,neatvalue($funcs), q!, 'FUNCLIST' => !,neatvalue($funclist), q!, 'IMPORTS' => !,neatvalue($imports), q!, 'DL_VARS' => !, neatvalue($vars); push @m, $extra if defined $extra; push @m, qq!);"\n\t!; # Can't use dlbase as it's been through mod2fname. my $olb_base = basename($target, '.opt'); if ($self->{XSMULTI}) { # We've been passed everything but the kitchen sink -- and the location of the # static library we're using to build the dynamic library -- so concoct that # location from what we do have. my $olb_dir = $self->catdir(dirname($instloc), $olb_base); push @m, qq!\$(PERL) -e "print ""${olb_dir}${olb_base}\$(LIB_EXT)/Include=!; push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($olb_base) : $olb_base); push @m, '\n' . $olb_dir . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"; } else { push @m, qq!\$(PERL) -e "print ""\$(INST_ARCHAUTODIR)${olb_base}\$(LIB_EXT)/Include=!; if ($self->{OBJECT} =~ /\bBASEEXT\b/ or $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) { push @m, ($Config{d_vms_case_sensitive_symbols} ? uc($self->{BASEEXT}) :'$(BASEEXT)'); } else { # We don't have a "main" object file, so pull 'em all in # Upcase module names if linker is being case-sensitive my($upcase) = $Config{d_vms_case_sensitive_symbols}; my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT}); for (@omods) { s/\.[^.]*$//; # Trim off file type s[\$\(\w+_EXT\)][]; # even as a macro s/.*[:>\/\]]//; # Trim off dir spec $_ = uc if $upcase; }; my(@lines); my $tmp = shift @omods; foreach my $elt (@omods) { $tmp .= ",$elt"; if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } } push @lines, $tmp; push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')'; } push @m, '\n$(INST_ARCHAUTODIR)' . $olb_base . '$(LIB_EXT)/Library\n"";" >>$(MMS$TARGET)',"\n"; } if (length $self->{LDLOADLIBS}) { my($line) = ''; foreach my $lib (split ' ', $self->{LDLOADLIBS}) { $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs if (length($line) + length($lib) > 160) { push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n"; $line = $lib . '\n'; } else { $line .= $lib . '\n'; } } push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line; } join '', @m; } =item xs_obj_opt Override to fixup -o flags. =cut sub xs_obj_opt { my ($self, $output_file) = @_; "/OBJECT=$output_file"; } =item dynamic_lib (override) Use VMS Link command. =cut sub xs_dynamic_lib_macros { my ($self, $attribs) = @_; my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; # This section creates the dynamically loadable objects from relevant # objects and possibly $(MYEXTLIB). OTHERLDFLAGS = %s INST_DYNAMIC_DEP = %s EOF } sub xs_make_dynamic_lib { my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; my $shr = $Config{'dbgprefix'} . 'PerlShr'; $exportlist =~ s/.def$/.opt/; # it's a linker options file # 1 2 3 4 5 _sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}"; %1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option EOF } =item xs_make_static_lib (override) Use VMS commands to manipulate object library. =cut sub xs_make_static_lib { my ($self, $object, $to, $todir) = @_; my @objects; if ($self->{XSMULTI}) { # The extension name should be the main object file name minus file type. my $lib = $object; $lib =~ s/\$\(OBJ_EXT\)\z//; my $override = $self->_xsbuild_value('xs', $lib, 'OBJECT'); $object = $override if defined $override; @objects = map { $self->fixpath($_,0) } split /(?<!\^)\s+/, $object; } else { push @objects, $object; } my @m; for my $obj (@objects) { push(@m, sprintf "\n%s : %s\$(DFSEP).exists", $obj, $todir); } push(@m, sprintf "\n\n%s : %s \$(MYEXTLIB)\n", $to, (join ' ', @objects)); # If this extension has its own library (eg SDBM_File) # then copy that to $(INST_STATIC) and add $(OBJECT) into it. push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); # if there was a library to copy, then we can't use MMS$SOURCE_LIST, # 'cause it's a library and you can't stick them in other libraries. # In that case, we use $OBJECT instead and hope for the best if ($self->{MYEXTLIB}) { for my $obj (@objects) { push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) ' . $obj,"\n"); } } else { push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); } push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n"; foreach my $lib (split ' ', $self->{EXTRALIBS}) { push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); } join('',@m); } =item static_lib_pure_cmd (override) Use VMS commands to manipulate object library. =cut sub static_lib_pure_cmd { my ($self, $from) = @_; sprintf <<'MAKE_FRAG', $from; If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET) Library/Object/Replace $(MMS$TARGET) %s MAKE_FRAG } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =item extra_clean_files Clean up some OS specific files. Plus the temp file used to shorten a lot of commands. And the name mangler database. =cut sub extra_clean_files { return qw( *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso .MM_Tmp cxx_repository ); } =item zipfile_target =item tarfile_target =item shdist_target Syntax for invoking shar, tar and zip differs from that for Unix. =cut sub zipfile_target { my($self) = shift; return <<'MAKE_FRAG'; $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; $(RM_RF) $(DISTVNAME) $(POSTOP) MAKE_FRAG } sub tarfile_target { my($self) = shift; return <<'MAKE_FRAG'; $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(POSTOP) MAKE_FRAG } sub shdist_target { my($self) = shift; return <<'MAKE_FRAG'; shdist : distdir $(PREOP) $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share $(RM_RF) $(DISTVNAME) $(POSTOP) MAKE_FRAG } # --- Test and Installation Sections --- =item install (override) Work around DCL's 255 character limit several times,and use VMS-style command line quoting in a few cases. =cut sub install { my($self, %attribs) = @_; my(@m); push @m, q[ install :: all pure_install doc_install $(NOECHO) $(NOOP) install_perl :: all pure_perl_install doc_perl_install $(NOECHO) $(NOOP) install_site :: all pure_site_install doc_site_install $(NOECHO) $(NOOP) install_vendor :: all pure_vendor_install doc_vendor_install $(NOECHO) $(NOOP) pure_install :: pure_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) doc_install :: doc_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) pure__install : pure_site_install $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" doc__install : doc_site_install $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" # This hack brought to you by DCL's 255-character command line limit pure_perl_install :: ]; push @m, q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp ] unless $self->{NO_PACKLIST}; push @m, q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLPRIVLIB)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLARCHLIB)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLBIN)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLMAN3DIR)" >>.MM_tmp $(NOECHO) $(MOD_INSTALL) <.MM_tmp $(NOECHO) $(RM_F) .MM_tmp $(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[" # Likewise pure_site_install :: ]; push @m, q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp ] unless $self->{NO_PACKLIST}; push @m, q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLSITELIB)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLSITEARCH)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLSITEBIN)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLSITEMAN1DIR)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLSITEMAN3DIR)" >>.MM_tmp $(NOECHO) $(MOD_INSTALL) <.MM_tmp $(NOECHO) $(RM_F) .MM_tmp $(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[" pure_vendor_install :: ]; push @m, q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp ] unless $self->{NO_PACKLIST}; push @m, q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLVENDORLIB)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLVENDORARCH)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLVENDORBIN)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLVENDORMAN1DIR)|" >>.MM_tmp $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLVENDORMAN3DIR)" >>.MM_tmp $(NOECHO) $(MOD_INSTALL) <.MM_tmp $(NOECHO) $(RM_F) .MM_tmp ]; push @m, q[ # Ditto doc_perl_install :: $(NOECHO) $(NOOP) # And again doc_site_install :: $(NOECHO) $(NOOP) doc_vendor_install :: $(NOECHO) $(NOOP) ] if $self->{NO_PERLLOCAL}; push @m, q[ # Ditto doc_perl_install :: $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ $(NOECHO) $(RM_F) .MM_tmp # And again doc_site_install :: $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ $(NOECHO) $(RM_F) .MM_tmp doc_vendor_install :: $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ $(NOECHO) $(RM_F) .MM_tmp ] unless $self->{NO_PERLLOCAL}; push @m, q[ uninstall :: uninstall_from_$(INSTALLDIRS)dirs $(NOECHO) $(NOOP) uninstall_from_perldirs :: $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ uninstall_from_sitedirs :: $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ uninstall_from_vendordirs :: $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ ]; join('',@m); } =item perldepend (override) Use VMS-style syntax for files; it's cheaper to just do it directly here than to have the L<MM_Unix|ExtUtils::MM_Unix> method call C<catfile> repeatedly. Also, if we have to rebuild Config.pm, use MM[SK] to do it. =cut sub perldepend { my($self) = @_; my(@m); if ($self->{OBJECT}) { # Need to add an object file dependency on the perl headers. # this is very important for XS modules in perl.git development. push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC) } if ($self->{PERL_SRC}) { my(@macros); my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)'; push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP'; push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc'; push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc'; push(@macros,'SOCKET=1') if $Config{'d_has_sockets'}; push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!; $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros; push(@m,q[ # Check for unpropagated config.sh changes. Should never happen. # We do NOT just update config.h because that is not sufficient. # An out of date config.h is not fatal but complains loudly! $(PERL_INC)config.h : $(PERL_SRC)config.sh $(NOOP) $(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" olddef = F$Environment("Default") Set Default $(PERL_SRC) $(MMS)],$mmsquals,); if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); $target =~ s/\Q$prefix/[/; push(@m," $target"); } else { push(@m,' $(MMS$TARGET)'); } push(@m,q[ Set Default 'olddef' ]); } push(@m, join(" ", map($self->fixpath($_,0),sort values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") if %{$self->{XS}}; join('',@m); } =item makeaperl (override) Undertake to build a new set of Perl images using VMS commands. Since VMS does dynamic loading, it's not necessary to statically link each extension into the Perl image, so this isn't the normal build path. Consequently, it hasn't really been tested, and may well be incomplete. =cut our %olbs; # needs to be localized sub makeaperl { my($self, %attribs) = @_; my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) = @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; my(@m); push @m, " # --- MakeMaker makeaperl section --- MAP_TARGET = $target "; return join '', @m if $self->{PARENT}; my($dir) = join ":", @{$self->{DIR}}; unless ($self->{MAKEAPERL}) { push @m, q{ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" $(NOECHO) $(PERLRUNINST) \ Makefile.PL DIR=}, $dir, q{ \ FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ MAKEAPERL=1 NORECURS=1 }; push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) }; push @m, "\n"; return join '', @m; } my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); local($_); # The front matter of the linkcommand... $linkcmd = join ' ', $Config{'ld'}, grep($_, @Config{qw(large split ldflags ccdlflags)}); $linkcmd =~ s/\s+/ /g; # Which *.olb files could we make use of... local(%olbs); # XXX can this be lexical? $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; require File::Find; File::Find::find(sub { return unless m/\Q$self->{LIB_EXT}\E$/; return if m/^libperl/; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; (my $xx = $File::Find::name) =~ s,.*?/auto/,,; $xx =~ s,/?$_,,; $xx =~ s,/,::,g; # Throw away anything not explicitly marked for inclusion. # DynaLoader is implied. foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ if( $xx eq $incl ){ $found++; last; } } return unless $found; } elsif( exists $self->{EXCLUDE_EXT} ){ (my $xx = $File::Find::name) =~ s,.*?/auto/,,; $xx =~ s,/?$_,,; $xx =~ s,/,::,g; # Throw away anything explicitly marked for exclusion foreach my $excl (@{$self->{EXCLUDE_EXT}}){ return if( $xx eq $excl ); } } $olbs{$ENV{DEFAULT}} = $_; }, grep( -d $_, @{$searchdirs || []})); # We trust that what has been handed in as argument will be buildable $static = [] unless $static; @olbs{@{$static}} = (1) x @{$static}; $extra = [] unless $extra && ref $extra eq 'ARRAY'; # Sort the object libraries in inverse order of # filespec length to try to insure that dependent extensions # will appear before their parents, so the linker will # search the parent library to resolve references. # (e.g. Intuit::DWIM will precede Intuit, so unresolved # references from [.intuit.dwim]dwim.obj can be found # in [.intuit]intuit.olb). for (sort { length($a) <=> length($b) || $a cmp $b } keys %olbs) { next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; my($dir) = $self->fixpath($_,1); my($extralibs) = $dir . "extralibs.ld"; my($extopt) = $dir . $olbs{$_}; $extopt =~ s/$self->{LIB_EXT}$/.opt/; push @optlibs, "$dir$olbs{$_}"; # Get external libraries this extension will need if (-f $extralibs ) { my %seenthis; open my $list, "<", $extralibs or warn $!,next; while (<$list>) { chomp; # Include a library in the link only once, unless it's mentioned # multiple times within a single extension's options file, in which # case we assume the builder needed to search it again later in the # link. my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); $libseen{$_}++; $seenthis{$_}++; next if $skip; push @$extra,$_; } } # Get full name of extension for ExtUtils::Miniperl if (-f $extopt) { open my $opt, '<', $extopt or die $!; while (<$opt>) { next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; my $pkg = $1; $pkg =~ s#__*#::#g; push @staticpkgs,$pkg; } } } # Place all of the external libraries after all of the Perl extension # libraries in the final link, in order to maximize the opportunity # for XS code from multiple extensions to resolve symbols against the # same external library while only including that library once. push @optlibs, @$extra; $target = "Perl$Config{'exe_ext'}" unless $target; my $shrtarget; ($shrtarget,$targdir) = fileparse($target); $shrtarget =~ s/^([^.]*)/$1Shr/; $shrtarget = $targdir . $shrtarget; $target = "Perlshr.$Config{'dlext'}" unless $target; $tmpdir = "[]" unless $tmpdir; $tmpdir = $self->fixpath($tmpdir,1); if (@optlibs) { $extralist = join(' ',@optlibs); } else { $extralist = ''; } # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr) # that's what we're building here). push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2]; if ($libperl) { unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { print "Warning: $libperl not found\n"; undef $libperl; } } unless ($libperl) { if (defined $self->{PERL_SRC}) { $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { } else { print "Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed otherwise ignore this warning\n"; } } $libperldir = $self->fixpath((fileparse($libperl))[1],1); push @m, ' # Fill in the target you want to produce if it\'s not perl MAP_TARGET = ',$self->fixpath($target,0),' MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," MAP_LINKCMD = $linkcmd MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," MAP_EXTRA = $extralist MAP_LIBPERL = ",$self->fixpath($libperl,0),' '; push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n"; foreach (@optlibs) { push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; } push @m,"\n${tmpdir}PerlShr.Opt :\n\t"; push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; push @m,' $(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",' $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say" $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" $(NOECHO) $(ECHO) "To remove the intermediate files, say $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean" '; push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n"; push @m, "# More from the 255-char line length limit\n"; foreach (@staticpkgs) { push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n]; } push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir; $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET) $(NOECHO) $(RM_F) %sWritemain.tmp MAKE_FRAG push @m, q[ # Still more from the 255-char line length limit doc_inst_perl : $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[ $(NOECHO) $(RM_F) .MM_tmp ]; push @m, " inst_perl : pure_inst_perl doc_inst_perl \$(NOECHO) \$(NOOP) pure_inst_perl : \$(MAP_TARGET) $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1)," $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1)," clean :: map_clean \$(NOECHO) \$(NOOP) map_clean : \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE) \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET) "; join '', @m; } # --- Output postprocessing section --- =item maketext_filter (override) Ensure that colons marking targets are preceded by space, in order to distinguish the target delimiter from a colon appearing as part of a filespec. =cut sub maketext_filter { my($self, $text) = @_; $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg; return $text; } =item prefixify (override) prefixifying on VMS is simple. Each should simply be: perl_root:[some.dir] which can just be converted to: volume:[your.prefix.some.dir] otherwise you get the default layout. In effect, your search prefix is ignored and $Config{vms_prefix} is used instead. =cut sub prefixify { my($self, $var, $sprefix, $rprefix, $default) = @_; # Translate $(PERLPREFIX) to a real path. $rprefix = $self->eliminate_macros($rprefix); $rprefix = vmspath($rprefix) if $rprefix; $sprefix = vmspath($sprefix) if $sprefix; $default = vmsify($default) unless $default =~ /\[.*\]/; (my $var_no_install = $var) =~ s/^install//; my $path = $self->{uc $var} || $ExtUtils::MM_Unix::Config_Override{lc $var} || $Config{lc $var} || $Config{lc $var_no_install}; if( !$path ) { warn " no Config found for $var.\n" if $Verbose >= 2; $path = $self->_prefixify_default($rprefix, $default); } elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) { # do nothing if there's no prefix or if its relative } elsif( $sprefix eq $rprefix ) { warn " no new prefix.\n" if $Verbose >= 2; } else { warn " prefixify $var => $path\n" if $Verbose >= 2; warn " from $sprefix to $rprefix\n" if $Verbose >= 2; my($path_vol, $path_dirs) = $self->splitpath( $path ); if( $path_vol eq $Config{vms_prefix}.':' ) { warn " $Config{vms_prefix}: seen\n" if $Verbose >= 2; $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; $path = $self->_catprefix($rprefix, $path_dirs); } else { $path = $self->_prefixify_default($rprefix, $default); } } print " now $path\n" if $Verbose >= 2; return $self->{uc $var} = $path; } sub _prefixify_default { my($self, $rprefix, $default) = @_; warn " cannot prefix, using default.\n" if $Verbose >= 2; if( !$default ) { warn "No default!\n" if $Verbose >= 1; return; } if( !$rprefix ) { warn "No replacement prefix!\n" if $Verbose >= 1; return ''; } return $self->_catprefix($rprefix, $default); } sub _catprefix { my($self, $rprefix, $default) = @_; my($rvol, $rdirs) = $self->splitpath($rprefix); if( $rvol ) { return $self->catpath($rvol, $self->catdir($rdirs, $default), '' ) } else { return $self->catdir($rdirs, $default); } } =item cd =cut sub cd { my($self, $dir, @cmds) = @_; $dir = vmspath($dir); my $cmd = join "\n\t", map "$_", @cmds; # No leading tab makes it look right when embedded my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd; startdir = F$Environment("Default") Set Default %s %s Set Default 'startdir' MAKE_FRAG # No trailing newline makes this easier to embed chomp $make_frag; return $make_frag; } =item oneliner =cut sub oneliner { my($self, $cmd, $switches) = @_; $switches = [] unless defined $switches; # Strip leading and trailing newlines $cmd =~ s{^\n+}{}; $cmd =~ s{\n+$}{}; my @cmds = split /\n/, $cmd; $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds; $cmd = $self->escape_newlines($cmd); # Switches must be quoted else they will be lowercased. $switches = join ' ', map { qq{"$_"} } @$switches; return qq{\$(ABSPERLRUN) $switches -e $cmd "--"}; } =item B<echo> perl trips up on "<foo>" thinking it's an input redirect. So we use the native Write command instead. Besides, it's faster. =cut sub echo { my($self, $text, $file, $opts) = @_; # Compatibility with old options if( !ref $opts ) { my $append = $opts; $opts = { append => $append || 0 }; } my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write'; $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; my $ql_opts = { allow_variables => $opts->{allow_variables} }; my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file "); push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) } split /\n/, $text; push @cmds, '$(NOECHO) Close MMECHOFILE'; return @cmds; } =item quote_literal =cut sub quote_literal { my($self, $text, $opts) = @_; $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; # I believe this is all we should need. $text =~ s{"}{""}g; $text = $opts->{allow_variables} ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); return qq{"$text"}; } =item escape_dollarsigns Quote, don't escape. =cut sub escape_dollarsigns { my($self, $text) = @_; # Quote dollar signs which are not starting a variable $text =~ s{\$ (?!\() }{"\$"}gx; return $text; } =item escape_all_dollarsigns Quote, don't escape. =cut sub escape_all_dollarsigns { my($self, $text) = @_; # Quote dollar signs $text =~ s{\$}{"\$\"}gx; return $text; } =item escape_newlines =cut sub escape_newlines { my($self, $text) = @_; $text =~ s{\n}{-\n}g; return $text; } =item max_exec_len 256 characters. =cut sub max_exec_len { my $self = shift; return $self->{_MAX_EXEC_LEN} ||= 256; } =item init_linker =cut sub init_linker { my $self = shift; $self->{EXPORT_LIST} ||= '$(BASEEXT).opt'; my $shr = $Config{dbgprefix} . 'PERLSHR'; if ($self->{PERL_SRC}) { $self->{PERL_ARCHIVE} ||= $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}"); } else { $self->{PERL_ARCHIVE} ||= $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"; } $self->{PERL_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; } =item catdir (override) =item catfile (override) Eliminate the macros in the output to the MMS/MMK file. (L<File::Spec::VMS> used to do this for us, but it's being removed) =cut sub catdir { my $self = shift; # Process the macros on VMS MMS/MMK my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; my $dir = $self->SUPER::catdir(@args); # Fix up the directory and force it to VMS format. $dir = $self->fixpath($dir, 1); return $dir; } sub catfile { my $self = shift; # Process the macros on VMS MMS/MMK my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; my $file = $self->SUPER::catfile(@args); $file = vmsify($file); return $file } =item eliminate_macros Expands MM[KS]/Make macros in a text string, using the contents of identically named elements of C<%$self>, and returns the result as a file specification in Unix syntax. NOTE: This is the canonical version of the method. The version in L<File::Spec::VMS> is deprecated. =cut sub eliminate_macros { my($self,$path) = @_; return '' unless $path; $self = {} unless ref $self; my($npath) = unixify($path); # sometimes unixify will return a string with an off-by-one trailing null $npath =~ s{\0$}{}; my($complex) = 0; my($head,$macro,$tail); # perform m##g in scalar context so it acts as an iterator while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { if (defined $self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); if (ref $self->{$macro}) { if (ref $self->{$macro} eq 'ARRAY') { $macro = join ' ', @{$self->{$macro}}; } else { print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; $macro = "\cB$macro\cB"; $complex = 1; } } else { $macro = $self->{$macro}; # Don't unixify if there is unescaped whitespace $macro = unixify($macro) unless ($macro =~ /(?<!\^)\s/); $macro =~ s#/\Z(?!\n)##; } $npath = "$head$macro$tail"; } } if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } $npath; } =item fixpath my $path = $mm->fixpath($path); my $path = $mm->fixpath($path, $is_dir); Catchall routine to clean up problem MM[SK]/Make macros. Expands macros in any directory specification, in order to avoid juxtaposing two VMS-syntax directories when MM[SK] is run. Also expands expressions which are all macro, so that we can tell how long the expansion is, and avoid overrunning DCL's command buffer when MM[KS] is running. fixpath() checks to see whether the result matches the name of a directory in the current default directory and returns a directory or file specification accordingly. C<$is_dir> can be set to true to force fixpath() to consider the path to be a directory or false to force it to be a file. NOTE: This is the canonical version of the method. The version in L<File::Spec::VMS> is deprecated. =cut sub fixpath { my($self,$path,$force_path) = @_; return '' unless $path; $self = bless {}, $self unless ref $self; my($fixedpath,$prefix,$name); if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { $fixedpath = vmspath($self->eliminate_macros($path)); } else { $fixedpath = vmsify($self->eliminate_macros($path)); } } elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { my($vmspre) = $self->eliminate_macros("\$($prefix)"); # is it a dir or just a name? $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; $fixedpath = vmspath($fixedpath) if $force_path; } else { $fixedpath = $path; $fixedpath = vmspath($fixedpath) if $force_path; } # No hints, so we try to guess if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($fixedpath) if -d $fixedpath; } # Trim off root dirname if it's had other dirs inserted in front of it. $fixedpath =~ s/\.000000([\]>])/$1/; # Special case for VMS absolute directory specs: these will have had device # prepended during trip through Unix syntax in eliminate_macros(), since # Unix syntax has no way to express "absolute from the top of this device's # directory tree". if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } return $fixedpath; } =item os_flavor VMS is VMS. =cut sub os_flavor { return('VMS'); } =item is_make_type (override) None of the make types being checked for is viable on VMS, plus our $self->{MAKE} is an unexpanded (and unexpandable) macro whose value is known only to the make utility itself. =cut sub is_make_type { my($self, $type) = @_; return 0; } =item make_type (override) Returns a suitable string describing the type of makefile being written. =cut sub make_type { "$Config{make}-style"; } =back =head1 AUTHOR Original author Charles Bailey F<bailey@newman.upenn.edu> Maintained by Michael G Schwern F<schwern@pobox.com> See L<ExtUtils::MakeMaker> for patching and contact information. =cut 1; perl5/ExtUtils/ParseXS/Constants.pm 0000444 00000002170 14711220005 0013201 0 ustar 00 package ExtUtils::ParseXS::Constants; use strict; use warnings; use Symbol; our $VERSION = '3.35'; =head1 NAME ExtUtils::ParseXS::Constants - Initialization values for some globals =head1 SYNOPSIS use ExtUtils::ParseXS::Constants (); $PrototypeRegexp = $ExtUtils::ParseXS::Constants::PrototypeRegexp; =head1 DESCRIPTION Initialization of certain non-subroutine variables in ExtUtils::ParseXS and some of its supporting packages has been moved into this package so that those values can be defined exactly once and then re-used in any package. Nothing is exported. Use fully qualified variable names. =cut # FIXME: THESE ARE NOT CONSTANTS! our @InitFileCode; # Note that to reduce maintenance, $PrototypeRegexp is used # by ExtUtils::Typemaps, too! our $PrototypeRegexp = "[" . quotemeta('\$%&*@;[]_') . "]"; our @XSKeywords = qw( REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK EXPORT_XSUB_SYMBOLS ); our $XSKeywordsAlternation = join('|', @XSKeywords); 1; perl5/ExtUtils/ParseXS/Eval.pm 0000444 00000004506 14711220006 0012122 0 ustar 00 package ExtUtils::ParseXS::Eval; use strict; use warnings; our $VERSION = '3.35'; =head1 NAME ExtUtils::ParseXS::Eval - Clean package to evaluate code in =head1 SYNOPSIS use ExtUtils::ParseXS::Eval; my $rv = ExtUtils::ParseXS::Eval::eval_typemap_code( $parsexs_obj, "some Perl code" ); =head1 SUBROUTINES =head2 $pxs->eval_output_typemap_code($typemapcode, $other_hashref) Sets up various bits of previously global state (formerly ExtUtils::ParseXS package variables) for eval'ing output typemap code that may refer to these variables. Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: $Package $Alias $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: $var $type $ntype $subtype $arg =cut sub eval_output_typemap_code { my ($_pxs, $_code, $_other) = @_; my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; my ($var, $type, $ntype, $subtype, $arg) = @{$_other}{qw(var type ntype subtype arg)}; my $rv = eval $_code; warn $@ if $@; return $rv; } =head2 $pxs->eval_input_typemap_code($typemapcode, $other_hashref) Sets up various bits of previously global state (formerly ExtUtils::ParseXS package variables) for eval'ing output typemap code that may refer to these variables. Warns the contents of C<$@> if any. Not all these variables are necessarily considered "public" wrt. use in typemaps, so beware. Variables set up from the ExtUtils::ParseXS object: $Package $Alias $func_name $Full_func_name $pname Variables set up from C<$other_hashref>: $var $type $ntype $subtype $num $init $printed_name $arg $argoff =cut sub eval_input_typemap_code { my ($_pxs, $_code, $_other) = @_; my ($Package, $ALIAS, $func_name, $Full_func_name, $pname) = @{$_pxs}{qw(Package ALIAS func_name Full_func_name pname)}; my ($var, $type, $num, $init, $printed_name, $arg, $ntype, $argoff, $subtype) = @{$_other}{qw(var type num init printed_name arg ntype argoff subtype)}; my $rv = eval $_code; warn $@ if $@; return $rv; } =head1 TODO Eventually, with better documentation and possible some cleanup, this could be part of C<ExtUtils::Typemaps>. =cut 1; # vim: ts=2 sw=2 et: perl5/ExtUtils/ParseXS/Utilities.pm 0000444 00000041423 14711220011 0013201 0 ustar 00 package ExtUtils::ParseXS::Utilities; use strict; use warnings; use Exporter; use File::Spec; use ExtUtils::ParseXS::Constants (); our $VERSION = '3.35'; our (@ISA, @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); =head1 NAME ExtUtils::ParseXS::Utilities - Subroutines used with ExtUtils::ParseXS =head1 SYNOPSIS use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); =head1 SUBROUTINES The following functions are not considered to be part of the public interface. They are documented here for the benefit of future maintainers of this module. =head2 C<standard_typemap_locations()> =over 4 =item * Purpose Provide a list of filepaths where F<typemap> files may be found. The filepaths -- relative paths to files (not just directory paths) -- appear in this list in lowest-to-highest priority. The highest priority is to look in the current directory. 'typemap' The second and third highest priorities are to look in the parent of the current directory and a directory called F<lib/ExtUtils> underneath the parent directory. '../typemap', '../lib/ExtUtils/typemap', The fourth through ninth highest priorities are to look in the corresponding grandparent, great-grandparent and great-great-grandparent directories. '../../typemap', '../../lib/ExtUtils/typemap', '../../../typemap', '../../../lib/ExtUtils/typemap', '../../../../typemap', '../../../../lib/ExtUtils/typemap', The tenth and subsequent priorities are to look in directories named F<ExtUtils> which are subdirectories of directories found in C<@INC> -- I<provided> a file named F<typemap> actually exists in such a directory. Example: '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', However, these filepaths appear in the list returned by C<standard_typemap_locations()> in reverse order, I<i.e.>, lowest-to-highest. '/usr/local/lib/perl5/5.10.1/ExtUtils/typemap', '../../../../lib/ExtUtils/typemap', '../../../../typemap', '../../../lib/ExtUtils/typemap', '../../../typemap', '../../lib/ExtUtils/typemap', '../../typemap', '../lib/ExtUtils/typemap', '../typemap', 'typemap' =item * Arguments my @stl = standard_typemap_locations( \@INC ); Reference to C<@INC>. =item * Return Value Array holding list of directories to be searched for F<typemap> files. =back =cut SCOPE: { my @tm_template; sub standard_typemap_locations { my $include_ref = shift; if (not @tm_template) { @tm_template = qw(typemap); my $updir = File::Spec->updir(); foreach my $dir ( File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2), File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4), ) { unshift @tm_template, File::Spec->catfile($dir, 'typemap'); unshift @tm_template, File::Spec->catfile($dir, lib => ExtUtils => 'typemap'); } } my @tm = @tm_template; foreach my $dir (@{ $include_ref}) { my $file = File::Spec->catfile($dir, ExtUtils => 'typemap'); unshift @tm, $file if -e $file; } return @tm; } } # end SCOPE =head2 C<trim_whitespace()> =over 4 =item * Purpose Perform an in-place trimming of leading and trailing whitespace from the first argument provided to the function. =item * Argument trim_whitespace($arg); =item * Return Value None. Remember: this is an I<in-place> modification of the argument. =back =cut sub trim_whitespace { $_[0] =~ s/^\s+|\s+$//go; } =head2 C<C_string()> =over 4 =item * Purpose Escape backslashes (C<\>) in prototype strings. =item * Arguments $ProtoThisXSUB = C_string($_); String needing escaping. =item * Return Value Properly escaped string. =back =cut sub C_string { my($string) = @_; $string =~ s[\\][\\\\]g; $string; } =head2 C<valid_proto_string()> =over 4 =item * Purpose Validate prototype string. =item * Arguments String needing checking. =item * Return Value Upon success, returns the same string passed as argument. Upon failure, returns C<0>. =back =cut sub valid_proto_string { my ($string) = @_; if ( $string =~ /^$ExtUtils::ParseXS::Constants::PrototypeRegexp+$/ ) { return $string; } return 0; } =head2 C<process_typemaps()> =over 4 =item * Purpose Process all typemap files. =item * Arguments my $typemaps_object = process_typemaps( $args{typemap}, $pwd ); List of two elements: C<typemap> element from C<%args>; current working directory. =item * Return Value Upon success, returns an L<ExtUtils::Typemaps> object. =back =cut sub process_typemaps { my ($tmap, $pwd) = @_; my @tm = ref $tmap ? @{$tmap} : ($tmap); foreach my $typemap (@tm) { die "Can't find $typemap in $pwd\n" unless -r $typemap; } push @tm, standard_typemap_locations( \@INC ); require ExtUtils::Typemaps; my $typemap = ExtUtils::Typemaps->new; foreach my $typemap_loc (@tm) { next unless -f $typemap_loc; # skip directories, binary files etc. warn("Warning: ignoring non-text typemap file '$typemap_loc'\n"), next unless -T $typemap_loc; $typemap->merge(file => $typemap_loc, replace => 1); } return $typemap; } =head2 C<map_type()> =over 4 =item * Purpose Performs a mapping at several places inside C<PARAGRAPH> loop. =item * Arguments $type = map_type($self, $type, $varname); List of three arguments. =item * Return Value String holding augmented version of second argument. =back =cut sub map_type { my ($self, $type, $varname) = @_; # C++ has :: in types too so skip this $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; if ($varname) { if ($type =~ / \( \s* \* (?= \s* \) ) /xg) { (substr $type, pos $type, 0) = " $varname "; } else { $type .= "\t$varname"; } } return $type; } =head2 C<standard_XS_defs()> =over 4 =item * Purpose Writes to the C<.c> output file certain preprocessor directives and function headers needed in all such files. =item * Arguments None. =item * Return Value Returns true. =back =cut sub standard_XS_defs { print <<"EOF"; #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef dVAR # define dVAR dNOOP #endif /* This stuff is not part of the API! You have been warned. */ #ifndef PERL_VERSION_DECIMAL # define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) #endif #ifndef PERL_DECIMAL_VERSION # define PERL_DECIMAL_VERSION \\ PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) #endif #ifndef PERL_VERSION_GE # define PERL_VERSION_GE(r,v,s) \\ (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) #endif #ifndef PERL_VERSION_LE # define PERL_VERSION_LE(r,v,s) \\ (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) #endif /* XS_INTERNAL is the explicit static-linkage variant of the default * XS macro. * * XS_EXTERNAL is the same as XS_INTERNAL except it does not include * "STATIC", ie. it exports XSUB symbols. You probably don't want that * for anything but the BOOT XSUB. * * See XSUB.h in core! */ /* TODO: This might be compatible further back than 5.10.0. */ #if PERL_VERSION_GE(5, 10, 0) && PERL_VERSION_LE(5, 15, 1) # undef XS_EXTERNAL # undef XS_INTERNAL # if defined(__CYGWIN__) && defined(USE_DYNAMIC_LOADING) # define XS_EXTERNAL(name) __declspec(dllexport) XSPROTO(name) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # if defined(__SYMBIAN32__) # define XS_EXTERNAL(name) EXPORT_C XSPROTO(name) # define XS_INTERNAL(name) EXPORT_C STATIC XSPROTO(name) # endif # ifndef XS_EXTERNAL # if defined(HASATTRIBUTE_UNUSED) && !defined(__cplusplus) # define XS_EXTERNAL(name) void name(pTHX_ CV* cv __attribute__unused__) # define XS_INTERNAL(name) STATIC void name(pTHX_ CV* cv __attribute__unused__) # else # ifdef __cplusplus # define XS_EXTERNAL(name) extern "C" XSPROTO(name) # define XS_INTERNAL(name) static XSPROTO(name) # else # define XS_EXTERNAL(name) XSPROTO(name) # define XS_INTERNAL(name) STATIC XSPROTO(name) # endif # endif # endif #endif /* perl >= 5.10.0 && perl <= 5.15.1 */ /* The XS_EXTERNAL macro is used for functions that must not be static * like the boot XSUB of a module. If perl didn't have an XS_EXTERNAL * macro defined, the best we can do is assume XS is the same. * Dito for XS_INTERNAL. */ #ifndef XS_EXTERNAL # define XS_EXTERNAL(name) XS(name) #endif #ifndef XS_INTERNAL # define XS_INTERNAL(name) XS(name) #endif /* Now, finally, after all this mess, we want an ExtUtils::ParseXS * internal macro that we're free to redefine for varying linkage due * to the EXPORT_XSUB_SYMBOLS XS keyword. This is internal, use * XS_EXTERNAL(name) or XS_INTERNAL(name) in your code if you need to! */ #undef XS_EUPXS #if defined(PERL_EUPXS_ALWAYS_EXPORT) # define XS_EUPXS(name) XS_EXTERNAL(name) #else /* default to internal */ # define XS_EUPXS(name) XS_INTERNAL(name) #endif EOF print <<"EOF"; #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) /* prototype to pass -Wmissing-prototypes */ STATIC void S_croak_xs_usage(const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak_nocontext("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define croak_xs_usage S_croak_xs_usage #endif /* NOTE: the prototype of newXSproto() is different in versions of perls, * so we define a portable version of newXSproto() */ #ifdef newXS_flags #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) #else #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ #if PERL_VERSION_LE(5, 21, 5) # define newXS_deffile(a,b) Perl_newXS(aTHX_ a,b,file) #else # define newXS_deffile(a,b) Perl_newXS_deffile(aTHX_ a,b) #endif EOF return 1; } =head2 C<assign_func_args()> =over 4 =item * Purpose Perform assignment to the C<func_args> attribute. =item * Arguments $string = assign_func_args($self, $argsref, $class); List of three elements. Second is an array reference; third is a string. =item * Return Value String. =back =cut sub assign_func_args { my ($self, $argsref, $class) = @_; my @func_args = @{$argsref}; shift @func_args if defined($class); for my $arg (@func_args) { $arg =~ s/^/&/ if $self->{in_out}->{$arg}; } return join(", ", @func_args); } =head2 C<analyze_preprocessor_statements()> =over 4 =item * Purpose Within each function inside each Xsub, print to the F<.c> output file certain preprocessor statements. =item * Arguments ( $self, $XSS_work_idx, $BootCode_ref ) = analyze_preprocessor_statements( $self, $statement, $XSS_work_idx, $BootCode_ref ); List of four elements. =item * Return Value Modifed values of three of the arguments passed to the function. In particular, the C<XSStack> and C<InitFileCode> attributes are modified. =back =cut sub analyze_preprocessor_statements { my ($self, $statement, $XSS_work_idx, $BootCode_ref) = @_; if ($statement eq 'if') { $XSS_work_idx = @{ $self->{XSStack} }; push(@{ $self->{XSStack} }, {type => 'if'}); } else { $self->death("Error: '$statement' with no matching 'if'") if $self->{XSStack}->[-1]{type} ne 'if'; if ($self->{XSStack}->[-1]{varname}) { push(@{ $self->{InitFileCode} }, "#endif\n"); push(@{ $BootCode_ref }, "#endif"); } my(@fns) = keys %{$self->{XSStack}->[-1]{functions}}; if ($statement ne 'endif') { # Hide the functions defined in other #if branches, and reset. @{$self->{XSStack}->[-1]{other_functions}}{@fns} = (1) x @fns; @{$self->{XSStack}->[-1]}{qw(varname functions)} = ('', {}); } else { my($tmp) = pop(@{ $self->{XSStack} }); 0 while (--$XSS_work_idx && $self->{XSStack}->[$XSS_work_idx]{type} ne 'if'); # Keep all new defined functions push(@fns, keys %{$tmp->{other_functions}}); @{$self->{XSStack}->[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; } } return ($self, $XSS_work_idx, $BootCode_ref); } =head2 C<set_cond()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub set_cond { my ($ellipsis, $min_args, $num_args) = @_; my $cond; if ($ellipsis) { $cond = ($min_args ? qq(items < $min_args) : 0); } elsif ($min_args == $num_args) { $cond = qq(items != $min_args); } else { $cond = qq(items < $min_args || items > $num_args); } return $cond; } =head2 C<current_line_number()> =over 4 =item * Purpose Figures out the current line number in the XS file. =item * Arguments C<$self> =item * Return Value The current line number. =back =cut sub current_line_number { my $self = shift; my $line_number = $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1]; return $line_number; } =head2 C<Warn()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub Warn { my $self = shift; my $warn_line_number = $self->current_line_number(); print STDERR "@_ in $self->{filename}, line $warn_line_number\n"; } =head2 C<blurt()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub blurt { my $self = shift; $self->Warn(@_); $self->{errors}++ } =head2 C<death()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub death { my $self = shift; $self->Warn(@_); exit 1; } =head2 C<check_conditional_preprocessor_statements()> =over 4 =item * Purpose =item * Arguments =item * Return Value =back =cut sub check_conditional_preprocessor_statements { my ($self) = @_; my @cpp = grep(/^\#\s*(?:if|e\w+)/, @{ $self->{line} }); if (@cpp) { my $cpplevel; for my $cpp (@cpp) { if ($cpp =~ /^\#\s*if/) { $cpplevel++; } elsif (!$cpplevel) { $self->Warn("Warning: #else/elif/endif without #if in this function"); print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" if $self->{XSStack}->[-1]{type} eq 'if'; return; } elsif ($cpp =~ /^\#\s*endif/) { $cpplevel--; } } $self->Warn("Warning: #if without #endif in this function") if $cpplevel; } } =head2 C<escape_file_for_line_directive()> =over 4 =item * Purpose Escapes a given code source name (typically a file name but can also be a command that was read from) so that double-quotes and backslashes are escaped. =item * Arguments A string. =item * Return Value A string with escapes for double-quotes and backslashes. =back =cut sub escape_file_for_line_directive { my $string = shift; $string =~ s/\\/\\\\/g; $string =~ s/"/\\"/g; return $string; } =head2 C<report_typemap_failure> =over 4 =item * Purpose Do error reporting for missing typemaps. =item * Arguments The C<ExtUtils::ParseXS> object. An C<ExtUtils::Typemaps> object. The string that represents the C type that was not found in the typemap. Optionally, the string C<death> or C<blurt> to choose whether the error is immediately fatal or not. Default: C<blurt> =item * Return Value Returns nothing. Depending on the arguments, this may call C<death> or C<blurt>, the former of which is fatal. =back =cut sub report_typemap_failure { my ($self, $tm, $ctype, $error_method) = @_; $error_method ||= 'blurt'; my @avail_ctypes = $tm->list_mapped_ctypes; my $err = "Could not find a typemap for C type '$ctype'.\n" . "The following C types are mapped by the current typemap:\n'" . join("', '", @avail_ctypes) . "'\n"; $self->$error_method($err); return(); } 1; # vim: ts=2 sw=2 et: perl5/ExtUtils/ParseXS/CountLines.pm 0000444 00000001713 14711220013 0013311 0 ustar 00 package ExtUtils::ParseXS::CountLines; use strict; our $VERSION = '3.35'; our $SECTION_END_MARKER; sub TIEHANDLE { my ($class, $cfile, $fh) = @_; $cfile =~ s/\\/\\\\/g; $cfile =~ s/"/\\"/g; $SECTION_END_MARKER = qq{#line --- "$cfile"}; return bless { buffer => '', fh => $fh, line_no => 1, }, $class; } sub PRINT { my $self = shift; for (@_) { $self->{buffer} .= $_; while ($self->{buffer} =~ s/^([^\n]*\n)//) { my $line = $1; ++$self->{line_no}; $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|; print {$self->{fh}} $line; } } } sub PRINTF { my $self = shift; my $fmt = shift; $self->PRINT(sprintf($fmt, @_)); } sub DESTROY { # Not necessary if we're careful to end with a "\n" my $self = shift; print {$self->{fh}} $self->{buffer}; } sub UNTIE { # This sub does nothing, but is necessary for references to be released. } sub end_marker { return $SECTION_END_MARKER; } 1; perl5/ExtUtils/MM_Any.pm 0000444 00000241633 14711220014 0011031 0 ustar 00 package ExtUtils::MM_Any; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; use Carp; use File::Spec; use File::Basename; BEGIN { our @ISA = qw(File::Spec); } # We need $Verbose use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); use ExtUtils::MakeMaker::Config; # So we don't have to keep calling the methods over and over again, # we have these globals to cache the values. Faster and shrtr. my $Curdir = __PACKAGE__->curdir; #my $Updir = __PACKAGE__->updir; my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec'; my $METASPEC_V = 2; =head1 NAME ExtUtils::MM_Any - Platform-agnostic MM methods =head1 SYNOPSIS FOR INTERNAL USE ONLY! package ExtUtils::MM_SomeOS; # Temporarily, you have to subclass both. Put MM_Any first. require ExtUtils::MM_Any; require ExtUtils::MM_Unix; @ISA = qw(ExtUtils::MM_Any ExtUtils::Unix); =head1 DESCRIPTION B<FOR INTERNAL USE ONLY!> ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of modules. It contains methods which are either inherently cross-platform or are written in a cross-platform manner. Subclass off of ExtUtils::MM_Any I<and> L<ExtUtils::MM_Unix>. This is a temporary solution. B<THIS MAY BE TEMPORARY!> =head1 METHODS Any methods marked I<Abstract> must be implemented by subclasses. =head2 Cross-platform helper methods These are methods which help writing cross-platform code. =head3 os_flavor I<Abstract> my @os_flavor = $mm->os_flavor; @os_flavor is the style of operating system this is, usually corresponding to the MM_*.pm file we're using. The first element of @os_flavor is the major family (ie. Unix, Windows, VMS, OS/2, etc...) and the rest are sub families. Some examples: Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x') Windows ('Win32') Win98 ('Win32', 'Win9x') Linux ('Unix', 'Linux') MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X') OS/2 ('OS/2') This is used to write code for styles of operating system. See os_flavor_is() for use. =head3 os_flavor_is my $is_this_flavor = $mm->os_flavor_is($this_flavor); my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors); Checks to see if the current operating system is one of the given flavors. This is useful for code like: if( $mm->os_flavor_is('Unix') ) { $out = `foo 2>&1`; } else { $out = `foo`; } =cut sub os_flavor_is { my $self = shift; my %flavors = map { ($_ => 1) } $self->os_flavor; return (grep { $flavors{$_} } @_) ? 1 : 0; } =head3 can_load_xs my $can_load_xs = $self->can_load_xs; Returns true if we have the ability to load XS. This is important because miniperl, used to build XS modules in the core, can not load XS. =cut sub can_load_xs { return defined &DynaLoader::boot_DynaLoader ? 1 : 0; } =head3 can_run use ExtUtils::MM; my $runnable = MM->can_run($Config{make}); If called in a scalar context it will return the full path to the binary you asked for if it was found, or C<undef> if it was not. If called in a list context, it will return a list of the full paths to instances of the binary where found in C<PATH>, or an empty list if it was not found. Copied from L<IPC::Cmd|IPC::Cmd/"$path = can_run( PROGRAM );">, but modified into a method (and removed C<$INSTANCES> capability). =cut sub can_run { my ($self, $command) = @_; # a lot of VMS executables have a symbol defined # check those first if ( $^O eq 'VMS' ) { require VMS::DCLsym; my $syms = VMS::DCLsym->new; return $command if scalar $syms->getsym( uc $command ); } my @possibles; if( File::Spec->file_name_is_absolute($command) ) { return $self->maybe_command($command); } else { for my $dir ( File::Spec->path, File::Spec->curdir ) { next if ! $dir || ! -d $dir; my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command); push @possibles, $abs if $abs = $self->maybe_command($abs); } } return @possibles if wantarray; return shift @possibles; } =head3 can_redirect_error $useredirect = MM->can_redirect_error; True if on an OS where qx operator (or backticks) can redirect C<STDERR> onto C<STDOUT>. =cut sub can_redirect_error { my $self = shift; $self->os_flavor_is('Unix') or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x')) or $self->os_flavor_is('OS/2') } =head3 is_make_type my $is_dmake = $self->is_make_type('dmake'); Returns true if C<< $self->make >> is the given type; possibilities are: gmake GNU make dmake nmake bsdmake BSD pmake-derived =cut my %maketype2true; # undocumented - so t/cd.t can still do its thing sub _clear_maketype_cache { %maketype2true = () } sub is_make_type { my($self, $type) = @_; return $maketype2true{$type} if defined $maketype2true{$type}; (undef, undef, my $make_basename) = $self->splitpath($self->make); return $maketype2true{$type} = 1 if $make_basename =~ /\b$type\b/i; # executable's filename return $maketype2true{$type} = 0 if $make_basename =~ /\b[gdn]make\b/i; # Never fall through for dmake/nmake/gmake # now have to run with "-v" and guess my $redirect = $self->can_redirect_error ? '2>&1' : ''; my $make = $self->make || $self->{MAKE}; my $minus_v = `"$make" -v $redirect`; return $maketype2true{$type} = 1 if $type eq 'gmake' and $minus_v =~ /GNU make/i; return $maketype2true{$type} = 1 if $type eq 'bsdmake' and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im; $maketype2true{$type} = 0; # it wasn't whatever you asked } =head3 can_dep_space my $can_dep_space = $self->can_dep_space; Returns true if C<make> can handle (probably by quoting) dependencies that contain a space. Currently known true for GNU make, false for BSD pmake derivative. =cut my $cached_dep_space; sub can_dep_space { my $self = shift; return $cached_dep_space if defined $cached_dep_space; return $cached_dep_space = 1 if $self->is_make_type('gmake'); return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32 return $cached_dep_space = 0 if $self->is_make_type('bsdmake'); return $cached_dep_space = 0; # assume no } =head3 quote_dep $text = $mm->quote_dep($text); Method that protects Makefile single-value constants (mainly filenames), so that make will still treat them as single values even if they inconveniently have spaces in. If the make program being used cannot achieve such protection and the given text would need it, throws an exception. =cut sub quote_dep { my ($self, $arg) = @_; die <<EOF if $arg =~ / / and not $self->can_dep_space; Tried to use make dependency with space for make that can't: '$arg' EOF $arg =~ s/( )/\\$1/g; # how GNU make does it return $arg; } =head3 split_command my @cmds = $MM->split_command($cmd, @args); Most OS have a maximum command length they can execute at once. Large modules can easily generate commands well past that limit. Its necessary to split long commands up into a series of shorter commands. C<split_command> will return a series of @cmds each processing part of the args. Collectively they will process all the arguments. Each individual line in @cmds will not be longer than the $self->max_exec_len being careful to take into account macro expansion. $cmd should include any switches and repeated initial arguments. If no @args are given, no @cmds will be returned. Pairs of arguments will always be preserved in a single command, this is a heuristic for things like pm_to_blib and pod2man which work on pairs of arguments. This makes things like this safe: $self->split_command($cmd, %pod2man); =cut sub split_command { my($self, $cmd, @args) = @_; my @cmds = (); return(@cmds) unless @args; # If the command was given as a here-doc, there's probably a trailing # newline. chomp $cmd; # set aside 30% for macro expansion. my $len_left = int($self->max_exec_len * 0.70); $len_left -= length $self->_expand_macros($cmd); do { my $arg_str = ''; my @next_args; while( @next_args = splice(@args, 0, 2) ) { # Two at a time to preserve pairs. my $next_arg_str = "\t ". join ' ', @next_args, "\n"; if( !length $arg_str ) { $arg_str .= $next_arg_str } elsif( length($arg_str) + length($next_arg_str) > $len_left ) { unshift @args, @next_args; last; } else { $arg_str .= $next_arg_str; } } chop $arg_str; push @cmds, $self->escape_newlines("$cmd \n$arg_str"); } while @args; return @cmds; } sub _expand_macros { my($self, $cmd) = @_; $cmd =~ s{\$\((\w+)\)}{ defined $self->{$1} ? $self->{$1} : "\$($1)" }e; return $cmd; } =head3 make_type Returns a suitable string describing the type of makefile being written. =cut # override if this isn't suitable! sub make_type { return 'Unix-style'; } =head3 stashmeta my @recipelines = $MM->stashmeta($text, $file); Generates a set of C<@recipelines> which will result in the literal C<$text> ending up in literal C<$file> when the recipe is executed. Call it once, with all the text you want in C<$file>. Make macros will not be expanded, so the locations will be fixed at configure-time, not at build-time. =cut sub stashmeta { my($self, $text, $file) = @_; $self->echo($text, $file, { allow_variables => 0, append => 0 }); } =head3 echo my @commands = $MM->echo($text); my @commands = $MM->echo($text, $file); my @commands = $MM->echo($text, $file, \%opts); Generates a set of @commands which print the $text to a $file. If $file is not given, output goes to STDOUT. If $opts{append} is true the $file will be appended to rather than overwritten. Default is to overwrite. If $opts{allow_variables} is true, make variables of the form C<$(...)> will not be escaped. Other C<$> will. Default is to escape all C<$>. Example of use: my $make = join '', map "\t$_\n", $MM->echo($text, $file); =cut sub echo { my($self, $text, $file, $opts) = @_; # Compatibility with old options if( !ref $opts ) { my $append = $opts; $opts = { append => $append || 0 }; } $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; my $ql_opts = { allow_variables => $opts->{allow_variables} }; my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) } split /\n/, $text; if( $file ) { my $redirect = $opts->{append} ? '>>' : '>'; $cmds[0] .= " $redirect $file"; $_ .= " >> $file" foreach @cmds[1..$#cmds]; } return @cmds; } =head3 wraplist my $args = $mm->wraplist(@list); Takes an array of items and turns them into a well-formatted list of arguments. In most cases this is simply something like: FOO \ BAR \ BAZ =cut sub wraplist { my $self = shift; return join " \\\n\t", @_; } =head3 maketext_filter my $filter_make_text = $mm->maketext_filter($make_text); The text of the Makefile is run through this method before writing to disk. It allows systems a chance to make portability fixes to the Makefile. By default it does nothing. This method is protected and not intended to be called outside of MakeMaker. =cut sub maketext_filter { return $_[1] } =head3 cd I<Abstract> my $subdir_cmd = $MM->cd($subdir, @cmds); This will generate a make fragment which runs the @cmds in the given $dir. The rough equivalent to this, except cross platform. cd $subdir && $cmd Currently $dir can only go down one level. "foo" is fine. "foo/bar" is not. "../foo" is right out. The resulting $subdir_cmd has no leading tab nor trailing newline. This makes it easier to embed in a make string. For example. my $make = sprintf <<'CODE', $subdir_cmd; foo : $(ECHO) what %s $(ECHO) mouche CODE =head3 oneliner I<Abstract> my $oneliner = $MM->oneliner($perl_code); my $oneliner = $MM->oneliner($perl_code, \@switches); This will generate a perl one-liner safe for the particular platform you're on based on the given $perl_code and @switches (a -e is assumed) suitable for using in a make target. It will use the proper shell quoting and escapes. $(PERLRUN) will be used as perl. Any newlines in $perl_code will be escaped. Leading and trailing newlines will be stripped. Makes this idiom much easier: my $code = $MM->oneliner(<<'CODE', [...switches...]); some code here another line here CODE Usage might be something like: # an echo emulation $oneliner = $MM->oneliner('print "Foo\n"'); $make = '$oneliner > somefile'; Dollar signs in the $perl_code will be protected from make using the C<quote_literal> method, unless they are recognised as being a make variable, C<$(varname)>, in which case they will be left for make to expand. Remember to quote make macros else it might be used as a bareword. For example: # Assign the value of the $(VERSION_FROM) make macro to $vf. $oneliner = $MM->oneliner('$vf = "$(VERSION_FROM)"'); Its currently very simple and may be expanded sometime in the figure to include more flexible code and switches. =head3 quote_literal I<Abstract> my $safe_text = $MM->quote_literal($text); my $safe_text = $MM->quote_literal($text, \%options); This will quote $text so it is interpreted literally in the shell. For example, on Unix this would escape any single-quotes in $text and put single-quotes around the whole thing. If $options{allow_variables} is true it will leave C<'$(FOO)'> make variables untouched. If false they will be escaped like any other C<$>. Defaults to true. =head3 escape_dollarsigns my $escaped_text = $MM->escape_dollarsigns($text); Escapes stray C<$> so they are not interpreted as make variables. It lets by C<$(...)>. =cut sub escape_dollarsigns { my($self, $text) = @_; # Escape dollar signs which are not starting a variable $text =~ s{\$ (?!\() }{\$\$}gx; return $text; } =head3 escape_all_dollarsigns my $escaped_text = $MM->escape_all_dollarsigns($text); Escapes all C<$> so they are not interpreted as make variables. =cut sub escape_all_dollarsigns { my($self, $text) = @_; # Escape dollar signs $text =~ s{\$}{\$\$}gx; return $text; } =head3 escape_newlines I<Abstract> my $escaped_text = $MM->escape_newlines($text); Shell escapes newlines in $text. =head3 max_exec_len I<Abstract> my $max_exec_len = $MM->max_exec_len; Calculates the maximum command size the OS can exec. Effectively, this is the max size of a shell command line. =for _private $self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes. =head3 make my $make = $MM->make; Returns the make variant we're generating the Makefile for. This attempts to do some normalization on the information from %Config or the user. =cut sub make { my $self = shift; my $make = lc $self->{MAKE}; # Truncate anything like foomake6 to just foomake. $make =~ s/^(\w+make).*/$1/; # Turn gnumake into gmake. $make =~ s/^gnu/g/; return $make; } =head2 Targets These are methods which produce make targets. =head3 all_target Generate the default target 'all'. =cut sub all_target { my $self = shift; return <<'MAKE_EXT'; all :: pure_all $(NOECHO) $(NOOP) MAKE_EXT } =head3 blibdirs_target my $make_frag = $mm->blibdirs_target; Creates the blibdirs target which creates all the directories we use in blib/. The blibdirs.ts target is deprecated. Depend on blibdirs instead. =cut sub _xs_list_basenames { my ($self) = @_; map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} }; } sub blibdirs_target { my $self = shift; my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib autodir archautodir bin script man1dir man3dir ); if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); } } my @exists = map { $_.'$(DFSEP).exists' } @dirs; my $make = sprintf <<'MAKE', join(' ', @exists); blibdirs : %s $(NOECHO) $(NOOP) # Backwards compat with 6.18 through 6.25 blibdirs.ts : blibdirs $(NOECHO) $(NOOP) MAKE $make .= $self->dir_target(@dirs); return $make; } =head3 clean (o) Defines the clean target. =cut sub clean { # --- Cleanup and Distribution Sections --- my($self, %attribs) = @_; my @m; push(@m, ' # Delete temporary files but do not touch installed files. We don\'t delete # the Makefile here so a later make realclean still has a makefile to use. clean :: clean_subdirs '); my @files = sort values %{$self->{XS}}; # .c files from *.xs files push @files, map { my $file = $_; map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base); } $self->_xs_list_basenames; my @dirs = qw(blib); # Normally these are all under blib but they might have been # redefined. # XXX normally this would be a good idea, but the Perl core sets # INST_LIB = ../../lib rather than actually installing the files. # So a "make clean" in an ext/ directory would blow away lib. # Until the core is adjusted let's leave this out. # push @dirs, qw($(INST_ARCHLIB) $(INST_LIB) # $(INST_BIN) $(INST_SCRIPT) # $(INST_MAN1DIR) $(INST_MAN3DIR) # $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR) # $(INST_STATIC) $(INST_DYNAMIC) # ); if( $attribs{FILES} ) { # Use @dirs because we don't know what's in here. push @dirs, ref $attribs{FILES} ? @{$attribs{FILES}} : split /\s+/, $attribs{FILES} ; } push(@files, qw[$(MAKE_APERL_FILE) MYMETA.json MYMETA.yml perlmain.c tmon.out mon.out so_locations blibdirs.ts pm_to_blib pm_to_blib.ts *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT) $(BOOTSTRAP) $(BASEEXT).bso $(BASEEXT).def lib$(BASEEXT).def $(BASEEXT).exp $(BASEEXT).x ]); push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld')); # core files if ($^O eq 'vos') { push(@files, qw[perl*.kp]); } else { push(@files, qw[core core.*perl.*.? *perl.core]); } push(@files, map { "core." . "[0-9]"x$_ } (1..5)); # OS specific things to clean up. Use @dirs since we don't know # what might be in here. push @dirs, $self->extra_clean_files; # Occasionally files are repeated several times from different sources { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; } { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; } push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files); push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs); # Leave Makefile.old around for realclean push @m, <<'MAKE'; $(NOECHO) $(RM_F) $(MAKEFILE_OLD) - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) MAKE push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; join("", @m); } =head3 clean_subdirs_target my $make_frag = $MM->clean_subdirs_target; Returns the clean_subdirs target. This is used by the clean target to call clean on any subdirectories which contain Makefiles. =cut sub clean_subdirs_target { my($self) = shift; # No subdirectories, no cleaning. return <<'NOOP_FRAG' unless @{$self->{DIR}}; clean_subdirs : $(NOECHO) $(NOOP) NOOP_FRAG my $clean = "clean_subdirs :\n"; for my $dir (@{$self->{DIR}}) { my $subclean = $self->oneliner(sprintf <<'CODE', $dir); exit 0 unless chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)'; CODE $clean .= "\t$subclean\n"; } return $clean; } =head3 dir_target my $make_frag = $mm->dir_target(@directories); Generates targets to create the specified directories and set its permission to PERM_DIR. Because depending on a directory to just ensure it exists doesn't work too well (the modified time changes too often) dir_target() creates a .exists file in the created directory. It is this you should depend on. For portability purposes you should use the $(DIRFILESEP) macro rather than a '/' to separate the directory from the file. yourdirectory$(DIRFILESEP).exists =cut sub dir_target { my($self, @dirs) = @_; my $make = ''; foreach my $dir (@dirs) { $make .= sprintf <<'MAKE', ($dir) x 4; %s$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) %s $(NOECHO) $(CHMOD) $(PERM_DIR) %s $(NOECHO) $(TOUCH) %s$(DFSEP).exists MAKE } return $make; } =head3 distdir Defines the scratch directory target that will hold the distribution before tar-ing (or shar-ing). =cut # For backwards compatibility. *dist_dir = *distdir; sub distdir { my($self) = shift; my $meta_target = $self->{NO_META} ? '' : 'distmeta'; my $sign_target = !$self->{SIGN} ? '' : 'distsignature'; return sprintf <<'MAKE_FRAG', $meta_target, $sign_target; create_distdir : $(RM_RF) $(DISTVNAME) $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" distdir : create_distdir %s %s $(NOECHO) $(NOOP) MAKE_FRAG } =head3 dist_test Defines a target that produces the distribution in the scratch directory, and runs 'perl Makefile.PL; make ;make test' in that subdirectory. =cut sub dist_test { my($self) = shift; my $mpl_args = join " ", map qq["$_"], @ARGV; my $test = $self->cd('$(DISTVNAME)', '$(ABSPERLRUN) Makefile.PL '.$mpl_args, '$(MAKE) $(PASTHRU)', '$(MAKE) test $(PASTHRU)' ); return sprintf <<'MAKE_FRAG', $test; disttest : distdir %s MAKE_FRAG } =head3 xs_dlsyms_arg Returns command-line arg(s) to linker for file listing dlsyms to export. Defaults to returning empty string, can be overridden by e.g. AIX. =cut sub xs_dlsyms_arg { return ''; } =head3 xs_dlsyms_ext Returns file-extension for C<xs_make_dlsyms> method's output file, including any "." character. =cut sub xs_dlsyms_ext { die "Pure virtual method"; } =head3 xs_dlsyms_extra Returns any extra text to be prepended to the C<$extra> argument of C<xs_make_dlsyms>. =cut sub xs_dlsyms_extra { ''; } =head3 xs_dlsyms_iterator Iterates over necessary shared objects, calling C<xs_make_dlsyms> method for each with appropriate arguments. =cut sub xs_dlsyms_iterator { my ($self, $attribs) = @_; if ($self->{XSMULTI}) { my @m; for my $ext ($self->_xs_list_basenames) { my @parts = File::Spec->splitdir($ext); shift @parts if $parts[0] eq 'lib'; my $name = join '::', @parts; push @m, $self->xs_make_dlsyms( $attribs, $ext . $self->xs_dlsyms_ext, "$ext.xs", $name, $parts[-1], {}, [], {}, [], $self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext), ); } return join "\n", @m; } else { return $self->xs_make_dlsyms( $attribs, $self->{BASEEXT} . $self->xs_dlsyms_ext, 'Makefile.PL', $self->{NAME}, $self->{DLBASE}, $attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {}, $attribs->{FUNCLIST} || $self->{FUNCLIST} || [], $attribs->{IMPORTS} || $self->{IMPORTS} || {}, $attribs->{DL_VARS} || $self->{DL_VARS} || [], $self->xs_dlsyms_extra, ); } } =head3 xs_make_dlsyms $self->xs_make_dlsyms( \%attribs, # hashref from %attribs in caller "$self->{BASEEXT}.def", # output file for Makefile target 'Makefile.PL', # dependency $self->{NAME}, # shared object's "name" $self->{DLBASE}, # last ::-separated part of name $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}, # various params $attribs{FUNCLIST} || $self->{FUNCLIST} || [], $attribs{IMPORTS} || $self->{IMPORTS} || {}, $attribs{DL_VARS} || $self->{DL_VARS} || [], # optional extra param that will be added as param to Mksymlists ); Utility method that returns Makefile snippet to call C<Mksymlists>. =cut sub xs_make_dlsyms { my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; my @m = ( "\n$target: $dep\n", q! $(PERLRUN) -MExtUtils::Mksymlists \\ -e "Mksymlists('NAME'=>\"!, $name, q!\", 'DLBASE' => '!,$dlbase, # The above two lines quoted differently to work around # a bug in the 4DOS/4NT command line interpreter. The visible # result of the bug was files named q('extension_name',) *with the # single quotes and the comma* in the extension build directories. q!', 'DL_FUNCS' => !,neatvalue($funcs), q!, 'FUNCLIST' => !,neatvalue($funclist), q!, 'IMPORTS' => !,neatvalue($imports), q!, 'DL_VARS' => !, neatvalue($vars) ); push @m, $extra if defined $extra; push @m, qq!);"\n!; join '', @m; } =head3 dynamic (o) Defines the dynamic target. =cut sub dynamic { # --- Dynamic Loading Sections --- my($self) = shift; ' dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC) $(NOECHO) $(NOOP) '; } =head3 makemakerdflt_target my $make_frag = $mm->makemakerdflt_target Returns a make fragment with the makemakerdeflt_target specified. This target is the first target in the Makefile, is the default target and simply points off to 'all' just in case any make variant gets confused or something gets snuck in before the real 'all' target. =cut sub makemakerdflt_target { return <<'MAKE_FRAG'; makemakerdflt : all $(NOECHO) $(NOOP) MAKE_FRAG } =head3 manifypods_target my $manifypods_target = $self->manifypods_target; Generates the manifypods target. This target generates man pages from all POD files in MAN1PODS and MAN3PODS. =cut sub manifypods_target { my($self) = shift; my $man1pods = ''; my $man3pods = ''; my $dependencies = ''; # populate manXpods & dependencies: foreach my $name (sort keys %{$self->{MAN1PODS}}, sort keys %{$self->{MAN3PODS}}) { $dependencies .= " \\\n\t$name"; } my $manify = <<END; manifypods : pure_all config $dependencies END my @man_cmds; foreach my $num (qw(1 3)) { my $pods = $self->{"MAN${num}PODS"}; my $p2m = sprintf <<'CMD', "\$(MAN${num}SECTION)", "$]" > 5.008 ? " -u" : ""; $(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s CMD push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods); } $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds; $manify .= join '', map { "$_\n" } @man_cmds; return $manify; } { my $has_cpan_meta; sub _has_cpan_meta { return $has_cpan_meta if defined $has_cpan_meta; return $has_cpan_meta = !!eval { require CPAN::Meta; CPAN::Meta->VERSION(2.112150); 1; }; } } =head3 metafile_target my $target = $mm->metafile_target; Generate the metafile target. Writes the file META.yml (YAML encoded meta-data) and META.json (JSON encoded meta-data) about the module in the distdir. The format follows Module::Build's as closely as possible. =cut sub metafile_target { my $self = shift; return <<'MAKE_FRAG' if $self->{NO_META} or ! _has_cpan_meta(); metafile : $(NOECHO) $(NOOP) MAKE_FRAG my $metadata = $self->metafile_data( $self->{META_ADD} || {}, $self->{META_MERGE} || {}, ); my $meta = $self->_fix_metadata_before_conversion( $metadata ); my @write_metayml = $self->stashmeta( $meta->as_string({version => "1.4"}), 'META_new.yml' ); my @write_metajson = $self->stashmeta( $meta->as_string({version => "2.0"}), 'META_new.json' ); my $metayml = join("\n\t", @write_metayml); my $metajson = join("\n\t", @write_metajson); return sprintf <<'MAKE_FRAG', $metayml, $metajson; metafile : create_distdir $(NOECHO) $(ECHO) Generating META.yml %s -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml $(NOECHO) $(ECHO) Generating META.json %s -$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json MAKE_FRAG } =begin private =head3 _fix_metadata_before_conversion $mm->_fix_metadata_before_conversion( \%metadata ); Fixes errors in the metadata before it's handed off to L<CPAN::Meta> for conversion. This hopefully results in something that can be used further on, no guarantee is made though. =end private =cut sub _fix_metadata_before_conversion { my ( $self, $metadata ) = @_; # we should never be called unless this already passed but # prefer to be defensive in case somebody else calls this return unless _has_cpan_meta; my $bad_version = $metadata->{version} && !CPAN::Meta::Validator->new->version( 'version', $metadata->{version} ); # just delete all invalid versions if( $bad_version ) { warn "Can't parse version '$metadata->{version}'\n"; $metadata->{version} = ''; } my $validator2 = CPAN::Meta::Validator->new( $metadata ); my @errors; push @errors, $validator2->errors if !$validator2->is_valid; my $validator14 = CPAN::Meta::Validator->new( { %$metadata, 'meta-spec' => { version => 1.4 }, } ); push @errors, $validator14->errors if !$validator14->is_valid; # fix non-camelcase custom resource keys (only other trick we know) for my $error ( @errors ) { my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ ); next if !$key; # first try to remove all non-alphabetic chars ( my $new_key = $key ) =~ s/[^_a-zA-Z]//g; # if that doesn't work, uppercase first one $new_key = ucfirst $new_key if !$validator14->custom_1( $new_key ); # copy to new key if that worked $metadata->{resources}{$new_key} = $metadata->{resources}{$key} if $validator14->custom_1( $new_key ); # and delete old one in any case delete $metadata->{resources}{$key}; } # paper over validation issues, but still complain, necessary because # there's no guarantee that the above will fix ALL errors my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) }; warn $@ if $@ and $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/; # use the original metadata straight if the conversion failed # or if it can't be stringified. if( !$meta || !eval { $meta->as_string( { version => $METASPEC_V } ) } || !eval { $meta->as_string } ) { $meta = bless $metadata, 'CPAN::Meta'; } my $now_license = $meta->as_struct({ version => 2 })->{license}; if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and @{$now_license} == 1 and $now_license->[0] eq 'unknown' ) { warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n"; } $meta; } =begin private =head3 _sort_pairs my @pairs = _sort_pairs($sort_sub, \%hash); Sorts the pairs of a hash based on keys ordered according to C<$sort_sub>. =end private =cut sub _sort_pairs { my $sort = shift; my $pairs = shift; return map { $_ => $pairs->{$_} } sort $sort keys %$pairs; } # Taken from Module::Build::Base sub _hash_merge { my ($self, $h, $k, $v) = @_; if (ref $h->{$k} eq 'ARRAY') { push @{$h->{$k}}, ref $v ? @$v : $v; } elsif (ref $h->{$k} eq 'HASH') { $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v; } else { $h->{$k} = $v; } } =head3 metafile_data my $metadata_hashref = $mm->metafile_data(\%meta_add, \%meta_merge); Returns the data which MakeMaker turns into the META.yml file and the META.json file. It is always in version 2.0 of the format. Values of %meta_add will overwrite any existing metadata in those keys. %meta_merge will be merged with them. =cut sub metafile_data { my $self = shift; my($meta_add, $meta_merge) = @_; $meta_add ||= {}; $meta_merge ||= {}; my $version = _normalize_version($self->{VERSION}); my $release_status = ($version =~ /_/) ? 'unstable' : 'stable'; my %meta = ( # required abstract => $self->{ABSTRACT} || 'unknown', author => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'], dynamic_config => 1, generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION", license => [ $self->{LICENSE} || 'unknown' ], 'meta-spec' => { url => $METASPEC_URL, version => $METASPEC_V, }, name => $self->{DISTNAME}, release_status => $release_status, version => $version, # optional no_index => { directory => [qw(t inc)] }, ); $self->_add_requirements_to_meta(\%meta); if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) { return \%meta; } # needs to be based on the original version my $v1_add = _metaspec_version($meta_add) !~ /^2/; my ($add_v, $merge_v) = map _metaspec_version($_), $meta_add, $meta_merge; for my $frag ($meta_add, $meta_merge) { my $def_v = $frag == $meta_add ? $merge_v : $add_v; $frag = CPAN::Meta::Converter->new($frag, default_version => $def_v)->upgrade_fragment; } # if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that # will override all prereqs, which is more than the user asked for; # instead, we'll go inside the prereqs and override all those while( my($key, $val) = each %$meta_add ) { if ($v1_add and $key eq 'prereqs') { $meta{$key}{$_} = $val->{$_} for keys %$val; } elsif ($key ne 'meta-spec') { $meta{$key} = $val; } } while( my($key, $val) = each %$meta_merge ) { next if $key eq 'meta-spec'; $self->_hash_merge(\%meta, $key, $val); } return \%meta; } =begin private =cut sub _add_requirements_to_meta { my ( $self, $meta ) = @_; # Check the original args so we can tell between the user setting it # to an empty hash and it just being initialized. $meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES} ? $self->{CONFIGURE_REQUIRES} : { 'ExtUtils::MakeMaker' => 0, }; $meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES} ? $self->{BUILD_REQUIRES} : { 'ExtUtils::MakeMaker' => 0, }; $meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES} if $self->{ARGS}{TEST_REQUIRES}; $meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM} if $self->{ARGS}{PREREQ_PM}; $meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) if $self->{MIN_PERL_VERSION}; } # spec version of given fragment - if not given, assume 1.4 sub _metaspec_version { my ( $meta ) = @_; return $meta->{'meta-spec'}->{version} if defined $meta->{'meta-spec'} and defined $meta->{'meta-spec'}->{version}; return '1.4'; } sub _add_requirements_to_meta_v1_4 { my ( $self, $meta ) = @_; # Check the original args so we can tell between the user setting it # to an empty hash and it just being initialized. if( $self->{ARGS}{CONFIGURE_REQUIRES} ) { $meta->{configure_requires} = $self->{CONFIGURE_REQUIRES}; } else { $meta->{configure_requires} = { 'ExtUtils::MakeMaker' => 0, }; } if( $self->{ARGS}{BUILD_REQUIRES} ) { $meta->{build_requires} = $self->{BUILD_REQUIRES}; } else { $meta->{build_requires} = { 'ExtUtils::MakeMaker' => 0, }; } if( $self->{ARGS}{TEST_REQUIRES} ) { $meta->{build_requires} = { %{ $meta->{build_requires} }, %{ $self->{TEST_REQUIRES} }, }; } $meta->{requires} = $self->{PREREQ_PM} if defined $self->{PREREQ_PM}; $meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) if $self->{MIN_PERL_VERSION}; } # Adapted from Module::Build::Base sub _normalize_version { my ($version) = @_; $version = 0 unless defined $version; if ( ref $version eq 'version' ) { # version objects $version = $version->stringify; } elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots # normalize string tuples without "v": "1.2.3" -> "v1.2.3" $version = "v$version"; } else { # leave alone } return $version; } =head3 _dump_hash $yaml = _dump_hash(\%options, %hash); Implements a fake YAML dumper for a hash given as a list of pairs. No quoting/escaping is done. Keys are supposed to be strings. Values are undef, strings, hash refs or array refs of strings. Supported options are: delta => STR - indentation delta use_header => BOOL - whether to include a YAML header indent => STR - a string of spaces default: '' max_key_length => INT - maximum key length used to align keys and values of the same hash default: 20 key_sort => CODE - a sort sub It may be undef, which means no sorting by keys default: sub { lc $a cmp lc $b } customs => HASH - special options for certain keys (whose values are hashes themselves) may contain: max_key_length, key_sort, customs =end private =cut sub _dump_hash { croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH'; my $options = shift; my %hash = @_; # Use a list to preserve order. my @pairs; my $k_sort = exists $options->{key_sort} ? $options->{key_sort} : sub { lc $a cmp lc $b }; if ($k_sort) { croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE'; @pairs = _sort_pairs($k_sort, \%hash); } else { # list of pairs, no sorting @pairs = @_; } my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : ''; my $indent = $options->{indent} || ''; my $k_length = min( ($options->{max_key_length} || 20), max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash) ); my $customs = $options->{customs} || {}; # printf format for key my $k_format = "%-${k_length}s"; while( @pairs ) { my($key, $val) = splice @pairs, 0, 2; $val = '~' unless defined $val; if(ref $val eq 'HASH') { if ( keys %$val ) { my %k_options = ( # options for recursive call delta => $options->{delta}, use_header => 0, indent => $indent . $options->{delta}, ); if (exists $customs->{$key}) { my %k_custom = %{$customs->{$key}}; foreach my $k (qw(key_sort max_key_length customs)) { $k_options{$k} = $k_custom{$k} if exists $k_custom{$k}; } } $yaml .= $indent . "$key:\n" . _dump_hash(\%k_options, %$val); } else { $yaml .= $indent . "$key: {}\n"; } } elsif (ref $val eq 'ARRAY') { if( @$val ) { $yaml .= $indent . "$key:\n"; for (@$val) { croak "only nested arrays of non-refs are supported" if ref $_; $yaml .= $indent . $options->{delta} . "- $_\n"; } } else { $yaml .= $indent . "$key: []\n"; } } elsif( ref $val and !blessed($val) ) { croak "only nested hashes, arrays and objects are supported"; } else { # if it's an object, just stringify it $yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val; } }; return $yaml; } sub blessed { return eval { $_[0]->isa("UNIVERSAL"); }; } sub max { return (sort { $b <=> $a } @_)[0]; } sub min { return (sort { $a <=> $b } @_)[0]; } =head3 metafile_file my $meta_yml = $mm->metafile_file(@metadata_pairs); Turns the @metadata_pairs into YAML. This method does not implement a complete YAML dumper, being limited to dump a hash with values which are strings, undef's or nested hashes and arrays of strings. No quoting/escaping is done. =cut sub metafile_file { my $self = shift; my %dump_options = ( use_header => 1, delta => ' ' x 4, key_sort => undef, ); return _dump_hash(\%dump_options, @_); } =head3 distmeta_target my $make_frag = $mm->distmeta_target; Generates the distmeta target to add META.yml and META.json to the MANIFEST in the distdir. =cut sub distmeta_target { my $self = shift; my @add_meta = ( $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']), exit unless -e q{META.yml}; eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) } or die "Could not add META.yml to MANIFEST: ${'@'}" CODE $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']) exit unless -f q{META.json}; eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) } or die "Could not add META.json to MANIFEST: ${'@'}" CODE ); my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta; return sprintf <<'MAKE', @add_meta_to_distdir; distmeta : create_distdir metafile $(NOECHO) %s $(NOECHO) %s MAKE } =head3 mymeta my $mymeta = $mm->mymeta; Generate MYMETA information as a hash either from an existing CPAN Meta file (META.json or META.yml) or from internal data. =cut sub mymeta { my $self = shift; my $file = shift || ''; # for testing my $mymeta = $self->_mymeta_from_meta($file); my $v2 = 1; unless ( $mymeta ) { $mymeta = $self->metafile_data( $self->{META_ADD} || {}, $self->{META_MERGE} || {}, ); $v2 = 0; } # Overwrite the non-configure dependency hashes $self->_add_requirements_to_meta($mymeta); $mymeta->{dynamic_config} = 0; return $mymeta; } sub _mymeta_from_meta { my $self = shift; my $metafile = shift || ''; # for testing return unless _has_cpan_meta(); my $meta; for my $file ( $metafile, "META.json", "META.yml" ) { next unless -e $file; eval { $meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } ); }; last if $meta; } return unless $meta; # META.yml before 6.25_01 cannot be trusted. META.yml lived in the source directory. # There was a good chance the author accidentally uploaded a stale META.yml if they # rolled their own tarball rather than using "make dist". if ($meta->{generated_by} && $meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { my $eummv = do { no warnings; $1+0; }; if ($eummv < 6.2501) { return; } } return $meta; } =head3 write_mymeta $self->write_mymeta( $mymeta ); Write MYMETA information to MYMETA.json and MYMETA.yml. =cut sub write_mymeta { my $self = shift; my $mymeta = shift; return unless _has_cpan_meta(); my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta ); $meta_obj->save( 'MYMETA.json', { version => "2.0" } ); $meta_obj->save( 'MYMETA.yml', { version => "1.4" } ); return 1; } =head3 realclean (o) Defines the realclean target. =cut sub realclean { my($self, %attribs) = @_; my @dirs = qw($(DISTVNAME)); my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD)); # Special exception for the perl core where INST_* is not in blib. # This cleans up the files built from the ext/ directory (all XS). if( $self->{PERL_CORE} ) { push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR)); push @files, values %{$self->{PM}}; } if( $self->has_link_code ){ push @files, qw($(OBJECT)); } if( $attribs{FILES} ) { if( ref $attribs{FILES} ) { push @dirs, @{ $attribs{FILES} }; } else { push @dirs, split /\s+/, $attribs{FILES}; } } # Occasionally files are repeated several times from different sources { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; } { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; } my $rm_cmd = join "\n\t", map { "$_" } $self->split_command('- $(RM_F)', @files); my $rmf_cmd = join "\n\t", map { "$_" } $self->split_command('- $(RM_RF)', @dirs); my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd; # Delete temporary files (via clean) and also delete dist files realclean purge :: realclean_subdirs %s %s MAKE $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP}; return $m; } =head3 realclean_subdirs_target my $make_frag = $MM->realclean_subdirs_target; Returns the realclean_subdirs target. This is used by the realclean target to call realclean on any subdirectories which contain Makefiles. =cut sub realclean_subdirs_target { my $self = shift; my @m = <<'EOF'; # so clean is forced to complete before realclean_subdirs runs realclean_subdirs : clean EOF return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}}; foreach my $dir (@{$self->{DIR}}) { foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) { my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile); chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s'; CODE push @m, "\t- $subrclean\n"; } } return join '', @m; } =head3 signature_target my $target = $mm->signature_target; Generate the signature target. Writes the file SIGNATURE with "cpansign -s". =cut sub signature_target { my $self = shift; return <<'MAKE_FRAG'; signature : cpansign -s MAKE_FRAG } =head3 distsignature_target my $make_frag = $mm->distsignature_target; Generates the distsignature target to add SIGNATURE to the MANIFEST in the distdir. =cut sub distsignature_target { my $self = shift; my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']); eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } or die "Could not add SIGNATURE to MANIFEST: ${'@'}" CODE my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s'); # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not # exist my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE'); my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign ); return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist distsignature : distmeta $(NOECHO) %s $(NOECHO) %s %s MAKE } =head3 special_targets my $make_frag = $mm->special_targets Returns a make fragment containing any targets which have special meaning to make. For example, .SUFFIXES and .PHONY. =cut sub special_targets { my $make_frag = <<'MAKE_FRAG'; .SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) .PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static MAKE_FRAG $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT}; .NO_CONFIG_REC: Makefile MAKE_FRAG return $make_frag; } =head2 Init methods Methods which help initialize the MakeMaker object and macros. =head3 init_ABSTRACT $mm->init_ABSTRACT =cut sub init_ABSTRACT { my $self = shift; if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) { warn "Both ABSTRACT_FROM and ABSTRACT are set. ". "Ignoring ABSTRACT_FROM.\n"; return; } if ($self->{ABSTRACT_FROM}){ $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or carp "WARNING: Setting ABSTRACT via file ". "'$self->{ABSTRACT_FROM}' failed\n"; } if ($self->{ABSTRACT} && $self->{ABSTRACT} =~ m![[:cntrl:]]+!) { warn "WARNING: ABSTRACT contains control character(s),". " they will be removed\n"; $self->{ABSTRACT} =~ s![[:cntrl:]]+!!g; return; } } =head3 init_INST $mm->init_INST; Called by init_main. Sets up all INST_* variables except those related to XS code. Those are handled in init_xs. =cut sub init_INST { my($self) = shift; $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch"); $self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin'); # INST_LIB typically pre-set if building an extension after # perl has been built and installed. Setting INST_LIB allows # you to build directly into, say $Config{privlibexp}. unless ($self->{INST_LIB}){ if ($self->{PERL_CORE}) { $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB}; } else { $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib"); } } my @parentdir = split(/::/, $self->{PARENT_NAME}); $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir); $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir); $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto', '$(FULLEXT)'); $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto', '$(FULLEXT)'); $self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script'); $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1'); $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3'); return 1; } =head3 init_INSTALL $mm->init_INSTALL; Called by init_main. Sets up all INSTALL_* variables (except INSTALLDIRS) and *PREFIX. =cut sub init_INSTALL { my($self) = shift; if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) { die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n"; } if( $self->{ARGS}{INSTALL_BASE} ) { $self->init_INSTALL_from_INSTALL_BASE; } else { $self->init_INSTALL_from_PREFIX; } } =head3 init_INSTALL_from_PREFIX $mm->init_INSTALL_from_PREFIX; =cut sub init_INSTALL_from_PREFIX { my $self = shift; $self->init_lib2arch; # There are often no Config.pm defaults for these new man variables so # we fall back to the old behavior which is to use installman*dir foreach my $num (1, 3) { my $k = 'installsiteman'.$num.'dir'; $self->{uc $k} ||= uc "\$(installman${num}dir)" unless $Config{$k}; } foreach my $num (1, 3) { my $k = 'installvendorman'.$num.'dir'; unless( $Config{$k} ) { $self->{uc $k} ||= $Config{usevendorprefix} ? uc "\$(installman${num}dir)" : ''; } } $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)' unless $Config{installsitebin}; $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)' unless $Config{installsitescript}; unless( $Config{installvendorbin} ) { $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix} ? $Config{installbin} : ''; } unless( $Config{installvendorscript} ) { $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix} ? $Config{installscript} : ''; } my $iprefix = $Config{installprefixexp} || $Config{installprefix} || $Config{prefixexp} || $Config{prefix} || ''; my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : ''; my $sprefix = $Config{siteprefixexp} || ''; # 5.005_03 doesn't have a siteprefix. $sprefix = $iprefix unless $sprefix; $self->{PREFIX} ||= ''; if( $self->{PREFIX} ) { @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} = ('$(PREFIX)') x 3; } else { $self->{PERLPREFIX} ||= $iprefix; $self->{SITEPREFIX} ||= $sprefix; $self->{VENDORPREFIX} ||= $vprefix; # Lots of MM extension authors like to use $(PREFIX) so we # put something sensible in there no matter what. $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)'; } my $arch = $Config{archname}; my $version = $Config{version}; # default style my $libstyle = $Config{installstyle} || 'lib/perl5'; my $manstyle = ''; if( $self->{LIBSTYLE} ) { $libstyle = $self->{LIBSTYLE}; $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : ''; } # Some systems, like VOS, set installman*dir to '' if they can't # read man pages. for my $num (1, 3) { $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none' unless $Config{'installman'.$num.'dir'}; } my %bin_layouts = ( bin => { s => $iprefix, t => 'perl', d => 'bin' }, vendorbin => { s => $vprefix, t => 'vendor', d => 'bin' }, sitebin => { s => $sprefix, t => 'site', d => 'bin' }, script => { s => $iprefix, t => 'perl', d => 'bin' }, vendorscript=> { s => $vprefix, t => 'vendor', d => 'bin' }, sitescript => { s => $sprefix, t => 'site', d => 'bin' }, ); my %man_layouts = ( man1dir => { s => $iprefix, t => 'perl', d => 'man/man1', style => $manstyle, }, siteman1dir => { s => $sprefix, t => 'site', d => 'man/man1', style => $manstyle, }, vendorman1dir => { s => $vprefix, t => 'vendor', d => 'man/man1', style => $manstyle, }, man3dir => { s => $iprefix, t => 'perl', d => 'man/man3', style => $manstyle, }, siteman3dir => { s => $sprefix, t => 'site', d => 'man/man3', style => $manstyle, }, vendorman3dir => { s => $vprefix, t => 'vendor', d => 'man/man3', style => $manstyle, }, ); my %lib_layouts = ( privlib => { s => $iprefix, t => 'perl', d => '', style => $libstyle, }, vendorlib => { s => $vprefix, t => 'vendor', d => '', style => $libstyle, }, sitelib => { s => $sprefix, t => 'site', d => 'site_perl', style => $libstyle, }, archlib => { s => $iprefix, t => 'perl', d => "$version/$arch", style => $libstyle }, vendorarch => { s => $vprefix, t => 'vendor', d => "$version/$arch", style => $libstyle }, sitearch => { s => $sprefix, t => 'site', d => "site_perl/$version/$arch", style => $libstyle }, ); # Special case for LIB. if( $self->{LIB} ) { foreach my $var (keys %lib_layouts) { my $Installvar = uc "install$var"; if( $var =~ /arch/ ) { $self->{$Installvar} ||= $self->catdir($self->{LIB}, $Config{archname}); } else { $self->{$Installvar} ||= $self->{LIB}; } } } my %type2prefix = ( perl => 'PERLPREFIX', site => 'SITEPREFIX', vendor => 'VENDORPREFIX' ); my %layouts = (%bin_layouts, %man_layouts, %lib_layouts); while( my($var, $layout) = each(%layouts) ) { my($s, $t, $d, $style) = @{$layout}{qw(s t d style)}; my $r = '$('.$type2prefix{$t}.')'; warn "Prefixing $var\n" if $Verbose >= 2; my $installvar = "install$var"; my $Installvar = uc $installvar; next if $self->{$Installvar}; $d = "$style/$d" if $style; $self->prefixify($installvar, $s, $r, $d); warn " $Installvar == $self->{$Installvar}\n" if $Verbose >= 2; } # Generate these if they weren't figured out. $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH}; $self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB}; return 1; } =head3 init_from_INSTALL_BASE $mm->init_from_INSTALL_BASE =cut my %map = ( lib => [qw(lib perl5)], arch => [('lib', 'perl5', $Config{archname})], bin => [qw(bin)], man1dir => [qw(man man1)], man3dir => [qw(man man3)] ); $map{script} = $map{bin}; sub init_INSTALL_from_INSTALL_BASE { my $self = shift; @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} = '$(INSTALL_BASE)'; my %install; foreach my $thing (keys %map) { foreach my $dir (('', 'SITE', 'VENDOR')) { my $uc_thing = uc $thing; my $key = "INSTALL".$dir.$uc_thing; $install{$key} ||= ($thing =~ /^man.dir$/ and not $Config{lc $key}) ? 'none' : $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); } } # Adjust for variable quirks. $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH}; $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB}; foreach my $key (keys %install) { $self->{$key} ||= $install{$key}; } return 1; } =head3 init_VERSION I<Abstract> $mm->init_VERSION Initialize macros representing versions of MakeMaker and other tools MAKEMAKER: path to the MakeMaker module. MM_VERSION: ExtUtils::MakeMaker Version MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards compat) VERSION: version of your module VERSION_MACRO: which macro represents the version (usually 'VERSION') VERSION_SYM: like version but safe for use as an RCS revision number DEFINE_VERSION: -D line to set the module version when compiling XS_VERSION: version in your .xs file. Defaults to $(VERSION) XS_VERSION_MACRO: which macro represents the XS version. XS_DEFINE_VERSION: -D line to set the xs version when compiling. Called by init_main. =cut sub init_VERSION { my($self) = shift; $self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename; $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION; $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision; $self->{VERSION_FROM} ||= ''; if ($self->{VERSION_FROM}){ $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}); if( $self->{VERSION} eq 'undef' ) { carp("WARNING: Setting VERSION via file ". "'$self->{VERSION_FROM}' failed\n"); } } if (defined $self->{VERSION}) { if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) { require version; my $normal = eval { version->new( $self->{VERSION} ) }; $self->{VERSION} = $normal if defined $normal; } $self->{VERSION} =~ s/^\s+//; $self->{VERSION} =~ s/\s+$//; } else { $self->{VERSION} = ''; } $self->{VERSION_MACRO} = 'VERSION'; ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g; $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"'; # Graham Barr and Paul Marquess had some ideas how to ensure # version compatibility between the *.pm file and the # corresponding *.xs file. The bottom line was, that we need an # XS_VERSION macro that defaults to VERSION: $self->{XS_VERSION} ||= $self->{VERSION}; $self->{XS_VERSION_MACRO} = 'XS_VERSION'; $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"'; } =head3 init_tools $MM->init_tools(); Initializes the simple macro definitions used by tools_other() and places them in the $MM object. These use conservative cross platform versions and should be overridden with platform specific versions for performance. Defines at least these macros. Macro Description NOOP Do nothing NOECHO Tell make not to display the command itself SHELL Program used to run shell commands ECHO Print text adding a newline on the end RM_F Remove a file RM_RF Remove a directory TOUCH Update a file's timestamp TEST_F Test for a file's existence TEST_S Test the size of a file CP Copy a file CP_NONEMPTY Copy a file if it is not empty MV Move a file CHMOD Change permissions on a file FALSE Exit with non-zero TRUE Exit with zero UMASK_NULL Nullify umask DEV_NULL Suppress all command output =cut sub init_tools { my $self = shift; $self->{ECHO} ||= $self->oneliner('binmode STDOUT, qq{:raw}; print qq{@ARGV}', ['-l']); $self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}'); $self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]); $self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]); $self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]); $self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]); $self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]); $self->{TEST_S} ||= $self->oneliner('test_s', ["-MExtUtils::Command::MM"]); $self->{CP_NONEMPTY} ||= $self->oneliner('cp_nonempty', ["-MExtUtils::Command::MM"]); $self->{FALSE} ||= $self->oneliner('exit 1'); $self->{TRUE} ||= $self->oneliner('exit 0'); $self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]); $self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]); $self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]); $self->{MOD_INSTALL} ||= $self->oneliner(<<'CODE', ['-MExtUtils::Install']); install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); CODE $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]); $self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]); $self->{WARN_IF_OLD_PACKLIST} ||= $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]); $self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]); $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]); $self->{UNINST} ||= 0; $self->{VERBINST} ||= 0; $self->{SHELL} ||= $Config{sh}; # UMASK_NULL is not used by MakeMaker but some CPAN modules # make use of it. $self->{UMASK_NULL} ||= "umask 0"; # Not the greatest default, but its something. $self->{DEV_NULL} ||= "> /dev/null 2>&1"; $self->{NOOP} ||= '$(TRUE)'; $self->{NOECHO} = '@' unless defined $self->{NOECHO}; $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile'; $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old'; $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl'; # Not everybody uses -f to indicate "use this Makefile instead" $self->{USEMAKEFILE} ||= '-f'; # Some makes require a wrapper around macros passed in on the command # line. $self->{MACROSTART} ||= ''; $self->{MACROEND} ||= ''; return; } =head3 init_others $MM->init_others(); Initializes the macro definitions having to do with compiling and linking used by tools_other() and places them in the $MM object. If there is no description, its the same as the parameter to WriteMakefile() documented in L<ExtUtils::MakeMaker>. =cut sub init_others { my $self = shift; $self->{LD_RUN_PATH} = ""; $self->{LIBS} = $self->_fix_libs($self->{LIBS}); # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS} foreach my $libs ( @{$self->{LIBS}} ){ $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace my(@libs) = $self->extliblist($libs); if ($libs[0] or $libs[1] or $libs[2]){ # LD_RUN_PATH now computed by ExtUtils::Liblist ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs; last; } } if ( $self->{OBJECT} ) { $self->{OBJECT} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT}; $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; } elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) { $self->{OBJECT} = join(" ", @{$self->{O_FILES}}); $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; } else { # init_dirscan should have found out, if we have C files $self->{OBJECT} = ""; $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]}; } $self->{OBJECT} =~ s/\n+/ \\\n\t/g; $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : ""; $self->{PERLMAINCC} ||= '$(CC)'; $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM}; # Sanity check: don't define LINKTYPE = dynamic if we're skipping # the 'dynamic' section of MM. We don't have this problem with # 'static', since we either must use it (%Config says we can't # use dynamic loading) or the caller asked for it explicitly. if (!$self->{LINKTYPE}) { $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'} ? 'static' : ($Config{usedl} ? 'dynamic' : 'static'); } return; } # Lets look at $self->{LIBS} carefully: It may be an anon array, a string or # undefined. In any case we turn it into an anon array sub _fix_libs { my($self, $libs) = @_; return !defined $libs ? [''] : !ref $libs ? [$libs] : !defined $libs->[0] ? [''] : $libs ; } =head3 tools_other my $make_frag = $MM->tools_other; Returns a make fragment containing definitions for the macros init_others() initializes. =cut sub tools_other { my($self) = shift; my @m; # We set PM_FILTER as late as possible so it can see all the earlier # on macro-order sensitive makes such as nmake. for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP FALSE TRUE ECHO ECHO_N UNINST VERBINST MOD_INSTALL DOC_INSTALL UNINSTALL WARN_IF_OLD_PACKLIST MACROSTART MACROEND USEMAKEFILE PM_FILTER FIXIN CP_NONEMPTY } ) { next unless defined $self->{$tool}; push @m, "$tool = $self->{$tool}\n"; } return join "", @m; } =head3 init_DIRFILESEP I<Abstract> $MM->init_DIRFILESEP; my $dirfilesep = $MM->{DIRFILESEP}; Initializes the DIRFILESEP macro which is the separator between the directory and filename in a filepath. ie. / on Unix, \ on Win32 and nothing on VMS. For example: # instead of $(INST_ARCHAUTODIR)/extralibs.ld $(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld Something of a hack but it prevents a lot of code duplication between MM_* variants. Do not use this as a separator between directories. Some operating systems use different separators between subdirectories as between directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS). =head3 init_linker I<Abstract> $mm->init_linker; Initialize macros which have to do with linking. PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic extensions. PERL_ARCHIVE_AFTER: path to a library which should be put on the linker command line I<after> the external libraries to be linked to dynamic extensions. This may be needed if the linker is one-pass, and Perl includes some overrides for C RTL functions, such as malloc(). EXPORT_LIST: name of a file that is passed to linker to define symbols to be exported. Some OSes do not need these in which case leave it blank. =head3 init_platform $mm->init_platform Initialize any macros which are for platform specific use only. A typical one is the version number of your OS specific module. (ie. MM_Unix_VERSION or MM_VMS_VERSION). =cut sub init_platform { return ''; } =head3 init_MAKE $mm->init_MAKE Initialize MAKE from either a MAKE environment variable or $Config{make}. =cut sub init_MAKE { my $self = shift; $self->{MAKE} ||= $ENV{MAKE} || $Config{make}; } =head2 Tools A grab bag of methods to generate specific macros and commands. =head3 manifypods Defines targets and routines to translate the pods into manpages and put them into the INST_* directories. =cut sub manifypods { my $self = shift; my $POD2MAN_macro = $self->POD2MAN_macro(); my $manifypods_target = $self->manifypods_target(); return <<END_OF_TARGET; $POD2MAN_macro $manifypods_target END_OF_TARGET } =head3 POD2MAN_macro my $pod2man_macro = $self->POD2MAN_macro Returns a definition for the POD2MAN macro. This is a program which emulates the pod2man utility. You can add more switches to the command by simply appending them on the macro. Typical usage: $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ... =cut sub POD2MAN_macro { my $self = shift; # Need the trailing '--' so perl stops gobbling arguments and - happens # to be an alternative end of line separator on VMS so we quote it return <<'END_OF_DEF'; POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--" POD2MAN = $(POD2MAN_EXE) END_OF_DEF } =head3 test_via_harness my $command = $mm->test_via_harness($perl, $tests); Returns a $command line which runs the given set of $tests with Test::Harness and the given $perl. Used on the t/*.t files. =cut sub test_via_harness { my($self, $perl, $tests) = @_; return qq{\t$perl "-MExtUtils::Command::MM" "-MTest::Harness" }. qq{"-e" "undef *Test::Harness::Switches; test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; } =head3 test_via_script my $command = $mm->test_via_script($perl, $script); Returns a $command line which just runs a single test without Test::Harness. No checks are done on the results, they're just printed. Used for test.pl, since they don't always follow Test::Harness formatting. =cut sub test_via_script { my($self, $perl, $script) = @_; return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n}; } =head3 tool_autosplit Defines a simple perl call that runs autosplit. May be deprecated by pm_to_blib soon. =cut sub tool_autosplit { my($self, %attribs) = @_; my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};' : ''; my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen); use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) PERL_CODE return sprintf <<'MAKE_FRAG', $asplit; # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto AUTOSPLITFILE = %s MAKE_FRAG } =head3 arch_check my $arch_ok = $mm->arch_check( $INC{"Config.pm"}, File::Spec->catfile($Config{archlibexp}, "Config.pm") ); A sanity check that what Perl thinks the architecture is and what Config thinks the architecture is are the same. If they're not it will return false and show a diagnostic message. When building Perl it will always return true, as nothing is installed yet. The interface is a bit odd because this is the result of a quick refactoring. Don't rely on it. =cut sub arch_check { my $self = shift; my($pconfig, $cconfig) = @_; return 1 if $self->{PERL_SRC}; my($pvol, $pthinks) = $self->splitpath($pconfig); my($cvol, $cthinks) = $self->splitpath($cconfig); $pthinks = $self->canonpath($pthinks); $cthinks = $self->canonpath($cthinks); my $ret = 1; if ($pthinks ne $cthinks) { print "Have $pthinks\n"; print "Want $cthinks\n"; $ret = 0; my $arch = (grep length, $self->splitdir($pthinks))[-1]; print <<END unless $self->{UNINSTALLED_PERL}; Your perl and your Config.pm seem to have different ideas about the architecture they are running on. Perl thinks: [$arch] Config says: [$Config{archname}] This may or may not cause problems. Please check your installation of perl if you have problems building this extension. END } return $ret; } =head2 File::Spec wrappers ExtUtils::MM_Any is a subclass of L<File::Spec>. The methods noted here override File::Spec. =head3 catfile File::Spec <= 0.83 has a bug where the file part of catfile is not canonicalized. This override fixes that bug. =cut sub catfile { my $self = shift; return $self->canonpath($self->SUPER::catfile(@_)); } =head2 Misc Methods I can't really figure out where they should go yet. =head3 find_tests my $test = $mm->find_tests; Returns a string suitable for feeding to the shell to return all tests in t/*.t. =cut sub find_tests { my($self) = shift; return -d 't' ? 't/*.t' : ''; } =head3 find_tests_recursive my $tests = $mm->find_tests_recursive; Returns a string suitable for feeding to the shell to return all tests in t/ but recursively. Equivalent to my $tests = $mm->find_tests_recursive_in('t'); =cut sub find_tests_recursive { my $self = shift; return $self->find_tests_recursive_in('t'); } =head3 find_tests_recursive_in my $tests = $mm->find_tests_recursive_in($dir); Returns a string suitable for feeding to the shell to return all tests in $dir recursively. =cut sub find_tests_recursive_in { my($self, $dir) = @_; return '' unless -d $dir; require File::Find; my $base_depth = grep { $_ ne '' } File::Spec->splitdir( (File::Spec->splitpath($dir))[1] ); my %depths; my $wanted = sub { return unless m!\.t$!; my ($volume,$directories,$file) = File::Spec->splitpath( $File::Find::name ); my $depth = grep { $_ ne '' } File::Spec->splitdir( $directories ); $depth -= $base_depth; $depths{ $depth } = 1; }; File::Find::find( $wanted, $dir ); return join ' ', map { $dir . '/*' x $_ . '.t' } sort { $a <=> $b } keys %depths; } =head3 extra_clean_files my @files_to_clean = $MM->extra_clean_files; Returns a list of OS specific files to be removed in the clean target in addition to the usual set. =cut # An empty method here tickled a perl 5.8.1 bug and would return its object. sub extra_clean_files { return; } =head3 installvars my @installvars = $mm->installvars; A list of all the INSTALL* variables without the INSTALL prefix. Useful for iteration or building related variable sets. =cut sub installvars { return qw(PRIVLIB SITELIB VENDORLIB ARCHLIB SITEARCH VENDORARCH BIN SITEBIN VENDORBIN SCRIPT SITESCRIPT VENDORSCRIPT MAN1DIR SITEMAN1DIR VENDORMAN1DIR MAN3DIR SITEMAN3DIR VENDORMAN3DIR ); } =head3 libscan my $wanted = $self->libscan($path); Takes a path to a file or dir and returns an empty string if we don't want to include this file in the library. Otherwise it returns the the $path unchanged. Mainly used to exclude version control administrative directories and base-level F<README.pod> from installation. =cut sub libscan { my($self,$path) = @_; if ($path =~ m<^README\.pod$>i) { warn "WARNING: Older versions of ExtUtils::MakeMaker may errantly install $path as part of this distribution. It is recommended to avoid using this path in CPAN modules.\n"; return ''; } my($dirs,$file) = ($self->splitpath($path))[1,2]; return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/, $self->splitdir($dirs), $file; return $path; } =head3 platform_constants my $make_frag = $mm->platform_constants Returns a make fragment defining all the macros initialized in init_platform() rather than put them in constants(). =cut sub platform_constants { return ''; } =head3 post_constants (o) Returns an empty string per default. Dedicated to overrides from within Makefile.PL after all constants have been defined. =cut sub post_constants { ""; } =head3 post_initialize (o) Returns an empty string per default. Used in Makefile.PLs to add some chunk of text to the Makefile after the object is initialized. =cut sub post_initialize { ""; } =head3 postamble (o) Returns an empty string. Can be used in Makefile.PLs to write some text to the Makefile at the end. =cut sub postamble { ""; } =begin private =head3 _PREREQ_PRINT $self->_PREREQ_PRINT; Implements PREREQ_PRINT. Refactored out of MakeMaker->new(). =end private =cut sub _PREREQ_PRINT { my $self = shift; require Data::Dumper; my @what = ('PREREQ_PM'); push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION}; push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES}; print Data::Dumper->Dump([@{$self}{@what}], \@what); exit 0; } =begin private =head3 _PRINT_PREREQ $mm->_PRINT_PREREQ; Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT added by Redhat to, I think, support generating RPMs from Perl modules. Should not include BUILD_REQUIRES as RPMs do not include them. Refactored out of MakeMaker->new(). =end private =cut sub _PRINT_PREREQ { my $self = shift; my $prereqs= $self->{PREREQ_PM}; my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs; if ( $self->{MIN_PERL_VERSION} ) { push @prereq, ['perl' => $self->{MIN_PERL_VERSION}]; } print join(" ", map { "perl($_->[0])>=$_->[1] " } sort { $a->[0] cmp $b->[0] } @prereq), "\n"; exit 0; } =begin private =head3 _perl_header_files my $perl_header_files= $self->_perl_header_files; returns a sorted list of header files as found in PERL_SRC or $archlibexp/CORE. Used by perldepend() in MM_Unix and MM_VMS via _perl_header_files_fragment() =end private =cut sub _perl_header_files { my $self = shift; my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE'); opendir my $dh, $header_dir or die "Failed to opendir '$header_dir' to find header files: $!"; # we need to use a temporary here as the sort in scalar context would have undefined results. my @perl_headers= sort grep { /\.h\z/ } readdir($dh); closedir $dh; return @perl_headers; } =begin private =head3 _perl_header_files_fragment ($o, $separator) my $perl_header_files_fragment= $self->_perl_header_files_fragment("/"); return a Makefile fragment which holds the list of perl header files which XS code depends on $(PERL_INC), and sets up the dependency for the $(OBJECT) file. The $separator argument defaults to "". MM_VMS will set it to "" and MM_UNIX to "/" in perldepend(). This reason child subclasses need to control this is that in VMS the $(PERL_INC) directory will already have delimiters in it, but in UNIX $(PERL_INC) will need a slash between it an the filename. Hypothetically win32 could use "\\" (but it doesn't need to). =end private =cut sub _perl_header_files_fragment { my ($self, $separator)= @_; $separator ||= ""; return join("\\\n", "PERL_HDRS = ", map { sprintf( " \$(PERL_INCDEP)%s%s ", $separator, $_ ) } $self->_perl_header_files() ) . "\n\n" . "\$(OBJECT) : \$(PERL_HDRS)\n"; } =head1 AUTHOR Michael G Schwern <schwern@pobox.com> and the denizens of makemaker@perl.org with code from ExtUtils::MM_Unix and ExtUtils::MM_Win32. =cut 1; perl5/ExtUtils/MakeMaker.pm 0000444 00000325430 14711220042 0011545 0 ustar 00 # $Id$ package ExtUtils::MakeMaker; use strict; use warnings; BEGIN {require 5.006;} require Exporter; use ExtUtils::MakeMaker::Config; use ExtUtils::MakeMaker::version; # ensure we always have our fake version.pm use Carp; use File::Path; my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') } if $CAN_DECODE and Encode::find_encoding('locale')->name eq 'ascii'; our $Verbose = 0; # exported our @Parent; # needs to be localized our @Get_from_Config; # referenced by MM_Unix our @MM_Sections; our @Overridable; my @Prepend_parent; my %Recognized_Att_Keys; our %macro_fsentity; # whether a macro is a filesystem name our %macro_dep; # whether a macro is a dependency our $VERSION = '7.62'; $VERSION =~ tr/_//d; # Emulate something resembling CVS $Revision$ (our $Revision = $VERSION) =~ s{_}{}; $Revision = int $Revision * 10000; our $Filename = __FILE__; # referenced outside MakeMaker our @ISA = qw(Exporter); our @EXPORT = qw(&WriteMakefile $Verbose &prompt &os_unsupported); our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists &WriteEmptyMakefile &open_for_writing &write_file_via_tmp &_sprintf562); # These will go away once the last of the Win32 & VMS specific code is # purged. my $Is_VMS = $^O eq 'VMS'; my $Is_Win32 = $^O eq 'MSWin32'; our $UNDER_CORE = $ENV{PERL_CORE}; # needs to be our full_setup(); require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker # will give them MM. require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect # loading ExtUtils::MakeMaker will give them MY. # This will go when Embed is its own CPAN module. # 5.6.2 can't do sprintf "%1$s" - this can only do %s sub _sprintf562 { my ($format, @args) = @_; for (my $i = 1; $i <= @args; $i++) { $format =~ s#%$i\$s#$args[$i-1]#g; } $format; } sub WriteMakefile { croak "WriteMakefile: Need even number of args" if @_ % 2; require ExtUtils::MY; my %att = @_; _convert_compat_attrs(\%att); _verify_att(\%att); my $mm = MM->new(\%att); $mm->flush; return $mm; } # Basic signatures of the attributes WriteMakefile takes. Each is the # reference type. Empty value indicate it takes a non-reference # scalar. my %Att_Sigs; my %Special_Sigs = ( AUTHOR => 'ARRAY', C => 'ARRAY', CONFIG => 'ARRAY', CONFIGURE => 'CODE', DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => ['ARRAY',''], MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', OBJECT => ['ARRAY', ''], PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', BUILD_REQUIRES => 'HASH', CONFIGURE_REQUIRES => 'HASH', TEST_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', XSBUILD => 'HASH', VERSION => ['version',''], _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', ); @Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys; @Att_Sigs{keys %Special_Sigs} = values %Special_Sigs; sub _convert_compat_attrs { #result of running several times should be same my($att) = @_; if (exists $att->{AUTHOR}) { if ($att->{AUTHOR}) { if (!ref($att->{AUTHOR})) { my $t = $att->{AUTHOR}; $att->{AUTHOR} = [$t]; } } else { $att->{AUTHOR} = []; } } } sub _verify_att { my($att) = @_; foreach my $key (sort keys %$att) { my $val = $att->{$key}; my $sig = $Att_Sigs{$key}; unless( defined $sig ) { warn "WARNING: $key is not a known parameter.\n"; next; } my @sigs = ref $sig ? @$sig : $sig; my $given = ref $val; unless( grep { _is_of_type($val, $_) } @sigs ) { my $takes = join " or ", map { _format_att($_) } @sigs; my $has = _format_att($given); warn "WARNING: $key takes a $takes not a $has.\n". " Please inform the author.\n"; } } } # Check if a given thing is a reference or instance of $type sub _is_of_type { my($thing, $type) = @_; return 1 if ref $thing eq $type; local $SIG{__DIE__}; return 1 if eval{ $thing->isa($type) }; return 0; } sub _format_att { my $given = shift; return $given eq '' ? "string/number" : uc $given eq $given ? "$given reference" : "$given object" ; } sub prompt ($;$) { ## no critic my($mess, $def) = @_; confess("prompt function called without an argument") unless defined $mess; my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; my $dispdef = defined $def ? "[$def] " : " "; $def = defined $def ? $def : ""; local $|=1; local $\; print "$mess $dispdef"; my $ans; if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) { print "$def\n"; } else { $ans = <STDIN>; if( defined $ans ) { $ans =~ s{\015?\012$}{}; } else { # user hit ctrl-D print "\n"; } } return (!defined $ans || $ans eq '') ? $def : $ans; } sub os_unsupported { die "OS unsupported\n"; } sub eval_in_subdirs { my($self) = @_; use Cwd qw(cwd abs_path); my $pwd = cwd() || die "Can't figure out your cwd!"; local @INC = map eval {abs_path($_) if -e} || $_, @INC; push @INC, '.'; # '.' has to always be at the end of @INC foreach my $dir (@{$self->{DIR}}){ my($abs) = $self->catdir($pwd,$dir); eval { $self->eval_in_x($abs); }; last if $@; } chdir $pwd; die $@ if $@; } sub eval_in_x { my($self,$dir) = @_; chdir $dir or carp("Couldn't change to directory $dir: $!"); { package main; do './Makefile.PL'; }; if ($@) { # if ($@ =~ /prerequisites/) { # die "MakeMaker WARNING: $@"; # } else { # warn "WARNING from evaluation of $dir/Makefile.PL: $@"; # } die "ERROR from evaluation of $dir/Makefile.PL: $@"; } } # package name for the classes into which the first object will be blessed my $PACKNAME = 'PACK000'; sub full_setup { $Verbose ||= 0; my @dep_macros = qw/ PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP /; my @fs_macros = qw/ FULLPERL XSUBPPDIR INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR INSTALLDIRS DESTDIR PREFIX INSTALL_BASE PERLPREFIX SITEPREFIX VENDORPREFIX INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN INSTALLMAN1DIR INSTALLMAN3DIR INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT PERL_LIB PERL_ARCHLIB SITELIBEXP SITEARCHEXP MAKE LIBPERL_A LIB PERL_SRC PERL_INC PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT /; my @attrib_help = qw/ AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME DL_FUNCS DL_VARS EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE FULLPERLRUN FULLPERLRUNINST FUNCLIST H IMPORTS INC INCLUDE_EXT LDFROM LIBS LICENSE LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA NO_PACKLIST NO_PERLLOCAL NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN PERLRUNINST PERL_CORE PERM_DIR PERM_RW PERM_RWX MAGICXS PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ PUREPERL_ONLY SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION clean depend dist dynamic_lib linkext macro realclean tool_autosplit MAN1EXT MAN3EXT MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED /; push @attrib_help, @fs_macros; @macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros); @macro_dep{@dep_macros} = (1) x @dep_macros; # IMPORTS is used under OS/2 and Win32 # @Overridable is close to @MM_Sections but not identical. The # order is important. Many subroutines declare macros. These # depend on each other. Let's try to collect the macros up front, # then pasthru, then the rules. # MM_Sections are the sections we have to call explicitly # in Overridable we have subroutines that are used indirectly @MM_Sections = qw( post_initialize const_config constants platform_constants tool_autosplit tool_xsubpp tools_other makemakerdflt dist macro depend cflags const_loadlibs const_cccmd post_constants pasthru special_targets c_o xs_c xs_o top_targets blibdirs linkext dlsyms dynamic_bs dynamic dynamic_lib static static_lib manifypods processPL installbin subdirs clean_subdirs clean realclean_subdirs realclean metafile signature dist_basics dist_core distdir dist_test dist_ci distmeta distsignature install force perldepend makefile staticmake test ppd ); # loses section ordering @Overridable = @MM_Sections; push @Overridable, qw[ libscan makeaperl needs_linking subdir_x test_via_harness test_via_script init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker ]; push @MM_Sections, qw[ pm_to_blib selfdocument ]; # Postamble needs to be the last that was always the case push @MM_Sections, "postamble"; push @Overridable, "postamble"; # All sections are valid keys. @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections; # we will use all these variables in the Makefile @Get_from_Config = qw( ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib sitelibexp sitearchexp so ); # 5.5.3 doesn't have any concept of vendor libs push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if "$]" >= 5.006; foreach my $item (@attrib_help){ $Recognized_Att_Keys{$item} = 1; } foreach my $item (@Get_from_Config) { $Recognized_Att_Keys{uc $item} = $Config{$item}; print "Attribute '\U$item\E' => '$Config{$item}'\n" if ($Verbose >= 2); } # # When we eval a Makefile.PL in a subdirectory, that one will ask # us (the parent) for the values and will prepend "..", so that # all files to be installed end up below OUR ./blib # @Prepend_parent = qw( INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC PERL FULLPERL ); } sub _has_cpan_meta_requirements { return eval { require CPAN::Meta::Requirements; CPAN::Meta::Requirements->VERSION(2.130); # Make sure vstrings can be handled. Some versions of CMR require B to # do this, which won't be available in miniperl. CPAN::Meta::Requirements->new->add_string_requirement('Module' => v1.2); 1; }; } sub new { my($class,$self) = @_; my($key); _convert_compat_attrs($self) if defined $self && $self; # Store the original args passed to WriteMakefile() foreach my $k (keys %$self) { $self->{ARGS}{$k} = $self->{$k}; } $self = {} unless defined $self; # Temporarily bless it into MM so it can be used as an # object. It will be blessed into a temp package later. bless $self, "MM"; # Cleanup all the module requirement bits my %key2cmr; for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { $self->{$key} ||= {}; if (_has_cpan_meta_requirements) { my $cmr = CPAN::Meta::Requirements->from_string_hash( $self->{$key}, { bad_version_hook => sub { #no warnings 'numeric'; # module doesn't use warnings my $fallback; if ( $_[0] =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { $fallback = sprintf "%f", $_[0]; } else { ($fallback) = $_[0] ? ($_[0] =~ /^([0-9.]+)/) : 0; $fallback += 0; carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as $fallback"; } version->new($fallback); }, }, ); $self->{$key} = $cmr->as_string_hash; $key2cmr{$key} = $cmr; } else { for my $module (sort keys %{ $self->{$key} }) { my $version = $self->{$key}->{$module}; my $fallback = 0; if (!defined($version) or !length($version)) { carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)"; } elsif ($version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/) { next; } else { if ( $version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { $fallback = sprintf "%f", $version; } else { ($fallback) = $version ? ($version =~ /^([0-9.]+)/) : 0; $fallback += 0; carp "Unparsable version '$version' for prerequisite $module treated as $fallback (CPAN::Meta::Requirements not available)"; } } $self->{$key}->{$module} = $fallback; } } } if ("@ARGV" =~ /\bPREREQ_PRINT\b/) { $self->_PREREQ_PRINT; } # PRINT_PREREQ is RedHatism. if ("@ARGV" =~ /\bPRINT_PREREQ\b/) { $self->_PRINT_PREREQ; } print "MakeMaker (v$VERSION)\n" if $Verbose; if (-f "MANIFEST" && ! -f "Makefile" && ! $UNDER_CORE){ check_manifest(); } check_hints($self); if ( $self->{MIN_PERL_VERSION}) { my $perl_version = $self->{MIN_PERL_VERSION}; if (ref $perl_version) { # assume a version object } else { $perl_version = eval { local $SIG{__WARN__} = sub { # simulate "use warnings FATAL => 'all'" for vintage perls die @_; }; version->new( $perl_version )->numify; }; $perl_version =~ tr/_//d if defined $perl_version; } if (!defined $perl_version) { # should this be a warning? die sprintf <<'END', $self->{MIN_PERL_VERSION}; MakeMaker FATAL: MIN_PERL_VERSION (%s) is not in a recognized format. Recommended is a quoted numerical value like '5.005' or '5.008001'. END } elsif ($perl_version > "$]") { my $message = sprintf <<'END', $perl_version, $]; Perl version %s or higher required. We run %s. END if ($self->{PREREQ_FATAL}) { die "MakeMaker FATAL: $message"; } else { warn "Warning: $message"; } } $self->{MIN_PERL_VERSION} = $perl_version; } my %configure_att; # record &{$self->{CONFIGURE}} attributes my(%initial_att) = %$self; # record initial attributes my(%unsatisfied) = (); my %prereq2version; my $cmr; if (_has_cpan_meta_requirements) { $cmr = CPAN::Meta::Requirements->new; for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { $cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key}; } foreach my $prereq ($cmr->required_modules) { $prereq2version{$prereq} = $cmr->requirements_for_module($prereq); } } else { for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { next unless my $module2version = $self->{$key}; $prereq2version{$_} = $module2version->{$_} for keys %$module2version; } } foreach my $prereq (sort keys %prereq2version) { my $required_version = $prereq2version{$prereq}; my $pr_version = 0; my $installed_file; if ( $prereq eq 'perl' ) { if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/ || $required_version !~ /^v?[\d_\.]+$/ ) { require version; my $normal = eval { version->new( $required_version ) }; $required_version = $normal if defined $normal; } $installed_file = $prereq; $pr_version = $]; } else { $installed_file = MM->_installed_file_for_module($prereq); $pr_version = MM->parse_version($installed_file) if $installed_file; $pr_version = 0 if $pr_version eq 'undef'; if ( !eval { version->new( $pr_version ); 1 } ) { #no warnings 'numeric'; # module doesn't use warnings my $fallback; if ( $pr_version =~ m!^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$! ) { $fallback = sprintf '%f', $pr_version; } else { ($fallback) = $pr_version ? ($pr_version =~ /^([0-9.]+)/) : 0; $fallback += 0; carp "Unparsable version '$pr_version' for installed prerequisite $prereq treated as $fallback"; } $pr_version = $fallback; } } # convert X.Y_Z alpha version #s to X.YZ for easier comparisons $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/; if (!$installed_file) { warn sprintf "Warning: prerequisite %s %s not found.\n", $prereq, $required_version unless $self->{PREREQ_FATAL} or $UNDER_CORE; $unsatisfied{$prereq} = 'not installed'; } elsif ( $cmr ? !$cmr->accepts_module($prereq, $pr_version) : $required_version > $pr_version ) { warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n", $prereq, $required_version, ($pr_version || 'unknown version') unless $self->{PREREQ_FATAL} or $UNDER_CORE; $unsatisfied{$prereq} = $required_version || 'unknown version' ; } } if (%unsatisfied && $self->{PREREQ_FATAL}){ my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} sort { $a cmp $b } keys %unsatisfied; die <<"END"; MakeMaker FATAL: prerequisites not found. $failedprereqs Please install these modules first and rerun 'perl Makefile.PL'. END } if (defined $self->{CONFIGURE}) { if (ref $self->{CONFIGURE} eq 'CODE') { %configure_att = %{&{$self->{CONFIGURE}}}; _convert_compat_attrs(\%configure_att); $self = { %$self, %configure_att }; } else { croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n"; } } my $newclass = ++$PACKNAME; local @Parent = @Parent; # Protect against non-local exits { print "Blessing Object into class [$newclass]\n" if $Verbose>=2; mv_all_methods("MY",$newclass); bless $self, $newclass; push @Parent, $self; require ExtUtils::MY; no strict 'refs'; ## no critic; @{"$newclass\:\:ISA"} = 'MM'; } if (defined $Parent[-2]){ $self->{PARENT} = $Parent[-2]; for my $key (@Prepend_parent) { next unless defined $self->{PARENT}{$key}; # Don't stomp on WriteMakefile() args. next if defined $self->{ARGS}{$key} and $self->{ARGS}{$key} eq $self->{$key}; $self->{$key} = $self->{PARENT}{$key}; if ($Is_VMS && $key =~ /PERL$/) { # PERL or FULLPERL will be a command verb or even a # command with an argument instead of a full file # specification under VMS. So, don't turn the command # into a filespec, but do add a level to the path of # the argument if not already absolute. my @cmd = split /\s+/, $self->{$key}; $cmd[1] = $self->catfile('[-]',$cmd[1]) unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]); $self->{$key} = join(' ', @cmd); } else { my $value = $self->{$key}; # not going to test in FS so only stripping start $value =~ s/"// if $key =~ /PERL$/ and $self->is_make_type('dmake'); $value =~ s/^"// if $key =~ /PERL$/; $value = $self->catdir("..", $value) unless $self->file_name_is_absolute($value); $value = qq{"$value} if $key =~ /PERL$/; $self->{$key} = $value; } } if ($self->{PARENT}) { $self->{PARENT}->{CHILDREN}->{$newclass} = $self; foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE AR FULL_AR CC CCFLAGS OPTIMIZE LD LDDLFLAGS LDFLAGS PERL_ARCHLIB DESTDIR)) { if (exists $self->{PARENT}->{$opt} and not exists $self->{$opt}) { # inherit, but only if already unspecified $self->{$opt} = $self->{PARENT}->{$opt}; } } } my @fm = grep /^FIRST_MAKEFILE=/, @ARGV; parse_args($self,@fm) if @fm; } else { parse_args($self, _shellwords($ENV{PERL_MM_OPT} || ''),@ARGV); } # RT#91540 PREREQ_FATAL not recognized on command line if (%unsatisfied && $self->{PREREQ_FATAL}){ my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} sort { $a cmp $b } keys %unsatisfied; die <<"END"; MakeMaker FATAL: prerequisites not found. $failedprereqs Please install these modules first and rerun 'perl Makefile.PL'. END } $self->{NAME} ||= $self->guess_name; warn "Warning: NAME must be a package name\n" unless $self->{NAME} =~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!; ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g; $self->init_MAKE; $self->init_main; $self->init_VERSION; $self->init_dist; $self->init_INST; $self->init_INSTALL; $self->init_DEST; $self->init_dirscan; $self->init_PM; $self->init_MANPODS; $self->init_xs; $self->init_PERL; $self->init_DIRFILESEP; $self->init_linker; $self->init_ABSTRACT; $self->arch_check( $INC{'Config.pm'}, $self->catfile($Config{'archlibexp'}, "Config.pm") ); $self->init_tools(); $self->init_others(); $self->init_platform(); $self->init_PERM(); my @args = @ARGV; @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; my($argv) = neatvalue(\@args); $argv =~ s/^\[/(/; $argv =~ s/\]$/)/; push @{$self->{RESULT}}, <<END; # This Makefile is for the $self->{NAME} extension to perl. # # It was generated automatically by MakeMaker version # $VERSION (Revision: $Revision) from the contents of # Makefile.PL. Don't edit this file, edit Makefile.PL instead. # # ANY CHANGES MADE HERE WILL BE LOST! # # MakeMaker ARGV: $argv # END push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att); if (defined $self->{CONFIGURE}) { push @{$self->{RESULT}}, <<END; # MakeMaker 'CONFIGURE' Parameters: END if (scalar(keys %configure_att) > 0) { foreach my $key (sort keys %configure_att){ next if $key eq 'ARGS'; my($v) = neatvalue($configure_att{$key}); $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; $v =~ tr/\n/ /s; push @{$self->{RESULT}}, "# $key => $v"; } } else { push @{$self->{RESULT}}, "# no values returned"; } undef %configure_att; # free memory } # turn the SKIP array into a SKIPHASH hash for my $skip (@{$self->{SKIP} || []}) { $self->{SKIPHASH}{$skip} = 1; } delete $self->{SKIP}; # free memory if ($self->{PARENT}) { for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) { $self->{SKIPHASH}{$_} = 1; } } # We run all the subdirectories now. They don't have much to query # from the parent, but the parent has to query them: if they need linking! unless ($self->{NORECURS}) { $self->eval_in_subdirs if @{$self->{DIR}}; } foreach my $section ( @MM_Sections ){ # Support for new foo_target() methods. my $method = $section; $method .= '_target' unless $self->can($method); print "Processing Makefile '$section' section\n" if ($Verbose >= 2); my($skipit) = $self->skipcheck($section); if ($skipit){ push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit."; } else { my(%a) = %{$self->{$section} || {}}; push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:"; push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a; push @{$self->{RESULT}}, $self->maketext_filter( $self->$method( %a ) ); } } push @{$self->{RESULT}}, "\n# End."; $self; } sub WriteEmptyMakefile { croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2; my %att = @_; $att{DIR} = [] unless $att{DIR}; # don't recurse by default my $self = MM->new(\%att); my $new = $self->{MAKEFILE}; my $old = $self->{MAKEFILE_OLD}; if (-f $old) { _unlink($old) or warn "unlink $old: $!"; } if ( -f $new ) { _rename($new, $old) or warn "rename $new => $old: $!" } open my $mfh, '>', $new or die "open $new for write: $!"; print $mfh <<'EOP'; all : manifypods : subdirs : dynamic : static : clean : install : makemakerdflt : test : test_dynamic : test_static : EOP close $mfh or die "close $new for write: $!"; } =begin private =head3 _installed_file_for_module my $file = MM->_installed_file_for_module($module); Return the first installed .pm $file associated with the $module. The one which will show up when you C<use $module>. $module is something like "strict" or "Test::More". =end private =cut sub _installed_file_for_module { my $class = shift; my $prereq = shift; my $file = "$prereq.pm"; $file =~ s{::}{/}g; my $path; for my $dir (@INC) { my $tmp = File::Spec->catfile($dir, $file); if ( -r $tmp ) { $path = $tmp; last; } } return $path; } # Extracted from MakeMaker->new so we can test it sub _MakeMaker_Parameters_section { my $self = shift; my $att = shift; my @result = <<'END'; # MakeMaker Parameters: END foreach my $key (sort keys %$att){ next if $key eq 'ARGS'; my $v; if ($key eq 'PREREQ_PM') { # CPAN.pm takes prereqs from this field in 'Makefile' # and does not know about BUILD_REQUIRES $v = neatvalue({ %{ $att->{PREREQ_PM} || {} }, %{ $att->{BUILD_REQUIRES} || {} }, %{ $att->{TEST_REQUIRES} || {} }, }); } else { $v = neatvalue($att->{$key}); } $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; $v =~ tr/\n/ /s; push @result, "# $key => $v"; } return @result; } # _shellwords and _parseline borrowed from Text::ParseWords sub _shellwords { my (@lines) = @_; my @allwords; foreach my $line (@lines) { $line =~ s/^\s+//; my @words = _parse_line('\s+', 0, $line); pop @words if (@words and !defined $words[-1]); return() unless (@words || !length($line)); push(@allwords, @words); } return(@allwords); } sub _parse_line { my($delimiter, $keep, $line) = @_; my($word, @pieces); no warnings 'uninitialized'; # we will be testing undef strings while (length($line)) { # This pattern is optimised to be stack conservative on older perls. # Do not refactor without being careful and testing it on very long strings. # See Perl bug #42980 for an example of a stack busting input. $line =~ s/^ (?: # double quoted string (") # $quote ((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted | # --OR-- # singe quoted string (') # $quote ((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted | # --OR-- # unquoted string ( # $unquoted (?:\\.|[^\\"'])*? ) # followed by ( # $delim \Z(?!\n) # EOL | # --OR-- (?-x:$delimiter) # delimiter | # --OR-- (?!^)(?=["']) # a quote ) )//xs or return; # extended layout my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6); return() unless( defined($quote) || length($unquoted) || length($delim)); if ($keep) { $quoted = "$quote$quoted$quote"; } else { $unquoted =~ s/\\(.)/$1/sg; if (defined $quote) { $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); #$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); } } $word .= substr($line, 0, 0); # leave results tainted $word .= defined $quote ? $quoted : $unquoted; if (length($delim)) { push(@pieces, $word); push(@pieces, $delim) if ($keep eq 'delimiters'); undef $word; } if (!length($line)) { push(@pieces, $word); } } return(@pieces); } sub check_manifest { print STDOUT "Checking if your kit is complete...\n"; require ExtUtils::Manifest; # avoid warning $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1; my(@missed) = ExtUtils::Manifest::manicheck(); if (@missed) { print "Warning: the following files are missing in your kit:\n"; print "\t", join "\n\t", @missed; print "\n"; print "Please inform the author.\n"; } else { print "Looks good\n"; } } sub parse_args{ my($self, @args) = @_; @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; foreach (@args) { unless (m/(.*?)=(.*)/) { ++$Verbose if m/^verb/; next; } my($name, $value) = ($1, $2); if ($value =~ m/^~(\w+)?/) { # tilde with optional username $value =~ s [^~(\w*)] [$1 ? ((getpwnam($1))[7] || "~$1") : (getpwuid($>))[7] ]ex; } # Remember the original args passed it. It will be useful later. $self->{ARGS}{uc $name} = $self->{uc $name} = $value; } # catch old-style 'potential_libs' and inform user how to 'upgrade' if (defined $self->{potential_libs}){ my($msg)="'potential_libs' => '$self->{potential_libs}' should be"; if ($self->{potential_libs}){ print "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n"; } else { print "$msg deleted.\n"; } $self->{LIBS} = [$self->{potential_libs}]; delete $self->{potential_libs}; } # catch old-style 'ARMAYBE' and inform user how to 'upgrade' if (defined $self->{ARMAYBE}){ my($armaybe) = $self->{ARMAYBE}; print "ARMAYBE => '$armaybe' should be changed to:\n", "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n"; my(%dl) = %{$self->{dynamic_lib} || {}}; $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe}; delete $self->{ARMAYBE}; } if (defined $self->{LDTARGET}){ print "LDTARGET should be changed to LDFROM\n"; $self->{LDFROM} = $self->{LDTARGET}; delete $self->{LDTARGET}; } # Turn a DIR argument on the command line into an array if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') { # So they can choose from the command line, which extensions they want # the grep enables them to have some colons too much in case they # have to build a list with the shell $self->{DIR} = [grep $_, split ":", $self->{DIR}]; } # Turn a INCLUDE_EXT argument on the command line into an array if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') { $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}]; } # Turn a EXCLUDE_EXT argument on the command line into an array if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') { $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}]; } foreach my $mmkey (sort keys %$self){ next if $mmkey eq 'ARGS'; print " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose; print "'$mmkey' is not a known MakeMaker parameter name.\n" unless exists $Recognized_Att_Keys{$mmkey}; } $| = 1 if $Verbose; } sub check_hints { my($self) = @_; # We allow extension-specific hints files. require File::Spec; my $curdir = File::Spec->curdir; my $hint_dir = File::Spec->catdir($curdir, "hints"); return unless -d $hint_dir; # First we look for the best hintsfile we have my($hint)="${^O}_$Config{osvers}"; $hint =~ s/\./_/g; $hint =~ s/_$//; return unless $hint; # Also try without trailing minor version numbers. while (1) { last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found } continue { last unless $hint =~ s/_[^_]*$//; # nothing to cut off } my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl"); return unless -f $hint_file; # really there _run_hintfile($self, $hint_file); } sub _run_hintfile { my ($self, $hint_file) = @_; local($@, $!); print "Processing hints file $hint_file\n" if $Verbose; if(open(my $fh, '<', $hint_file)) { my $hints_content = do { local $/; <$fh> }; no strict; eval $hints_content; warn "Failed to run hint file $hint_file: $@" if $@; } else { warn "Could not open $hint_file for read: $!"; } } sub mv_all_methods { my($from,$to) = @_; local $SIG{__WARN__} = sub { # can't use 'no warnings redefined', 5.6 only warn @_ unless $_[0] =~ /^Subroutine .* redefined/ }; foreach my $method (@Overridable) { next unless defined &{"${from}::$method"}; no strict 'refs'; ## no critic *{"${to}::$method"} = \&{"${from}::$method"}; # If we delete a method, then it will be undefined and cannot # be called. But as long as we have Makefile.PLs that rely on # %MY:: being intact, we have to fill the hole with an # inheriting method: { package MY; my $super = "SUPER::".$method; *{$method} = sub { shift->$super(@_); }; } } } sub skipcheck { my($self) = shift; my($section) = @_; return 'skipped' if $section eq 'metafile' && $UNDER_CORE; if ($section eq 'dynamic') { print "Warning (non-fatal): Target 'dynamic' depends on targets ", "in skipped section 'dynamic_bs'\n" if $self->{SKIPHASH}{dynamic_bs} && $Verbose; print "Warning (non-fatal): Target 'dynamic' depends on targets ", "in skipped section 'dynamic_lib'\n" if $self->{SKIPHASH}{dynamic_lib} && $Verbose; } if ($section eq 'dynamic_lib') { print "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ", "targets in skipped section 'dynamic_bs'\n" if $self->{SKIPHASH}{dynamic_bs} && $Verbose; } if ($section eq 'static') { print "Warning (non-fatal): Target 'static' depends on targets ", "in skipped section 'static_lib'\n" if $self->{SKIPHASH}{static_lib} && $Verbose; } return 'skipped' if $self->{SKIPHASH}{$section}; return ''; } # returns filehandle, dies on fail. :raw so no :crlf sub open_for_writing { my ($file) = @_; open my $fh ,">", $file or die "Unable to open $file: $!"; my @layers = ':raw'; push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE; binmode $fh, join ' ', @layers; $fh; } sub flush { my $self = shift; my $finalname = $self->{MAKEFILE}; printf STDOUT "Generating a %s %s\n", $self->make_type, $finalname if $Verbose || !$self->{PARENT}; print STDOUT "Writing $finalname for $self->{NAME}\n" if $Verbose || !$self->{PARENT}; unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); write_file_via_tmp($finalname, $self->{RESULT}); # Write MYMETA.yml to communicate metadata up to the CPAN clients print STDOUT "Writing MYMETA.yml and MYMETA.json\n" if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta ); # save memory if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) { my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE); delete $self->{$_} for grep !$keep{$_}, keys %$self; } system("$Config::Config{eunicefix} $finalname") if $Config::Config{eunicefix} ne ":"; return; } sub write_file_via_tmp { my ($finalname, $contents) = @_; my $fh = open_for_writing("MakeMaker.tmp"); die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents; for my $chunk (@$contents) { my $to_write = $chunk; utf8::encode $to_write if !$CAN_DECODE && "$]" > 5.008; print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!"; } close $fh or die "Can't write to MakeMaker.tmp: $!"; _rename("MakeMaker.tmp", $finalname) or warn "rename MakeMaker.tmp => $finalname: $!"; chmod 0644, $finalname if !$Is_VMS; return; } # This is a rename for OS's where the target must be unlinked first. sub _rename { my($src, $dest) = @_; _unlink($dest); return rename $src, $dest; } # This is an unlink for OS's where the target must be writable first. sub _unlink { my @files = @_; chmod 0666, @files; return unlink @files; } # The following mkbootstrap() is only for installations that are calling # the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker # writes Makefiles, that use ExtUtils::Mkbootstrap directly. sub mkbootstrap { die <<END; !!! Your Makefile has been built such a long time ago, !!! !!! that is unlikely to work with current MakeMaker. !!! !!! Please rebuild your Makefile !!! END } # Ditto for mksymlists() as of MakeMaker 5.17 sub mksymlists { die <<END; !!! Your Makefile has been built such a long time ago, !!! !!! that is unlikely to work with current MakeMaker. !!! !!! Please rebuild your Makefile !!! END } sub neatvalue { my($v) = @_; return "undef" unless defined $v; my($t) = ref $v; return "q[$v]" unless $t; if ($t eq 'ARRAY') { my(@m, @neat); push @m, "["; foreach my $elem (@$v) { push @neat, "q[$elem]"; } push @m, join ", ", @neat; push @m, "]"; return join "", @m; } return $v unless $t eq 'HASH'; my(@m, $key, $val); for my $key (sort keys %$v) { last unless defined $key; # cautious programming in case (undef,undef) is true push @m,"$key=>".neatvalue($v->{$key}); } return "{ ".join(', ',@m)." }"; } sub _find_magic_vstring { my $value = shift; return $value if $UNDER_CORE; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } sub selfdocument { my($self) = @_; my(@m); if ($Verbose){ push @m, "\n# Full list of MakeMaker attribute values:"; foreach my $key (sort keys %$self){ next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/; my($v) = neatvalue($self->{$key}); $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; $v =~ tr/\n/ /s; push @m, "# $key => $v"; } } # added here as selfdocument is not overridable push @m, <<'EOF'; # here so even if top_targets is overridden, these will still be defined # gmake will silently still work if any are .PHONY-ed but nmake won't EOF push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n", # config is so manifypods won't puke if no subdirs grep !$self->{SKIPHASH}{$_}, qw(static dynamic config); join "\n", @m; } 1; __END__ =head1 NAME ExtUtils::MakeMaker - Create a module Makefile =head1 SYNOPSIS use ExtUtils::MakeMaker; WriteMakefile( NAME => "Foo::Bar", VERSION_FROM => "lib/Foo/Bar.pm", ); =head1 DESCRIPTION This utility is designed to write a Makefile for an extension module from a Makefile.PL. It is based on the Makefile.SH model provided by Andy Dougherty and the perl5-porters. It splits the task of generating the Makefile into several subroutines that can be individually overridden. Each subroutine returns the text it wishes to have written to the Makefile. As there are various Make programs with incompatible syntax, which use operating system shells, again with incompatible syntax, it is important for users of this module to know which flavour of Make a Makefile has been written for so they'll use the correct one and won't have to face the possibly bewildering errors resulting from using the wrong one. On POSIX systems, that program will likely be GNU Make; on Microsoft Windows, it will be either Microsoft NMake, DMake or GNU Make. See the section on the L</"MAKE"> parameter for details. ExtUtils::MakeMaker (EUMM) is object oriented. Each directory below the current directory that contains a Makefile.PL is treated as a separate object. This makes it possible to write an unlimited number of Makefiles with a single invocation of WriteMakefile(). All inputs to WriteMakefile are Unicode characters, not just octets. EUMM seeks to handle all of these correctly. It is currently still not possible to portably use Unicode characters in module names, because this requires Perl to handle Unicode filenames, which is not yet the case on Windows. See L<ExtUtils::MakeMaker::FAQ> for details of the design and usage. =head2 How To Write A Makefile.PL See L<ExtUtils::MakeMaker::Tutorial>. The long answer is the rest of the manpage :-) =head2 Default Makefile Behaviour The generated Makefile enables the user of the extension to invoke perl Makefile.PL # optionally "perl Makefile.PL verbose" make make test # optionally set TEST_VERBOSE=1 make install # See below The Makefile to be produced may be altered by adding arguments of the form C<KEY=VALUE>. E.g. perl Makefile.PL INSTALL_BASE=~ Other interesting targets in the generated Makefile are make config # to check if the Makefile is up-to-date make clean # delete local temp files (Makefile gets renamed) make realclean # delete derived files (including ./blib) make ci # check in all the files in the MANIFEST file make dist # see below the Distribution Support section =head2 make test MakeMaker checks for the existence of a file named F<test.pl> in the current directory, and if it exists it executes the script with the proper set of perl C<-I> options. MakeMaker also checks for any files matching glob("t/*.t"). It will execute all matching files in alphabetical order via the L<Test::Harness> module with the C<-I> switches set correctly. You can also organize your tests within subdirectories in the F<t/> directory. To do so, use the F<test> directive in your I<Makefile.PL>. For example, if you had tests in: t/foo t/foo/bar You could tell make to run tests in both of those directories with the following directives: test => {TESTS => 't/*/*.t t/*/*/*.t'} test => {TESTS => 't/foo/*.t t/foo/bar/*.t'} The first will run all test files in all first-level subdirectories and all subdirectories they contain. The second will run tests in only the F<t/foo> and F<t/foo/bar>. If you'd like to see the raw output of your tests, set the C<TEST_VERBOSE> variable to true. make test TEST_VERBOSE=1 If you want to run particular test files, set the C<TEST_FILES> variable. It is possible to use globbing with this mechanism. make test TEST_FILES='t/foobar.t t/dagobah*.t' Windows users who are using C<nmake> should note that due to a bug in C<nmake>, when specifying C<TEST_FILES> you must use back-slashes instead of forward-slashes. nmake test TEST_FILES='t\foobar.t t\dagobah*.t' =head2 make testdb A useful variation of the above is the target C<testdb>. It runs the test under the Perl debugger (see L<perldebug>). If the file F<test.pl> exists in the current directory, it is used for the test. If you want to debug some other testfile, set the C<TEST_FILE> variable thusly: make testdb TEST_FILE=t/mytest.t By default the debugger is called using C<-d> option to perl. If you want to specify some other option, set the C<TESTDB_SW> variable: make testdb TESTDB_SW=-Dx =head2 make install make alone puts all relevant files into directories that are named by the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and INST_MAN3DIR. All these default to something below ./blib if you are I<not> building below the perl source directory. If you I<are> building below the perl source, INST_LIB and INST_ARCHLIB default to ../../lib, and INST_SCRIPT is not defined. The I<install> target of the generated Makefile copies the files found below each of the INST_* directories to their INSTALL* counterparts. Which counterparts are chosen depends on the setting of INSTALLDIRS according to the following table: INSTALLDIRS set to perl site vendor PERLPREFIX SITEPREFIX VENDORPREFIX INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR The INSTALL... macros in turn default to their %Config ($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts. You can check the values of these variables on your system with perl '-V:install.*' And to check the sequence in which the library directories are searched by perl, run perl -le 'print join $/, @INC' Sometimes older versions of the module you're installing live in other directories in @INC. Because Perl loads the first version of a module it finds, not the newest, you might accidentally get one of these older versions even after installing a brand new version. To delete I<all other versions of the module you're installing> (not simply older ones) set the C<UNINST> variable. make install UNINST=1 =head2 INSTALL_BASE INSTALL_BASE can be passed into Makefile.PL to change where your module will be installed. INSTALL_BASE is more like what everyone else calls "prefix" than PREFIX is. To have everything installed in your home directory, do the following. # Unix users, INSTALL_BASE=~ works fine perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir Like PREFIX, it sets several INSTALL* attributes at once. Unlike PREFIX it is easy to predict where the module will end up. The installation pattern looks like this: INSTALLARCHLIB INSTALL_BASE/lib/perl5/$Config{archname} INSTALLPRIVLIB INSTALL_BASE/lib/perl5 INSTALLBIN INSTALL_BASE/bin INSTALLSCRIPT INSTALL_BASE/bin INSTALLMAN1DIR INSTALL_BASE/man/man1 INSTALLMAN3DIR INSTALL_BASE/man/man3 INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as of 0.28) install to the same location. If you want MakeMaker and Module::Build to install to the same location simply set INSTALL_BASE and C<--install_base> to the same location. INSTALL_BASE was added in 6.31. =head2 PREFIX and LIB attribute PREFIX and LIB can be used to set several INSTALL* attributes in one go. Here's an example for installing into your home directory. # Unix users, PREFIX=~ works fine perl Makefile.PL PREFIX=/path/to/your/home/dir This will install all files in the module under your home directory, with man pages and libraries going into an appropriate place (usually ~/man and ~/lib). How the exact location is determined is complicated and depends on how your Perl was configured. INSTALL_BASE works more like what other build systems call "prefix" than PREFIX and we recommend you use that instead. Another way to specify many INSTALL directories with a single parameter is LIB. perl Makefile.PL LIB=~/lib This will install the module's architecture-independent files into ~/lib, the architecture-dependent files into ~/lib/$archname. Note, that in both cases the tilde expansion is done by MakeMaker, not by perl by default, nor by make. Conflicts between parameters LIB, PREFIX and the various INSTALL* arguments are resolved so that: =over 4 =item * setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX); =item * without LIB, setting PREFIX replaces the initial C<$Config{prefix}> part of those INSTALL* arguments, even if the latter are explicitly set (but are set to still start with C<$Config{prefix}>). =back If the user has superuser privileges, and is not working on AFS or relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB, INSTALLSCRIPT, etc. will be appropriate, and this incantation will be the best: perl Makefile.PL; make; make test make install make install by default writes some documentation of what has been done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature can be bypassed by calling make pure_install. =head2 AFS users will have to specify the installation directories as these most probably have changed since perl itself has been installed. They will have to do this by calling perl Makefile.PL INSTALLSITELIB=/afs/here/today \ INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages make Be careful to repeat this procedure every time you recompile an extension, unless you are sure the AFS installation directories are still valid. =head2 Static Linking of a new Perl Binary An extension that is built with the above steps is ready to use on systems supporting dynamic loading. On systems that do not support dynamic loading, any newly created extension has to be linked together with the available resources. MakeMaker supports the linking process by creating appropriate targets in the Makefile whenever an extension is built. You can invoke the corresponding section of the makefile with make perl That produces a new perl binary in the current directory with all extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP, and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on UNIX, this is called F<Makefile.aperl> (may be system dependent). If you want to force the creation of a new perl, it is recommended that you delete this F<Makefile.aperl>, so the directories are searched through for linkable libraries again. The binary can be installed into the directory where perl normally resides on your machine with make inst_perl To produce a perl binary with a different name than C<perl>, either say perl Makefile.PL MAP_TARGET=myperl make myperl make inst_perl or say perl Makefile.PL make myperl MAP_TARGET=myperl make inst_perl MAP_TARGET=myperl In any case you will be prompted with the correct invocation of the C<inst_perl> target that installs the new binary into INSTALLBIN. make inst_perl by default writes some documentation of what has been done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This can be bypassed by calling make pure_inst_perl. Warning: the inst_perl: target will most probably overwrite your existing perl binary. Use with care! Sometimes you might want to build a statically linked perl although your system supports dynamic loading. In this case you may explicitly set the linktype with the invocation of the Makefile.PL or make: perl Makefile.PL LINKTYPE=static # recommended or make LINKTYPE=static # works on most systems =head2 Determination of Perl Library and Installation Locations MakeMaker needs to know, or to guess, where certain things are located. Especially INST_LIB and INST_ARCHLIB (where to put the files during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read existing modules from), and PERL_INC (header files and C<libperl*.*>). Extensions may be built either using the contents of the perl source directory tree or from the installed perl library. The recommended way is to build extensions after you have run 'make install' on perl itself. You can do that in any directory on your hard disk that is not below the perl source tree. The support for extensions below the ext directory of the perl distribution is only good for the standard extensions that come with perl. If an extension is being built below the C<ext/> directory of the perl source then MakeMaker will set PERL_SRC automatically (e.g., C<../..>). If PERL_SRC is defined and the extension is recognized as a standard extension, then other variables default to the following: PERL_INC = PERL_SRC PERL_LIB = PERL_SRC/lib PERL_ARCHLIB = PERL_SRC/lib INST_LIB = PERL_LIB INST_ARCHLIB = PERL_ARCHLIB If an extension is being built away from the perl source then MakeMaker will leave PERL_SRC undefined and default to using the installed copy of the perl library. The other variables default to the following: PERL_INC = $archlibexp/CORE PERL_LIB = $privlibexp PERL_ARCHLIB = $archlibexp INST_LIB = ./blib/lib INST_ARCHLIB = ./blib/arch If perl has not yet been installed then PERL_SRC can be defined on the command line as shown in the previous section. =head2 Which architecture dependent directory? If you don't want to keep the defaults for the INSTALL* macros, MakeMaker helps you to minimize the typing needed: the usual relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined by Configure at perl compilation time. MakeMaker supports the user who sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not, then MakeMaker defaults the latter to be the same subdirectory of INSTALLPRIVLIB as Configure decided for the counterparts in %Config, otherwise it defaults to INSTALLPRIVLIB. The same relationship holds for INSTALLSITELIB and INSTALLSITEARCH. MakeMaker gives you much more freedom than needed to configure internal variables and get different results. It is worth mentioning that make(1) also lets you configure most of the variables that are used in the Makefile. But in the majority of situations this will not be necessary, and should only be done if the author of a package recommends it (or you know what you're doing). =head2 Using Attributes and Parameters The following attributes may be specified as arguments to WriteMakefile() or as NAME=VALUE pairs on the command line. Attributes that became available with later versions of MakeMaker are indicated. In order to maintain portability of attributes with older versions of MakeMaker you may want to use L<App::EUMM::Upgrade> with your C<Makefile.PL>. =over 2 =item ABSTRACT One line description of the module. Will be included in PPD file. =item ABSTRACT_FROM Name of the file that contains the package description. MakeMaker looks for a line in the POD matching /^($package\s-\s)(.*)/. This is typically the first line in the "=head1 NAME" section. $2 becomes the abstract. =item AUTHOR Array of strings containing name (and email address) of package author(s). Is used in CPAN Meta files (META.yml or META.json) and PPD (Perl Package Description) files for PPM (Perl Package Manager). =item BINARY_LOCATION Used when creating PPD files for binary packages. It can be set to a full or relative path or URL to the binary archive for a particular architecture. For example: perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz builds a PPD package that references a binary of the C<Agent> package, located in the C<x86> directory relative to the PPD itself. =item BUILD_REQUIRES Available in version 6.55_03 and above. A hash of modules that are needed to build your module but not run it. This will go into the C<build_requires> field of your F<META.yml> and the C<build> of the C<prereqs> field of your F<META.json>. Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified. The format is the same as PREREQ_PM. =item C Ref to array of *.c file names. Initialised from a directory scan and the values portion of the XS attribute hash. This is not currently used by MakeMaker but may be handy in Makefile.PLs. =item CCFLAGS String that will be included in the compiler call command line between the arguments INC and OPTIMIZE. =item CONFIG Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from config.sh. MakeMaker will add to CONFIG the following values anyway: ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc lib_ext obj_ext ranlib sitelibexp sitearchexp so =item CONFIGURE CODE reference. The subroutine should return a hash reference. The hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to be determined by some evaluation method. =item CONFIGURE_REQUIRES Available in version 6.52 and above. A hash of modules that are required to run Makefile.PL itself, but not to run your distribution. This will go into the C<configure_requires> field of your F<META.yml> and the C<configure> of the C<prereqs> field of your F<META.json>. Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified. The format is the same as PREREQ_PM. =item DEFINE Something like C<"-DHAVE_UNISTD_H"> =item DESTDIR This is the root directory into which the code will be installed. It I<prepends itself to the normal prefix>. For example, if your code would normally go into F</usr/local/lib/perl> you could set DESTDIR=~/tmp/ and installation would go into F<~/tmp/usr/local/lib/perl>. This is primarily of use for people who repackage Perl modules. NOTE: Due to the nature of make, it is important that you put the trailing slash on your DESTDIR. F<~/tmp/> not F<~/tmp>. =item DIR Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm'] in ext/SDBM_File =item DISTNAME A safe filename for the package. Defaults to NAME below but with :: replaced with -. For example, Foo::Bar becomes Foo-Bar. =item DISTVNAME Your name for distributing the package with the version number included. This is used by 'make dist' to name the resulting archive file. Defaults to DISTNAME-VERSION. For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04. On some OS's where . has special meaning VERSION_SYM may be used in place of VERSION. =item DLEXT Specifies the extension of the module's loadable object. For example: DLEXT => 'unusual_ext', # Default value is $Config{so} NOTE: When using this option to alter the extension of a module's loadable object, it is also necessary that the module's pm file specifies the same change: local $DynaLoader::dl_dlext = 'unusual_ext'; =item DL_FUNCS Hashref of symbol names for routines to be made available as universal symbols. Each key/value pair consists of the package name and an array of routine names in that package. Used only under AIX, OS/2, VMS and Win32 at present. The routine names supplied will be expanded in the same way as XSUB names are expanded by the XS() macro. Defaults to {"$(NAME)" => ["boot_$(NAME)" ] } e.g. {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], "NetconfigPtr" => [ 'DESTROY'] } Please see the L<ExtUtils::Mksymlists> documentation for more information about the DL_FUNCS, DL_VARS and FUNCLIST attributes. =item DL_VARS Array of symbol names for variables to be made available as universal symbols. Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. (e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) =item EXCLUDE_EXT Array of extension names to exclude when doing a static build. This is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more details. (e.g. [ qw( Socket POSIX ) ] ) This attribute may be most useful when specified as a string on the command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' =item EXE_FILES Ref to array of executable files. The files will be copied to the INST_SCRIPT directory. Make realclean will delete them from there again. If your executables start with something like #!perl or #!/usr/bin/perl MakeMaker will change this to the path of the perl 'Makefile.PL' was invoked with so the programs will be sure to run properly even if perl is not in /usr/bin/perl. =item FIRST_MAKEFILE The name of the Makefile to be produced. This is used for the second Makefile that will be produced for the MAP_TARGET. Defaults to 'Makefile' or 'Descrip.MMS' on VMS. (Note: we couldn't use MAKEFILE because dmake uses this for something else). =item FULLPERL Perl binary able to run this extension, load XS modules, etc... =item FULLPERLRUN Like PERLRUN, except it uses FULLPERL. =item FULLPERLRUNINST Like PERLRUNINST, except it uses FULLPERL. =item FUNCLIST This provides an alternate means to specify function names to be exported from the extension. Its value is a reference to an array of function names to be exported by the extension. These names are passed through unaltered to the linker options file. =item H Ref to array of *.h file names. Similar to C. =item IMPORTS This attribute is used to specify names to be imported into the extension. Takes a hash ref. It is only used on OS/2 and Win32. =item INC Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> =item INCLUDE_EXT Array of extension names to be included when doing a static build. MakeMaker will normally build with all of the installed extensions when doing a static build, and that is usually the desired behavior. If INCLUDE_EXT is present then MakeMaker will build only with those extensions which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ]) It is not necessary to mention DynaLoader or the current extension when filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then only DynaLoader and the current extension will be included in the build. This attribute may be most useful when specified as a string on the command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' =item INSTALLARCHLIB Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to perl. =item INSTALLBIN Directory to install binary files (e.g. tkperl) into if INSTALLDIRS=perl. =item INSTALLDIRS Determines which of the sets of installation directories to choose: perl, site or vendor. Defaults to site. =item INSTALLMAN1DIR =item INSTALLMAN3DIR These directories get the man pages at 'make install' time if INSTALLDIRS=perl. Defaults to $Config{installman*dir}. If set to 'none', no man pages will be installed. =item INSTALLPRIVLIB Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to perl. Defaults to $Config{installprivlib}. =item INSTALLSCRIPT Available in version 6.30_02 and above. Used by 'make install' which copies files from INST_SCRIPT to this directory if INSTALLDIRS=perl. =item INSTALLSITEARCH Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to site (default). =item INSTALLSITEBIN Used by 'make install', which copies files from INST_BIN to this directory if INSTALLDIRS is set to site (default). =item INSTALLSITELIB Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to site (default). =item INSTALLSITEMAN1DIR =item INSTALLSITEMAN3DIR These directories get the man pages at 'make install' time if INSTALLDIRS=site (default). Defaults to $(SITEPREFIX)/man/man$(MAN*EXT). If set to 'none', no man pages will be installed. =item INSTALLSITESCRIPT Used by 'make install' which copies files from INST_SCRIPT to this directory if INSTALLDIRS is set to site (default). =item INSTALLVENDORARCH Used by 'make install', which copies files from INST_ARCHLIB to this directory if INSTALLDIRS is set to vendor. Note that if you do not set this, the value of INSTALLVENDORLIB will be used, which is probably not what you want. =item INSTALLVENDORBIN Used by 'make install', which copies files from INST_BIN to this directory if INSTALLDIRS is set to vendor. =item INSTALLVENDORLIB Used by 'make install', which copies files from INST_LIB to this directory if INSTALLDIRS is set to vendor. =item INSTALLVENDORMAN1DIR =item INSTALLVENDORMAN3DIR These directories get the man pages at 'make install' time if INSTALLDIRS=vendor. Defaults to $(VENDORPREFIX)/man/man$(MAN*EXT). If set to 'none', no man pages will be installed. =item INSTALLVENDORSCRIPT Available in version 6.30_02 and above. Used by 'make install' which copies files from INST_SCRIPT to this directory if INSTALLDIRS is set to vendor. =item INST_ARCHLIB Same as INST_LIB for architecture dependent files. =item INST_BIN Directory to put real binary files during 'make'. These will be copied to INSTALLBIN during 'make install' =item INST_LIB Directory where we put library files of this extension while building it. =item INST_MAN1DIR Directory to hold the man pages at 'make' time =item INST_MAN3DIR Directory to hold the man pages at 'make' time =item INST_SCRIPT Directory where executable files should be installed during 'make'. Defaults to "./blib/script", just to have a dummy location during testing. make install will copy the files in INST_SCRIPT to INSTALLSCRIPT. =item LD Program to be used to link libraries for dynamic loading. Defaults to $Config{ld}. =item LDDLFLAGS Any special flags that might need to be passed to ld to create a shared library suitable for dynamic loading. It is up to the makefile to use it. (See L<Config/lddlflags>) Defaults to $Config{lddlflags}. =item LDFROM Defaults to "$(OBJECT)" and is used in the ld command to specify what files to link/load from (also see dynamic_lib below for how to specify ld flags) =item LIB LIB should only be set at C<perl Makefile.PL> time but is allowed as a MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB and INSTALLSITELIB to that value regardless any explicit setting of those arguments (or of PREFIX). INSTALLARCHLIB and INSTALLSITEARCH are set to the corresponding architecture subdirectory. =item LIBPERL_A The filename of the perllibrary that will be used together with this extension. Defaults to libperl.a. =item LIBS An anonymous array of alternative library specifications to be searched for (in order) until at least one library is found. E.g. 'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"] Mind, that any element of the array contains a complete set of arguments for the ld command. So do not specify 'LIBS' => ["-ltcl", "-ltk", "-lX11"] See ODBM_File/Makefile.PL for an example, where an array is needed. If you specify a scalar as in 'LIBS' => "-ltcl -ltk -lX11" MakeMaker will turn it into an array with one element. =item LICENSE Available in version 6.31 and above. The licensing terms of your distribution. Generally it's "perl_5" for the same license as Perl itself. See L<CPAN::Meta::Spec> for the list of options. Defaults to "unknown". =item LINKTYPE 'static' or 'dynamic' (default unless usedl=undef in config.sh). Should only be used to force static linking (also see linkext below). =item MAGICXS Available in version 6.8305 and above. When this is set to C<1>, C<OBJECT> will be automagically derived from C<O_FILES>. =item MAKE Available in version 6.30_01 and above. Variant of make you intend to run the generated Makefile with. This parameter lets Makefile.PL know what make quirks to account for when generating the Makefile. MakeMaker also honors the MAKE environment variable. This parameter takes precedence. Currently the only significant values are 'dmake' and 'nmake' for Windows users, instructing MakeMaker to generate a Makefile in the flavour of DMake ("Dennis Vadura's Make") or Microsoft NMake respectively. Defaults to $Config{make}, which may go looking for a Make program in your environment. How are you supposed to know what flavour of Make a Makefile has been generated for if you didn't specify a value explicitly? Search the generated Makefile for the definition of the MAKE variable, which is used to recursively invoke the Make utility. That will tell you what Make you're supposed to invoke the Makefile with. =item MAKEAPERL Boolean which tells MakeMaker that it should include the rules to make a perl. This is handled automatically as a switch by MakeMaker. The user normally does not need it. =item MAKEFILE_OLD When 'make clean' or similar is run, the $(FIRST_MAKEFILE) will be backed up at this location. Defaults to $(FIRST_MAKEFILE).old or $(FIRST_MAKEFILE)_old on VMS. =item MAN1PODS Hashref of pod-containing files. MakeMaker will default this to all EXE_FILES files that include POD directives. The files listed here will be converted to man pages and installed as was requested at Configure time. This hash should map POD files (or scripts containing POD) to the man file names under the C<blib/man1/> directory, as in the following example: MAN1PODS => { 'doc/command.pod' => 'blib/man1/command.1', 'scripts/script.pl' => 'blib/man1/script.1', } =item MAN3PODS Hashref that assigns to *.pm and *.pod files the files into which the manpages are to be written. MakeMaker parses all *.pod and *.pm files for POD directives. Files that contain POD will be the default keys of the MAN3PODS hashref. These will then be converted to man pages during C<make> and will be installed during C<make install>. Example similar to MAN1PODS. =item MAP_TARGET If it is intended that a new perl binary be produced, this variable may hold a name for that binary. Defaults to perl =item META_ADD =item META_MERGE Available in version 6.46 and above. A hashref of items to add to the CPAN Meta file (F<META.yml> or F<META.json>). They differ in how they behave if they have the same key as the default metadata. META_ADD will override the default value with its own. META_MERGE will merge its value with the default. Unless you want to override the defaults, prefer META_MERGE so as to get the advantage of any future defaults. Where prereqs are concerned, if META_MERGE is used, prerequisites are merged with their counterpart C<WriteMakefile()> argument (PREREQ_PM is merged into {prereqs}{runtime}{requires}, BUILD_REQUIRES into C<{prereqs}{build}{requires}>, CONFIGURE_REQUIRES into C<{prereqs}{configure}{requires}>, and TEST_REQUIRES into C<{prereqs}{test}{requires})>. When prereqs are specified with META_ADD, the only prerequisites added to the file come from the metadata, not C<WriteMakefile()> arguments. Note that these configuration options are only used for generating F<META.yml> and F<META.json> -- they are NOT used for F<MYMETA.yml> and F<MYMETA.json>. Therefore data in these fields should NOT be used for dynamic (user-side) configuration. By default CPAN Meta specification C<1.4> is used. In order to use CPAN Meta specification C<2.0>, indicate with C<meta-spec> the version you want to use. META_MERGE => { "meta-spec" => { version => 2 }, resources => { repository => { type => 'git', url => 'git://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker.git', web => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker', }, }, }, =item MIN_PERL_VERSION Available in version 6.48 and above. The minimum required version of Perl for this distribution. Either the 5.006001 or the 5.6.1 format is acceptable. =item MYEXTLIB If the extension links to a library that it builds, set this to the name of the library (see SDBM_File) =item NAME The package representing the distribution. For example, C<Test::More> or C<ExtUtils::MakeMaker>. It will be used to derive information about the distribution such as the L</DISTNAME>, installation locations within the Perl library and where XS files will be looked for by default (see L</XS>). C<NAME> I<must> be a valid Perl package name and it I<must> have an associated C<.pm> file. For example, C<Foo::Bar> is a valid C<NAME> and there must exist F<Foo/Bar.pm>. Any XS code should be in F<Bar.xs> unless stated otherwise. Your distribution B<must> have a C<NAME>. =item NEEDS_LINKING MakeMaker will figure out if an extension contains linkable code anywhere down the directory tree, and will set this variable accordingly, but you can speed it up a very little bit if you define this boolean variable yourself. =item NOECHO Command so make does not print the literal commands it's running. By setting it to an empty string you can generate a Makefile that prints all commands. Mainly used in debugging MakeMaker itself. Defaults to C<@>. =item NORECURS Boolean. Attribute to inhibit descending into subdirectories. =item NO_META When true, suppresses the generation and addition to the MANIFEST of the META.yml and META.json module meta-data files during 'make distdir'. Defaults to false. =item NO_MYMETA Available in version 6.57_02 and above. When true, suppresses the generation of MYMETA.yml and MYMETA.json module meta-data files during 'perl Makefile.PL'. Defaults to false. =item NO_PACKLIST Available in version 6.7501 and above. When true, suppresses the writing of C<packlist> files for installs. Defaults to false. =item NO_PERLLOCAL Available in version 6.7501 and above. When true, suppresses the appending of installations to C<perllocal>. Defaults to false. =item NO_VC In general, any generated Makefile checks for the current version of MakeMaker and the version the Makefile was built under. If NO_VC is set, the version check is neglected. Do not write this into your Makefile.PL, use it interactively instead. =item OBJECT List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long string or an array containing all object files, e.g. "tkpBind.o tkpButton.o tkpCanvas.o" or ["tkpBind.o", "tkpButton.o", "tkpCanvas.o"] (Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.) =item OPTIMIZE Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is passed to subdirectory makes. =item PERL Perl binary for tasks that can be done by miniperl. If it contains spaces or other shell metacharacters, it needs to be quoted in a way that protects them, since this value is intended to be inserted in a shell command line in the Makefile. E.g.: # Perl executable lives in "C:/Program Files/Perl/bin" # Normally you don't need to set this yourself! $ perl Makefile.PL PERL='"C:/Program Files/Perl/bin/perl.exe" -w' =item PERL_CORE Set only when MakeMaker is building the extensions of the Perl core distribution. =item PERLMAINCC The call to the program that is able to compile perlmain.c. Defaults to $(CC). =item PERL_ARCHLIB Same as for PERL_LIB, but for architecture dependent files. Used only when MakeMaker is building the extensions of the Perl core distribution (because normally $(PERL_ARCHLIB) is automatically in @INC, and adding it would get in the way of PERL5LIB). =item PERL_LIB Directory containing the Perl library to use. Used only when MakeMaker is building the extensions of the Perl core distribution (because normally $(PERL_LIB) is automatically in @INC, and adding it would get in the way of PERL5LIB). =item PERL_MALLOC_OK defaults to 0. Should be set to TRUE if the extension can work with the memory allocation routines substituted by the Perl malloc() subsystem. This should be applicable to most extensions with exceptions of those =over 4 =item * with bugs in memory allocations which are caught by Perl's malloc(); =item * which interact with the memory allocator in other ways than via malloc(), realloc(), free(), calloc(), sbrk() and brk(); =item * which rely on special alignment which is not provided by Perl's malloc(). =back B<NOTE.> Neglecting to set this flag in I<any one> of the loaded extension nullifies many advantages of Perl's malloc(), such as better usage of system resources, error detection, memory usage reporting, catchable failure of memory allocations, etc. =item PERLPREFIX Directory under which core modules are to be installed. Defaults to $Config{installprefixexp}, falling back to $Config{installprefix}, $Config{prefixexp} or $Config{prefix} should $Config{installprefixexp} not exist. Overridden by PREFIX. =item PERLRUN Use this instead of $(PERL) when you wish to run perl. It will set up extra necessary flags for you. =item PERLRUNINST Use this instead of $(PERL) when you wish to run perl to work with modules. It will add things like -I$(INST_ARCH) and other necessary flags so perl can see the modules you're about to install. =item PERL_SRC Directory containing the Perl source code (use of this should be avoided, it may be undefined) =item PERM_DIR Available in version 6.51_01 and above. Desired permission for directories. Defaults to C<755>. =item PERM_RW Desired permission for read/writable files. Defaults to C<644>. =item PERM_RWX Desired permission for executable files. Defaults to C<755>. =item PL_FILES MakeMaker can run programs to generate files for you at build time. By default any file named *.PL (except Makefile.PL and Build.PL) in the top level directory will be assumed to be a Perl program and run passing its own basename in as an argument. This basename is actually a build target, and there is an intention, but not a requirement, that the *.PL file make the file passed to to as an argument. For example... perl foo.PL foo This behavior can be overridden by supplying your own set of files to search. PL_FILES accepts a hash ref, the key being the file to run and the value is passed in as the first argument when the PL file is run. PL_FILES => {'bin/foobar.PL' => 'bin/foobar'} PL_FILES => {'foo.PL' => 'foo.c'} Would run bin/foobar.PL like this: perl bin/foobar.PL bin/foobar If multiple files from one program are desired an array ref can be used. PL_FILES => {'bin/foobar.PL' => [qw(bin/foobar1 bin/foobar2)]} In this case the program will be run multiple times using each target file. perl bin/foobar.PL bin/foobar1 perl bin/foobar.PL bin/foobar2 If an output file depends on extra input files beside the script itself, a hash ref can be used in version 7.36 and above: PL_FILES => { 'foo.PL' => { 'foo.out' => 'foo.in', 'bar.out' => [qw(bar1.in bar2.in)], } In this case the extra input files will be passed to the program after the target file: perl foo.PL foo.out foo.in perl foo.PL bar.out bar1.in bar2.in PL files are normally run B<after> pm_to_blib and include INST_LIB and INST_ARCH in their C<@INC>, so the just built modules can be accessed... unless the PL file is making a module (or anything else in PM) in which case it is run B<before> pm_to_blib and does not include INST_LIB and INST_ARCH in its C<@INC>. This apparently odd behavior is there for backwards compatibility (and it's somewhat DWIM). The argument passed to the .PL is set up as a target to build in the Makefile. In other sections such as C<postamble> you can specify a dependency on the filename/argument that the .PL is supposed (or will have, now that that is is a dependency) to generate. Note the file to be generated will still be generated and the .PL will still run even without an explicit dependency created by you, since the C<all> target still depends on running all eligible to run.PL files. =item PM Hashref of .pm files and *.pl files to be installed. e.g. {'name_of_file.pm' => '$(INST_LIB)/install_as.pm'} By default this will include *.pm and *.pl and the files found in the PMLIBDIRS directories. Defining PM in the Makefile.PL will override PMLIBDIRS. =item PMLIBDIRS Ref to array of subdirectories containing library files. Defaults to [ 'lib', $(BASEEXT) ]. The directories will be scanned and I<any> files they contain will be installed in the corresponding location in the library. A libscan() method can be used to alter the behaviour. Defining PM in the Makefile.PL will override PMLIBDIRS. (Where BASEEXT is the last component of NAME.) =item PM_FILTER A filter program, in the traditional Unix sense (input from stdin, output to stdout) that is passed on each .pm file during the build (in the pm_to_blib() phase). It is empty by default, meaning no filtering is done. You could use: PM_FILTER => 'perl -ne "print unless /^\\#/"', to remove all the leading comments on the fly during the build. In order to be as portable as possible, please consider using a Perl one-liner rather than Unix (or other) utilities, as above. The # is escaped for the Makefile, since what is going to be generated will then be: PM_FILTER = perl -ne "print unless /^\#/" Without the \ before the #, we'd have the start of a Makefile comment, and the macro would be incorrectly defined. You will almost certainly be better off using the C<PL_FILES> system, instead. See above, or the L<ExtUtils::MakeMaker::FAQ> entry. =item POLLUTE Release 5.005 grandfathered old global symbol names by providing preprocessor macros for extension source compatibility. As of release 5.6, these preprocessor definitions are not available by default. The POLLUTE flag specifies that the old names should still be defined: perl Makefile.PL POLLUTE=1 Please inform the module author if this is necessary to successfully install a module under 5.6 or later. =item PPM_INSTALL_EXEC Name of the executable used to run C<PPM_INSTALL_SCRIPT> below. (e.g. perl) =item PPM_INSTALL_SCRIPT Name of the script that gets executed by the Perl Package Manager after the installation of a package. =item PPM_UNINSTALL_EXEC Available in version 6.8502 and above. Name of the executable used to run C<PPM_UNINSTALL_SCRIPT> below. (e.g. perl) =item PPM_UNINSTALL_SCRIPT Available in version 6.8502 and above. Name of the script that gets executed by the Perl Package Manager before the removal of a package. =item PREFIX This overrides all the default install locations. Man pages, libraries, scripts, etc... MakeMaker will try to make an educated guess about where to place things under the new PREFIX based on your Config defaults. Failing that, it will fall back to a structure which should be sensible for your platform. If you specify LIB or any INSTALL* variables they will not be affected by the PREFIX. =item PREREQ_FATAL Bool. If this parameter is true, failing to have the required modules (or the right versions thereof) will be fatal. C<perl Makefile.PL> will C<die> instead of simply informing the user of the missing dependencies. It is I<extremely> rare to have to use C<PREREQ_FATAL>. Its use by module authors is I<strongly discouraged> and should never be used lightly. For dependencies that are required in order to run C<Makefile.PL>, see C<CONFIGURE_REQUIRES>. Module installation tools have ways of resolving unmet dependencies but to do that they need a F<Makefile>. Using C<PREREQ_FATAL> breaks this. That's bad. Assuming you have good test coverage, your tests should fail with missing dependencies informing the user more strongly that something is wrong. You can write a F<t/00compile.t> test which will simply check that your code compiles and stop "make test" prematurely if it doesn't. See L<Test::More/BAIL_OUT> for more details. =item PREREQ_PM A hash of modules that are needed to run your module. The keys are the module names ie. Test::More, and the minimum version is the value. If the required version number is 0 any version will do. The versions given may be a Perl v-string (see L<version>) or a range (see L<CPAN::Meta::Requirements>). This will go into the C<requires> field of your F<META.yml> and the C<runtime> of the C<prereqs> field of your F<META.json>. PREREQ_PM => { # Require Test::More at least 0.47 "Test::More" => "0.47", # Require any version of Acme::Buffy "Acme::Buffy" => 0, } =item PREREQ_PRINT Bool. If this parameter is true, the prerequisites will be printed to stdout and MakeMaker will exit. The output format is an evalable hash ref. $PREREQ_PM = { 'A::B' => Vers1, 'C::D' => Vers2, ... }; If a distribution defines a minimal required perl version, this is added to the output as an additional line of the form: $MIN_PERL_VERSION = '5.008001'; If BUILD_REQUIRES is not empty, it will be dumped as $BUILD_REQUIRES hashref. =item PRINT_PREREQ RedHatism for C<PREREQ_PRINT>. The output format is different, though: perl(A::B)>=Vers1 perl(C::D)>=Vers2 ... A minimal required perl version, if present, will look like this: perl(perl)>=5.008001 =item SITEPREFIX Like PERLPREFIX, but only for the site install locations. Defaults to $Config{siteprefixexp}. Perls prior to 5.6.0 didn't have an explicit siteprefix in the Config. In those cases $Config{installprefix} will be used. Overridable by PREFIX =item SIGN Available in version 6.18 and above. When true, perform the generation and addition to the MANIFEST of the SIGNATURE file in the distdir during 'make distdir', via 'cpansign -s'. Note that you need to install the Module::Signature module to perform this operation. Defaults to false. =item SKIP Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the Makefile. Caution! Do not use the SKIP attribute for the negligible speedup. It may seriously damage the resulting Makefile. Only use it if you really need it. =item TEST_REQUIRES Available in version 6.64 and above. A hash of modules that are needed to test your module but not run or build it. This will go into the C<build_requires> field of your F<META.yml> and the C<test> of the C<prereqs> field of your F<META.json>. The format is the same as PREREQ_PM. =item TYPEMAPS Ref to array of typemap file names. Use this when the typemaps are in some directory other than the current directory or when they are not named B<typemap>. The last typemap in the list takes precedence. A typemap in the current directory has highest precedence, even if it isn't listed in TYPEMAPS. The default system typemap has lowest precedence. =item VENDORPREFIX Like PERLPREFIX, but only for the vendor install locations. Defaults to $Config{vendorprefixexp}. Overridable by PREFIX =item VERBINST If true, make install will be verbose =item VERSION Your version number for distributing the package. This defaults to 0.1. =item VERSION_FROM Instead of specifying the VERSION in the Makefile.PL you can let MakeMaker parse a file to determine the version number. The parsing routine requires that the file named by VERSION_FROM contains one single line to compute the version number. The first line in the file that contains something like a $VERSION assignment or C<package Name VERSION> will be used. The following lines will be parsed o.k.: # Good package Foo::Bar 1.23; # 1.23 $VERSION = '1.00'; # 1.00 *VERSION = \'1.01'; # 1.01 ($VERSION) = q$Revision$ =~ /(\d+)/g; # The digits in $Revision$ $FOO::VERSION = '1.10'; # 1.10 *FOO::VERSION = \'1.11'; # 1.11 but these will fail: # Bad my $VERSION = '1.01'; local $VERSION = '1.02'; local $FOO::VERSION = '1.30'; (Putting C<my> or C<local> on the preceding line will work o.k.) "Version strings" are incompatible and should not be used. # Bad $VERSION = 1.2.3; $VERSION = v1.2.3; L<version> objects are fine. As of MakeMaker 6.35 version.pm will be automatically loaded, but you must declare the dependency on version.pm. For compatibility with older MakeMaker you should load on the same line as $VERSION is declared. # All on one line use version; our $VERSION = qv(1.2.3); The file named in VERSION_FROM is not added as a dependency to Makefile. This is not really correct, but it would be a major pain during development to have to rewrite the Makefile for any smallish change in that file. If you want to make sure that the Makefile contains the correct VERSION macro after any change of the file, you would have to do something like depend => { Makefile => '$(VERSION_FROM)' } See attribute C<depend> below. =item VERSION_SYM A sanitized VERSION with . replaced by _. For places where . has special meaning (some filesystems, RCS labels, etc...) =item XS Hashref of .xs files. MakeMaker will default this. e.g. {'name_of_file.xs' => 'name_of_file.c'} The .c files will automatically be included in the list of files deleted by a make clean. =item XSBUILD Available in version 7.12 and above. Hashref with options controlling the operation of C<XSMULTI>: { xs => { all => { # options applying to all .xs files for this distribution }, 'lib/Class/Name/File' => { # specifically for this file DEFINE => '-Dfunktastic', # defines for only this file INC => "-I$funkyliblocation", # include flags for only this file # OBJECT => 'lib/Class/Name/File$(OBJ_EXT)', # default LDFROM => "lib/Class/Name/File\$(OBJ_EXT) $otherfile\$(OBJ_EXT)", # what's linked }, }, } Note C<xs> is the file-extension. More possibilities may arise in the future. Note that object names are specified without their XS extension. C<LDFROM> defaults to the same as C<OBJECT>. C<OBJECT> defaults to, for C<XSMULTI>, just the XS filename with the extension replaced with the compiler-specific object-file extension. The distinction between C<OBJECT> and C<LDFROM>: C<OBJECT> is the make target, so make will try to build it. However, C<LDFROM> is what will actually be linked together to make the shared object or static library (SO/SL), so if you override it, make sure it includes what you want to make the final SO/SL, almost certainly including the XS basename with C<$(OBJ_EXT)> appended. =item XSMULTI Available in version 7.12 and above. When this is set to C<1>, multiple XS files may be placed under F<lib/> next to their corresponding C<*.pm> files (this is essential for compiling with the correct C<VERSION> values). This feature should be considered experimental, and details of it may change. This feature was inspired by, and small portions of code copied from, L<ExtUtils::MakeMaker::BigHelper>. Hopefully this feature will render that module mainly obsolete. =item XSOPT String of options to pass to xsubpp. This might include C<-C++> or C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for that purpose. =item XSPROTOARG May be set to C<-prototypes>, C<-noprototypes> or the empty string. The empty string is equivalent to the xsubpp default, or C<-noprototypes>. See the xsubpp documentation for details. MakeMaker defaults to the empty string. =item XS_VERSION Your version number for the .xs file of this package. This defaults to the value of the VERSION attribute. =back =head2 Additional lowercase attributes can be used to pass parameters to the methods which implement that part of the Makefile. Parameters are specified as a hash ref but are passed to the method as a hash. =over 2 =item clean {FILES => "*.xyz foo"} =item depend {ANY_TARGET => ANY_DEPENDENCY, ...} (ANY_TARGET must not be given a double-colon rule by MakeMaker.) =item dist {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip', ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' } If you specify COMPRESS, then SUFFIX should also be altered, as it is needed to tell make the target file of the compression. Setting DIST_CP to ln can be useful, if you need to preserve the timestamps on your files. DIST_CP can take the values 'cp', which copies the file, 'ln', which links the file, and 'best' which copies symbolic links and links the rest. Default is 'best'. =item dynamic_lib {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} =item linkext {LINKTYPE => 'static', 'dynamic' or ''} NB: Extensions that have nothing but *.pm files had to say {LINKTYPE => ''} with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line can be deleted safely. MakeMaker recognizes when there's nothing to be linked. =item macro {ANY_MACRO => ANY_VALUE, ...} =item postamble Anything put here will be passed to L<MY::postamble()|ExtUtils::MM_Any/postamble (o)> if you have one. =item realclean {FILES => '$(INST_ARCHAUTODIR)/*.xyz'} =item test Specify the targets for testing. {TESTS => 't/*.t'} C<RECURSIVE_TEST_FILES> can be used to include all directories recursively under C<t> that contain C<.t> files. It will be ignored if you provide your own C<TESTS> attribute, defaults to false. {RECURSIVE_TEST_FILES=>1} This is supported since 6.76 =item tool_autosplit {MAXLEN => 8} =back =head2 Overriding MakeMaker Methods If you cannot achieve the desired Makefile behaviour by specifying attributes you may define private subroutines in the Makefile.PL. Each subroutine returns the text it wishes to have written to the Makefile. To override a section of the Makefile you can either say: sub MY::c_o { "new literal text" } or you can edit the default by saying something like: package MY; # so that "SUPER" works right sub c_o { my $inherited = shift->SUPER::c_o(@_); $inherited =~ s/old text/new text/; $inherited; } If you are running experiments with embedding perl as a library into other applications, you might find MakeMaker is not sufficient. You'd better have a look at L<ExtUtils::Embed> which is a collection of utilities for embedding. If you still need a different solution, try to develop another subroutine that fits your needs and submit the diffs to C<makemaker@perl.org> For a complete description of all MakeMaker methods see L<ExtUtils::MM_Unix>. Here is a simple example of how to add a new target to the generated Makefile: sub MY::postamble { return <<'MAKE_FRAG'; $(MYEXTLIB): sdbm/Makefile cd sdbm && $(MAKE) all MAKE_FRAG } =head2 The End Of Cargo Cult Programming WriteMakefile() now does some basic sanity checks on its parameters to protect against typos and malformatted values. This means some things which happened to work in the past will now throw warnings and possibly produce internal errors. Some of the most common mistakes: =over 2 =item C<< MAN3PODS => ' ' >> This is commonly used to suppress the creation of man pages. MAN3PODS takes a hash ref not a string, but the above worked by accident in old versions of MakeMaker. The correct code is C<< MAN3PODS => { } >>. =back =head2 Hintsfile support MakeMaker.pm uses the architecture-specific information from Config.pm. In addition it evaluates architecture specific hints files in a C<hints/> directory. The hints files are expected to be named like their counterparts in C<PERL_SRC/hints>, but with an C<.pl> file name extension (eg. C<next_3_2.pl>). They are simply C<eval>ed by MakeMaker within the WriteMakefile() subroutine, and can be used to execute commands as well as to include special variables. The rules which hintsfile is chosen are the same as in Configure. The hintsfile is eval()ed immediately after the arguments given to WriteMakefile are stuffed into a hash reference $self but before this reference becomes blessed. So if you want to do the equivalent to override or create an attribute you would say something like $self->{LIBS} = ['-ldbm -lucb -lc']; =head2 Distribution Support For authors of extensions MakeMaker provides several Makefile targets. Most of the support comes from the L<ExtUtils::Manifest> module, where additional documentation can be found. =over 4 =item make distcheck reports which files are below the build directory but not in the MANIFEST file and vice versa. (See L<ExtUtils::Manifest/fullcheck> for details) =item make skipcheck reports which files are skipped due to the entries in the C<MANIFEST.SKIP> file (See L<ExtUtils::Manifest/skipcheck> for details) =item make distclean does a realclean first and then the distcheck. Note that this is not needed to build a new distribution as long as you are sure that the MANIFEST file is ok. =item make veryclean does a realclean first and then removes backup files such as C<*~>, C<*.bak>, C<*.old> and C<*.orig> =item make manifest rewrites the MANIFEST file, adding all remaining files found (See L<ExtUtils::Manifest/mkmanifest> for details) =item make distdir Copies all the files that are in the MANIFEST file to a newly created directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory exists, it will be removed first. Additionally, it will create META.yml and META.json module meta-data file in the distdir and add this to the distdir's MANIFEST. You can shut this behavior off with the NO_META flag. =item make disttest Makes a distdir first, and runs a C<perl Makefile.PL>, a make, and a make test in that directory. =item make tardist First does a distdir. Then a command $(PREOP) which defaults to a null command, followed by $(TO_UNIX), which defaults to a null command under UNIX, and will convert files in distribution directory to UNIX format otherwise. Next it runs C<tar> on that directory into a tarfile and deletes the directory. Finishes with a command $(POSTOP) which defaults to a null command. =item make dist Defaults to $(DIST_DEFAULT) which in turn defaults to tardist. =item make uutardist Runs a tardist first and uuencodes the tarfile. =item make shdist First does a distdir. Then a command $(PREOP) which defaults to a null command. Next it runs C<shar> on that directory into a sharfile and deletes the intermediate directory again. Finishes with a command $(POSTOP) which defaults to a null command. Note: For shdist to work properly a C<shar> program that can handle directories is mandatory. =item make zipdist First does a distdir. Then a command $(PREOP) which defaults to a null command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a zipfile. Then deletes that directory. Finishes with a command $(POSTOP) which defaults to a null command. =item make ci Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file. =back Customization of the dist targets can be done by specifying a hash reference to the dist attribute of the WriteMakefile call. The following parameters are recognized: CI ('ci -u') COMPRESS ('gzip --best') POSTOP ('@ :') PREOP ('@ :') TO_UNIX (depends on the system) RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):') SHAR ('shar') SUFFIX ('.gz') TAR ('tar') TARFLAGS ('cvf') ZIP ('zip') ZIPFLAGS ('-r') An example: WriteMakefile( ...other options... dist => { COMPRESS => "bzip2", SUFFIX => ".bz2" } ); =head2 Module Meta-Data (META and MYMETA) Long plaguing users of MakeMaker based modules has been the problem of getting basic information about the module out of the sources I<without> running the F<Makefile.PL> and doing a bunch of messy heuristics on the resulting F<Makefile>. Over the years, it has become standard to keep this information in one or more CPAN Meta files distributed with each distribution. The original format of CPAN Meta files was L<YAML> and the corresponding file was called F<META.yml>. In 2010, version 2 of the L<CPAN::Meta::Spec> was released, which mandates JSON format for the metadata in order to overcome certain compatibility issues between YAML serializers and to avoid breaking older clients unable to handle a new version of the spec. The L<CPAN::Meta> library is now standard for accessing old and new-style Meta files. If L<CPAN::Meta> is installed, MakeMaker will automatically generate F<META.json> and F<META.yml> files for you and add them to your F<MANIFEST> as part of the 'distdir' target (and thus the 'dist' target). This is intended to seamlessly and rapidly populate CPAN with module meta-data. If you wish to shut this feature off, set the C<NO_META> C<WriteMakefile()> flag to true. At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agreed to use the CPAN Meta format to communicate post-configuration requirements between toolchain components. These files, F<MYMETA.json> and F<MYMETA.yml>, are generated when F<Makefile.PL> generates a F<Makefile> (if L<CPAN::Meta> is installed). Clients like L<CPAN> or L<CPANPLUS> will read these files to see what prerequisites must be fulfilled before building or testing the distribution. If you wish to shut this feature off, set the C<NO_MYMETA> C<WriteMakeFile()> flag to true. =head2 Disabling an extension If some events detected in F<Makefile.PL> imply that there is no way to create the Module, but this is a normal state of things, then you can create a F<Makefile> which does nothing, but succeeds on all the "usual" build targets. To do so, use use ExtUtils::MakeMaker qw(WriteEmptyMakefile); WriteEmptyMakefile(); instead of WriteMakefile(). This may be useful if other modules expect this module to be I<built> OK, as opposed to I<work> OK (say, this system-dependent module builds in a subdirectory of some other distribution, or is listed as a dependency in a CPAN::Bundle, but the functionality is supported by different means on the current architecture). =head2 Other Handy Functions =over 4 =item prompt my $value = prompt($message); my $value = prompt($message, $default); The C<prompt()> function provides an easy way to request user input used to write a makefile. It displays the $message as a prompt for input. If a $default is provided it will be used as a default. The function returns the $value selected by the user. If C<prompt()> detects that it is not running interactively and there is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable is set to true, the $default will be used without prompting. This prevents automated processes from blocking on user input. If no $default is provided an empty string will be used instead. =item os_unsupported os_unsupported(); os_unsupported if $^O eq 'MSWin32'; The C<os_unsupported()> function provides a way to correctly exit your C<Makefile.PL> before calling C<WriteMakefile>. It is essentially a C<die> with the message "OS unsupported". This is supported since 7.26 =back =head2 Supported versions of Perl Please note that while this module works on Perl 5.6, it is no longer being routinely tested on 5.6 - the earliest Perl version being routinely tested, and expressly supported, is 5.8.1. However, patches to repair any breakage on 5.6 are still being accepted. =head1 ENVIRONMENT =over 4 =item PERL_MM_OPT Command line options used by C<MakeMaker-E<gt>new()>, and thus by C<WriteMakefile()>. The string is split as the shell would, and the result is processed before any actual command line arguments are processed. PERL_MM_OPT='CCFLAGS="-Wl,-rpath -Wl,/foo/bar/lib" LIBS="-lwibble -lwobble"' =item PERL_MM_USE_DEFAULT If set to a true value then MakeMaker's prompt function will always return the default without waiting for user input. =item PERL_CORE Same as the PERL_CORE parameter. The parameter overrides this. =back =head1 SEE ALSO L<Module::Build> is a pure-Perl alternative to MakeMaker which does not rely on make or any other external utility. It may be easier to extend to suit your needs. L<Module::Build::Tiny> is a minimal pure-Perl alternative to MakeMaker that follows the Build.PL protocol of Module::Build but without its complexity and cruft, implementing only the installation of the module and leaving authoring to L<mbtiny> or other authoring tools. L<Module::Install> is a (now discouraged) wrapper around MakeMaker which adds features not normally available. L<ExtUtils::ModuleMaker> and L<Module::Starter> are both modules to help you setup your distribution. L<CPAN::Meta> and L<CPAN::Meta::Spec> explain CPAN Meta files in detail. L<File::ShareDir::Install> makes it easy to install static, sometimes also referred to as 'shared' files. L<File::ShareDir> helps accessing the shared files after installation. L<Test::File::ShareDir> helps when writing tests to use the shared files both before and after installation. L<Dist::Zilla> is an authoring tool which allows great customization and extensibility of the author experience, relying on the existing install tools like ExtUtils::MakeMaker only for installation. L<Dist::Milla> is a Dist::Zilla bundle that greatly simplifies common usage. L<Minilla> is a minimal authoring tool that does the same things as Dist::Milla without the overhead of Dist::Zilla. =head1 AUTHORS Andy Dougherty C<doughera@lafayette.edu>, Andreas KE<ouml>nig C<andreas.koenig@mind.de>, Tim Bunce C<timb@cpan.org>. VMS support by Charles Bailey C<bailey@newman.upenn.edu>. OS/2 support by Ilya Zakharevich C<ilya@math.ohio-state.edu>. Currently maintained by Michael G Schwern C<schwern@pobox.com> Send patches and ideas to C<makemaker@perl.org>. Send bug reports via http://rt.cpan.org/. Please send your generated Makefile along with your report. For more up-to-date information, see L<https://metacpan.org/release/ExtUtils-MakeMaker>. Repository available at L<https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker>. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<http://www.perl.com/perl/misc/Artistic.html> =cut perl5/ExtUtils/Mkbootstrap.pm 0000444 00000006312 14711220071 0012212 0 ustar 00 package ExtUtils::Mkbootstrap; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require Exporter; our @ISA = ('Exporter'); our @EXPORT = ('&Mkbootstrap'); use Config; our $Verbose = 0; sub Mkbootstrap { my($baseext, @bsloadlibs)=@_; @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs print " bsloadlibs=@bsloadlibs\n" if $Verbose; # We need DynaLoader here because we and/or the *_BS file may # call dl_findfile(). We don't say `use' here because when # first building perl extensions the DynaLoader will not have # been built when MakeMaker gets first used. require DynaLoader; rename "$baseext.bs", "$baseext.bso" if -s "$baseext.bs"; if (-f "${baseext}_BS"){ $_ = "${baseext}_BS"; package DynaLoader; # execute code as if in DynaLoader no strict 'vars'; local($osname, $dlsrc) = (); # avoid warnings ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)}; $bscode = ""; unshift @INC, "."; require $_; shift @INC; } if ($Config{'dlsrc'} =~ /^dl_dld/){ package DynaLoader; no strict 'vars'; push(@dl_resolve_using, dl_findfile('-lc')); } my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using); my($method) = ''; if (@all || (defined $DynaLoader::bscode && length $DynaLoader::bscode)){ open my $bs, ">", "$baseext.bs" or die "Unable to open $baseext.bs: $!"; print "Writing $baseext.bs\n"; print " containing: @all" if $Verbose; print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; print $bs "# Do not edit this file, changes will be lost.\n"; print $bs "# This file was automatically generated by the\n"; print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; if (@all) { print $bs "\@DynaLoader::dl_resolve_using = "; # If @all contains names in the form -lxxx or -Lxxx then it's asking for # runtime library location so we automatically add a call to dl_findfile() if (" @all" =~ m/ -[lLR]/){ print $bs " dl_findfile(qw(\n @all\n ));\n"; } else { print $bs " qw(@all);\n"; } } # write extra code if *_BS says so print $bs $DynaLoader::bscode if $DynaLoader::bscode; print $bs "\n1;\n"; close $bs; } } 1; __END__ =head1 NAME ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader =head1 SYNOPSIS Mkbootstrap =head1 DESCRIPTION Mkbootstrap typically gets called from an extension Makefile. There is no C<*.bs> file supplied with the extension. Instead, there may be a C<*_BS> file which has code for the special cases, like posix for berkeley db on the NeXT. This file will get parsed, and produce a maybe empty C<@DynaLoader::dl_resolve_using> array for the current architecture. That will be extended by $BSLOADLIBS, which was computed by ExtUtils::Liblist::ext(). If this array still is empty, we do nothing, else we write a .bs file with an C<@DynaLoader::dl_resolve_using> array. The C<*_BS> file can put some code into the generated C<*.bs> file by placing it in C<$bscode>. This is a handy 'escape' mechanism that may prove useful in complex situations. If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then Mkbootstrap will automatically add a dl_findfile() call to the generated C<*.bs> file. =cut perl5/ExtUtils/MM_Win32.pm 0000444 00000035326 14711220072 0011210 0 ustar 00 package ExtUtils::MM_Win32; use strict; use warnings; =head1 NAME ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 SYNOPSIS use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed =head1 DESCRIPTION See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. =cut use ExtUtils::MakeMaker::Config; use File::Basename; use File::Spec; use ExtUtils::MakeMaker qw(neatvalue _sprintf562); require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); our $VERSION = '7.62'; $VERSION =~ tr/_//d; $ENV{EMXSHELL} = 'sh'; # to run `commands` my ( $BORLAND, $GCC, $MSVC ) = _identify_compiler_environment( \%Config ); sub _identify_compiler_environment { my ( $config ) = @_; my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0; my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0; my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C return ( $BORLAND, $GCC, $MSVC ); } =head2 Overridden methods =over 4 =item B<dlsyms> =cut sub dlsyms { my($self,%attribs) = @_; return '' if $self->{SKIPHASH}{'dynamic'}; $self->xs_dlsyms_iterator(\%attribs); } =item xs_dlsyms_ext On Win32, is C<.def>. =cut sub xs_dlsyms_ext { '.def'; } =item replace_manpage_separator Changes the path separator with . =cut sub replace_manpage_separator { my($self,$man) = @_; $man =~ s,[/\\]+,.,g; $man; } =item B<maybe_command> Since Windows has nothing as simple as an executable bit, we check the file extension. The PATHEXT env variable will be used to get a list of extensions that might indicate a command, otherwise .com, .exe, .bat and .cmd will be used by default. =cut sub maybe_command { my($self,$file) = @_; my @e = exists($ENV{'PATHEXT'}) ? split(/;/, $ENV{PATHEXT}) : qw(.com .exe .bat .cmd); my $e = ''; for (@e) { $e .= "\Q$_\E|" } chop $e; # see if file ends in one of the known extensions if ($file =~ /($e)$/i) { return $file if -e $file; } else { for (@e) { return "$file$_" if -e "$file$_"; } } return; } =item B<init_DIRFILESEP> Using \ for Windows, except for "gmake" where it is /. =cut sub init_DIRFILESEP { my($self) = shift; # The ^ makes sure its not interpreted as an escape in nmake $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' : $self->is_make_type('dmake') ? '\\\\' : $self->is_make_type('gmake') ? '/' : '\\'; } =item init_tools Override some of the slower, portable commands with Windows specific ones. =cut sub init_tools { my ($self) = @_; $self->{NOOP} ||= 'rem'; $self->{DEV_NULL} ||= '> NUL'; $self->{FIXIN} ||= $self->{PERL_CORE} ? "\$(PERLRUN) -I$self->{PERL_SRC}\\cpan\\ExtUtils-PL2Bat\\lib $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" : 'pl2bat.bat'; $self->SUPER::init_tools; # Setting SHELL from $Config{sh} can break dmake. Its ok without it. delete $self->{SHELL}; return; } =item init_others Override the default link and compile tools. LDLOADLIBS's default is changed to $Config{libs}. Adjustments are made for Borland's quirks needing -L to come first. =cut sub init_others { my $self = shift; $self->{LD} ||= 'link'; $self->{AR} ||= 'lib'; $self->SUPER::init_others; $self->{LDLOADLIBS} ||= $Config{libs}; # -Lfoo must come first for Borland, so we put it in LDDLFLAGS if ($BORLAND) { my $libs = $self->{LDLOADLIBS}; my $libpath = ''; while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) { $libpath .= ' ' if length $libpath; $libpath .= $1; } $self->{LDLOADLIBS} = $libs; $self->{LDDLFLAGS} ||= $Config{lddlflags}; $self->{LDDLFLAGS} .= " $libpath"; } return; } =item init_platform Add MM_Win32_VERSION. =item platform_constants =cut sub init_platform { my($self) = shift; $self->{MM_Win32_VERSION} = $VERSION; return; } sub platform_constants { my($self) = shift; my $make_frag = ''; foreach my $macro (qw(MM_Win32_VERSION)) { next unless defined $self->{$macro}; $make_frag .= "$macro = $self->{$macro}\n"; } return $make_frag; } =item specify_shell Set SHELL to $ENV{COMSPEC} only if make is type 'gmake'. =cut sub specify_shell { my $self = shift; return '' unless $self->is_make_type('gmake'); "\nSHELL = $ENV{COMSPEC}\n"; } =item constants Add MAXLINELENGTH for dmake before all the constants are output. =cut sub constants { my $self = shift; my $make_text = $self->SUPER::constants; return $make_text unless $self->is_make_type('dmake'); # dmake won't read any single "line" (even those with escaped newlines) # larger than a certain size which can be as small as 8k. PM_TO_BLIB # on large modules like DateTime::TimeZone can create lines over 32k. # So we'll crank it up to a <ironic>WHOPPING</ironic> 64k. # # This has to come here before all the constants and not in # platform_constants which is after constants. my $size = $self->{MAXLINELENGTH} || 800000; my $prefix = qq{ # Get dmake to read long commands like PM_TO_BLIB MAXLINELENGTH = $size }; return $prefix . $make_text; } =item special_targets Add .USESHELL target for dmake. =cut sub special_targets { my($self) = @_; my $make_frag = $self->SUPER::special_targets; $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake'); .USESHELL : MAKE_FRAG return $make_frag; } =item static_lib_pure_cmd Defines how to run the archive utility =cut sub static_lib_pure_cmd { my ($self, $from) = @_; $from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from : ($GCC ? '-ru $@ ' . $from : '-out:$@ ' . $from)); } =item dynamic_lib Methods are overridden here: not dynamic_lib itself, but the utility ones that do the OS-specific work. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist; if ($GCC) { # per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer # uses dlltool - relies on post 2002 MinGW # 1 2 push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom; $(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base EOF } elsif ($BORLAND) { my $ldargs = $self->is_make_type('dmake') ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),} : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),}; my $subbed; if ($exportlist eq '$(EXPORT_LIST)') { $subbed = $self->is_make_type('dmake') ? q{$(EXPORT_LIST:s,/,\,)} : q{$(subst /,\,$(EXPORT_LIST))}; } else { # in XSMULTI, exportlist is per-XS, so have to sub in perl not make ($subbed = $exportlist) =~ s#/#\\#g; } push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed; $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES) EOF } else { # VC push @m, sprintf <<'EOF', $ldfrom, $exportlist; $(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s EOF # Embed the manifest file if it exists push(@m, q{ if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 if exist $@.manifest del $@.manifest}); } push @m, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; join '', @m; } sub xs_dynamic_lib_macros { my ($self, $attribs) = @_; my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; # This section creates the dynamically loadable objects from relevant # objects and possibly $(MYEXTLIB). OTHERLDFLAGS = %s INST_DYNAMIC_DEP = %s EOF } =item extra_clean_files Clean out some extra dll.{base,exp} files which might be generated by gcc. Otherwise, take out all *.pdb files. =cut sub extra_clean_files { my $self = shift; return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb'); } =item init_linker =cut sub init_linker { my $self = shift; $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}"; $self->{PERL_ARCHIVEDEP} = "\$(PERL_INCDEP)\\$Config{libperl}"; $self->{PERL_ARCHIVE_AFTER} = ''; $self->{EXPORT_LIST} = '$(BASEEXT).def'; } =item perl_script Checks for the perl program under several common perl extensions. =cut sub perl_script { my($self,$file) = @_; return $file if -r $file && -f _; return "$file.pl" if -r "$file.pl" && -f _; return "$file.plx" if -r "$file.plx" && -f _; return "$file.bat" if -r "$file.bat" && -f _; return; } sub can_dep_space { my ($self) = @_; return 0 unless $self->can_load_xs; require Win32; require File::Spec; my ($vol, $dir) = File::Spec->splitpath($INC{'ExtUtils/MakeMaker.pm'}); # can_dep_space via GetShortPathName, if short paths are supported my $canary = Win32::GetShortPathName(File::Spec->catpath($vol, $dir, 'MakeMaker.pm')); (undef, undef, my $file) = File::Spec->splitpath($canary); return (length $file > 11) ? 0 : 1; } =item quote_dep =cut sub quote_dep { my ($self, $arg) = @_; if ($arg =~ / / and not $self->is_make_type('gmake')) { require Win32; $arg = Win32::GetShortPathName($arg); die <<EOF if not defined $arg or $arg =~ / /; Tried to use make dependency with space for non-GNU make: '$arg' Fallback to short pathname failed. EOF return $arg; } return $self->SUPER::quote_dep($arg); } =item xs_obj_opt Override to fixup -o flags for MSVC. =cut sub xs_obj_opt { my ($self, $output_file) = @_; ($MSVC ? "/Fo" : "-o ") . $output_file; } =item pasthru All we send is -nologo to nmake to prevent it from printing its damned banner. =cut sub pasthru { my($self) = shift; my $old = $self->SUPER::pasthru; return $old unless $self->is_make_type('nmake'); $old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /; $old; } =item arch_check (override) Normalize all arguments for consistency of comparison. =cut sub arch_check { my $self = shift; # Win32 is an XS module, minperl won't have it. # arch_check() is not critical, so just fake it. return 1 unless $self->can_load_xs; return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_); } sub _normalize_path_name { my $self = shift; my $file = shift; require Win32; my $short = Win32::GetShortPathName($file); return defined $short ? lc $short : lc $file; } =item oneliner These are based on what command.com does on Win98. They may be wrong for other Windows shells, I don't know. =cut sub oneliner { my($self, $cmd, $switches) = @_; $switches = [] unless defined $switches; # Strip leading and trailing newlines $cmd =~ s{^\n+}{}; $cmd =~ s{\n+$}{}; $cmd = $self->quote_literal($cmd); $cmd = $self->escape_newlines($cmd); $switches = join ' ', @$switches; return qq{\$(ABSPERLRUN) $switches -e $cmd --}; } sub quote_literal { my($self, $text, $opts) = @_; $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP # Apply the Microsoft C/C++ parsing rules $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\" $text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\" $text =~ s{(?<!\\)"}{\\"}g; # " -> \" $text = qq{"$text"} if $text =~ /[ \t#]/; # hash because gmake 4.2.1 # Apply the Command Prompt parsing rules (cmd.exe) my @text = split /("[^"]*")/, $text; # We should also escape parentheses, but it breaks one-liners containing # $(MACRO)s in makefiles. s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text; $text = join('', @text); # dmake expands {{ to { and }} to }. if( $self->is_make_type('dmake') ) { $text =~ s/{/{{/g; $text =~ s/}/}}/g; } $text = $opts->{allow_variables} ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); return $text; } sub escape_newlines { my($self, $text) = @_; # Escape newlines $text =~ s{\n}{\\\n}g; return $text; } =item cd dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It wants: cd dir1\dir2 command another_command cd ..\.. =cut sub cd { my($self, $dir, @cmds) = @_; return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake'); my $cmd = join "\n\t", map "$_", @cmds; my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir)); # No leading tab and no trailing newline makes for easier embedding. my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs; cd %s %s cd %s MAKE_FRAG chomp $make_frag; return $make_frag; } =item max_exec_len nmake 1.50 limits command length to 2048 characters. =cut sub max_exec_len { my $self = shift; return $self->{_MAX_EXEC_LEN} ||= 2 * 1024; } =item os_flavor Windows is Win32. =cut sub os_flavor { return('Win32'); } =item dbgoutflag Returns a CC flag that tells the CC to emit a separate debugging symbol file when compiling an object file. =cut sub dbgoutflag { $MSVC ? '-Fd$(*).pdb' : ''; } =item cflags Defines the PERLDLL symbol if we are configured for static building since all code destined for the perl5xx.dll must be compiled with the PERLDLL symbol defined. =cut sub cflags { my($self,$libperl)=@_; return $self->{CFLAGS} if $self->{CFLAGS}; return '' unless $self->needs_linking(); my $base = $self->SUPER::cflags($libperl); foreach (split /\n/, $base) { /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; }; $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static'); return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} }; } =item make_type Returns a suitable string describing the type of makefile being written. =cut sub make_type { my ($self) = @_; my $make = $self->make; $make = +( File::Spec->splitpath( $make ) )[-1]; $make =~ s!\.exe$!!i; if ( $make =~ m![^A-Z0-9]!i ) { ($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make; } return "$make-style"; } 1; __END__ =back perl5/ExtUtils/ParseXS.pm 0000444 00000202014 14711220073 0011231 0 ustar 00 package ExtUtils::ParseXS; use strict; use 5.006001; use Cwd; use Config; use Exporter 'import'; use File::Basename; use File::Spec; use Symbol; our $VERSION; BEGIN { $VERSION = '3.35'; } use ExtUtils::ParseXS::Constants $VERSION; use ExtUtils::ParseXS::CountLines $VERSION; use ExtUtils::ParseXS::Utilities $VERSION; use ExtUtils::ParseXS::Eval $VERSION; $VERSION = eval $VERSION if $VERSION =~ /_/; use ExtUtils::ParseXS::Utilities qw( standard_typemap_locations trim_whitespace C_string valid_proto_string process_typemaps map_type standard_XS_defs assign_func_args analyze_preprocessor_statements set_cond Warn current_line_number blurt death check_conditional_preprocessor_statements escape_file_for_line_directive report_typemap_failure ); our @EXPORT_OK = qw( process_file report_error_count ); ############################## # A number of "constants" our ($C_group_rex, $C_arg); # Group in C (no support for comments or literals) $C_group_rex = qr/ [({\[] (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* [)}\]] /x; # Chunk in C without comma at toplevel (no comments): $C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) | (??{ $C_group_rex }) | " (?: (?> [^\\"]+ ) | \\. )* " # String literal | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal )* /xs; # "impossible" keyword (multiple newline) my $END = "!End!\n\n"; # Match an XS Keyword my $BLOCK_regexp = '\s*(' . $ExtUtils::ParseXS::Constants::XSKeywordsAlternation . "|$END)\\s*:"; sub new { return bless {} => shift; } our $Singleton = __PACKAGE__->new; sub process_file { my $self; # Allow for $package->process_file(%hash), $obj->process_file, and process_file() if (@_ % 2) { my $invocant = shift; $self = ref($invocant) ? $invocant : $invocant->new; } else { $self = $Singleton; } my %options = @_; $self->{ProtoUsed} = exists $options{prototypes}; # Set defaults. my %args = ( argtypes => 1, csuffix => '.c', except => 0, hiertype => 0, inout => 1, linenumbers => 1, optimize => 1, output => \*STDOUT, prototypes => 0, typemap => [], versioncheck => 1, FH => Symbol::gensym(), %options, ); $args{except} = $args{except} ? ' TRY' : ''; # Global Constants my ($Is_VMS, $SymSet); if ($^O eq 'VMS') { $Is_VMS = 1; # Establish set of global symbols with max length 28, since xsubpp # will later add the 'XS_' prefix. require ExtUtils::XSSymSet; $SymSet = ExtUtils::XSSymSet->new(28); } @{ $self->{XSStack} } = ({type => 'none'}); $self->{InitFileCode} = [ @ExtUtils::ParseXS::Constants::InitFileCode ]; $self->{Overload} = 0; # bool $self->{errors} = 0; # count $self->{Fallback} = '&PL_sv_undef'; # Most of the 1500 lines below uses these globals. We'll have to # clean this up sometime, probably. For now, we just pull them out # of %args. -Ken $self->{RetainCplusplusHierarchicalTypes} = $args{hiertype}; $self->{WantPrototypes} = $args{prototypes}; $self->{WantVersionChk} = $args{versioncheck}; $self->{WantLineNumbers} = $args{linenumbers}; $self->{IncludedFiles} = {}; die "Missing required parameter 'filename'" unless $args{filename}; $self->{filepathname} = $args{filename}; ($self->{dir}, $self->{filename}) = (dirname($args{filename}), basename($args{filename})); $self->{filepathname} =~ s/\\/\\\\/g; $self->{IncludedFiles}->{$args{filename}}++; # Open the output file if given as a string. If they provide some # other kind of reference, trust them that we can print to it. if (not ref $args{output}) { open my($fh), "> $args{output}" or die "Can't create $args{output}: $!"; $args{outfile} = $args{output}; $args{output} = $fh; } # Really, we shouldn't have to chdir() or select() in the first # place. For now, just save and restore. my $orig_cwd = cwd(); my $orig_fh = select(); chdir($self->{dir}); my $pwd = cwd(); my $csuffix = $args{csuffix}; if ($self->{WantLineNumbers}) { my $cfile; if ( $args{outfile} ) { $cfile = $args{outfile}; } else { $cfile = $args{filename}; $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; } tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output}); select PSEUDO_STDOUT; } else { select $args{output}; } $self->{typemap} = process_typemaps( $args{typemap}, $pwd ); # Move more settings from parameters to object foreach my $datum ( qw| argtypes except inout optimize | ) { $self->{$datum} = $args{$datum}; } $self->{strip_c_func_prefix} = $args{s}; # Identify the version of xsubpp used print <<EOM; /* * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the * contents of $self->{filename}. Do not edit this file, edit $self->{filename} instead. * * ANY CHANGES MADE HERE WILL BE LOST! * */ EOM print("#line 1 \"" . escape_file_for_line_directive($self->{filepathname}) . "\"\n") if $self->{WantLineNumbers}; # Open the input file (using $self->{filename} which # is a basename'd $args{filename} due to chdir above) open($self->{FH}, '<', $self->{filename}) or die "cannot open $self->{filename}: $!\n"; FIRSTMODULE: while (readline($self->{FH})) { if (/^=/) { my $podstartline = $.; do { if (/^=cut\s*$/) { # We can't just write out a /* */ comment, as our embedded # POD might itself be in a comment. We can't put a /**/ # comment inside #if 0, as the C standard says that the source # file is decomposed into preprocessing characters in the stage # before preprocessing commands are executed. # I don't want to leave the text as barewords, because the spec # isn't clear whether macros are expanded before or after # preprocessing commands are executed, and someone pathological # may just have defined one of the 3 words as a macro that does # something strange. Multiline strings are illegal in C, so # the "" we write must be a string literal. And they aren't # concatenated until 2 steps later, so we are safe. # - Nicholas Clark print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); printf("#line %d \"%s\"\n", $. + 1, escape_file_for_line_directive($self->{filepathname})) if $self->{WantLineNumbers}; next FIRSTMODULE; } } while (readline($self->{FH})); # At this point $. is at end of file so die won't state the start # of the problem, and as we haven't yet read any lines &death won't # show the correct line in the message either. die ("Error: Unterminated pod in $self->{filename}, line $podstartline\n") unless $self->{lastline}; } last if ($self->{Package}, $self->{Prefix}) = /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; print $_; } unless (defined $_) { warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n"; exit 0; # Not a fatal error for the caller process } print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; standard_XS_defs(); print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; $self->{lastline} = $_; $self->{lastline_no} = $.; my $BootCode_ref = []; my $XSS_work_idx = 0; my $cpp_next_tmp = 'XSubPPtmpAAAA'; PARAGRAPH: while ($self->fetch_para()) { my $outlist_ref = []; # Print initial preprocessor statements and blank lines while (@{ $self->{line} } && $self->{line}->[0] !~ /^[^\#]/) { my $ln = shift(@{ $self->{line} }); print $ln, "\n"; next unless $ln =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; my $statement = $+; ( $self, $XSS_work_idx, $BootCode_ref ) = analyze_preprocessor_statements( $self, $statement, $XSS_work_idx, $BootCode_ref ); } next PARAGRAPH unless @{ $self->{line} }; if ($XSS_work_idx && !$self->{XSStack}->[$XSS_work_idx]{varname}) { # We are inside an #if, but have not yet #defined its xsubpp variable. print "#define $cpp_next_tmp 1\n\n"; push(@{ $self->{InitFileCode} }, "#if $cpp_next_tmp\n"); push(@{ $BootCode_ref }, "#if $cpp_next_tmp"); $self->{XSStack}->[$XSS_work_idx]{varname} = $cpp_next_tmp++; } $self->death( "Code is not inside a function" ." (maybe last function was ended by a blank line " ." followed by a statement on column one?)") if $self->{line}->[0] =~ /^\s/; # initialize info arrays foreach my $member (qw(args_match var_types defaults arg_list argtype_seen in_out lengthof)) { $self->{$member} = {}; } $self->{proto_arg} = []; $self->{processing_arg_with_types} = 0; # bool $self->{proto_in_this_xsub} = 0; # counter & bool $self->{scope_in_this_xsub} = 0; # counter & bool $self->{interface} = 0; # bool $self->{interface_macro} = 'XSINTERFACE_FUNC'; $self->{interface_macro_set} = 'XSINTERFACE_FUNC_SET'; $self->{ProtoThisXSUB} = $self->{WantPrototypes}; # states 0 (none), 1 (yes), 2 (empty prototype) $self->{ScopeThisXSUB} = 0; # bool my $xsreturn = 0; $_ = shift(@{ $self->{line} }); while (my $kwd = $self->check_keyword("REQUIRE|PROTOTYPES|EXPORT_XSUB_SYMBOLS|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) { my $method = $kwd . "_handler"; $self->$method($_); next PARAGRAPH unless @{ $self->{line} }; $_ = shift(@{ $self->{line} }); } if ($self->check_keyword("BOOT")) { check_conditional_preprocessor_statements($self); push (@{ $BootCode_ref }, "#line $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} }] \"" . escape_file_for_line_directive($self->{filepathname}) . "\"") if $self->{WantLineNumbers} && $self->{line}->[0] !~ /^\s*#\s*line\b/; push (@{ $BootCode_ref }, @{ $self->{line} }, ""); next PARAGRAPH; } # extract return type, function name and arguments ($self->{ret_type}) = ExtUtils::Typemaps::tidy_type($_); my $RETVAL_no_return = 1 if $self->{ret_type} =~ s/^NO_OUTPUT\s+//; # Allow one-line ANSI-like declaration unshift @{ $self->{line} }, $2 if $self->{argtypes} and $self->{ret_type} =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; # a function definition needs at least 2 lines $self->blurt("Error: Function definition too short '$self->{ret_type}'"), next PARAGRAPH unless @{ $self->{line} }; my $externC = 1 if $self->{ret_type} =~ s/^extern "C"\s+//; my $static = 1 if $self->{ret_type} =~ s/^static\s+//; my $func_header = shift(@{ $self->{line} }); $self->blurt("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; my ($class, $orig_args); ($class, $self->{func_name}, $orig_args) = ($1, $2, $3); $class = "$4 $class" if $4; ($self->{pname} = $self->{func_name}) =~ s/^($self->{Prefix})?/$self->{Packprefix}/; my $clean_func_name; ($clean_func_name = $self->{func_name}) =~ s/^$self->{Prefix}//; $self->{Full_func_name} = "$self->{Packid}_$clean_func_name"; if ($Is_VMS) { $self->{Full_func_name} = $SymSet->addsym( $self->{Full_func_name} ); } # Check for duplicate function definition for my $tmp (@{ $self->{XSStack} }) { next unless defined $tmp->{functions}{ $self->{Full_func_name} }; Warn( $self, "Warning: duplicate function definition '$clean_func_name' detected"); last; } $self->{XSStack}->[$XSS_work_idx]{functions}{ $self->{Full_func_name} }++; delete $self->{XsubAliases}; delete $self->{XsubAliasValues}; %{ $self->{Interfaces} } = (); @{ $self->{Attributes} } = (); $self->{DoSetMagic} = 1; $orig_args =~ s/\\\s*/ /g; # process line continuations my @args; my (@fake_INPUT_pre); # For length(s) generated variables my (@fake_INPUT); my $only_C_inlist_ref = {}; # Not in the signature of Perl function if ($self->{argtypes} and $orig_args =~ /\S/) { my $args = "$orig_args ,"; use re 'eval'; if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); no re 'eval'; for ( @args ) { s/^\s+//; s/\s+$//; my ($arg, $default) = ($_ =~ m/ ( [^=]* ) ( (?: = .* )? ) /x); my ($pre, $len_name) = ($arg =~ /(.*?) \s* \b ( \w+ | length\( \s*\w+\s* \) ) \s* $ /x); next unless defined($pre) && length($pre); my $out_type = ''; my $inout_var; if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) { my $type = $1; $out_type = $type if $type ne 'IN'; $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//; } my $islength; if ($len_name =~ /^length\( \s* (\w+) \s* \)\z/x) { $len_name = "XSauto_length_of_$1"; $islength = 1; die "Default value on length() argument: '$_'" if length $default; } if (length $pre or $islength) { # Has a type if ($islength) { push @fake_INPUT_pre, $arg; } else { push @fake_INPUT, $arg; } # warn "pushing '$arg'\n"; $self->{argtype_seen}->{$len_name}++; $_ = "$len_name$default"; # Assigns to @args } $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST" or $islength; push @{ $outlist_ref }, $len_name if $out_type =~ /OUTLIST$/; $self->{in_out}->{$len_name} = $out_type if $out_type; } } else { no re 'eval'; @args = split(/\s*,\s*/, $orig_args); Warn( $self, "Warning: cannot parse argument list '$orig_args', fallback to split"); } } else { @args = split(/\s*,\s*/, $orig_args); for (@args) { if ($self->{inout} and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) { my $out_type = $1; next if $out_type eq 'IN'; $only_C_inlist_ref->{$_} = 1 if $out_type eq "OUTLIST"; if ($out_type =~ /OUTLIST$/) { push @{ $outlist_ref }, undef; } $self->{in_out}->{$_} = $out_type; } } } if (defined($class)) { my $arg0 = ((defined($static) or $self->{func_name} eq 'new') ? "CLASS" : "THIS"); unshift(@args, $arg0); } my $extra_args = 0; my @args_num = (); my $num_args = 0; my $report_args = ''; my $ellipsis; foreach my $i (0 .. $#args) { if ($args[$i] =~ s/\.\.\.//) { $ellipsis = 1; if ($args[$i] eq '' && $i == $#args) { $report_args .= ", ..."; pop(@args); last; } } if ($only_C_inlist_ref->{$args[$i]}) { push @args_num, undef; } else { push @args_num, ++$num_args; $report_args .= ", $args[$i]"; } if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { $extra_args++; $args[$i] = $1; $self->{defaults}->{$args[$i]} = $2; $self->{defaults}->{$args[$i]} =~ s/"/\\"/g; } $self->{proto_arg}->[$i+1] = '$'; } my $min_args = $num_args - $extra_args; $report_args =~ s/"/\\"/g; $report_args =~ s/^,\s+//; $self->{func_args} = assign_func_args($self, \@args, $class); @{ $self->{args_match} }{@args} = @args_num; my $PPCODE = grep(/^\s*PPCODE\s*:/, @{ $self->{line} }); my $CODE = grep(/^\s*CODE\s*:/, @{ $self->{line} }); # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) # to set explicit return values. my $EXPLICIT_RETURN = ($CODE && ("@{ $self->{line} }" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); $self->{ALIAS} = grep(/^\s*ALIAS\s*:/, @{ $self->{line} }); my $INTERFACE = grep(/^\s*INTERFACE\s*:/, @{ $self->{line} }); $xsreturn = 1 if $EXPLICIT_RETURN; $externC = $externC ? qq[extern "C"] : ""; # print function header print Q(<<"EOF"); #$externC #XS_EUPXS(XS_$self->{Full_func_name}); /* prototype to pass -Wmissing-prototypes */ #XS_EUPXS(XS_$self->{Full_func_name}) #[[ # dVAR; dXSARGS; EOF print Q(<<"EOF") if $self->{ALIAS}; # dXSI32; EOF print Q(<<"EOF") if $INTERFACE; # dXSFUNCTION($self->{ret_type}); EOF $self->{cond} = set_cond($ellipsis, $min_args, $num_args); print Q(<<"EOF") if $self->{except}; # char errbuf[1024]; # *errbuf = '\\0'; EOF if($self->{cond}) { print Q(<<"EOF"); # if ($self->{cond}) # croak_xs_usage(cv, "$report_args"); EOF } else { # cv likely to be unused print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ EOF } #gcc -Wall: if an xsub has PPCODE is used #it is possible none of ST, XSRETURN or XSprePUSH macros are used #hence 'ax' (setup by dXSARGS) is unused #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS #but such a move could break third-party extensions print Q(<<"EOF") if $PPCODE; # PERL_UNUSED_VAR(ax); /* -Wall */ EOF print Q(<<"EOF") if $PPCODE; # SP -= items; EOF # Now do a block of some sort. $self->{condnum} = 0; $self->{cond} = ''; # last CASE: conditional push(@{ $self->{line} }, "$END:"); push(@{ $self->{line_no} }, $self->{line_no}->[-1]); $_ = ''; check_conditional_preprocessor_statements(); while (@{ $self->{line} }) { $self->CASE_handler($_) if $self->check_keyword("CASE"); print Q(<<"EOF"); # $self->{except} [[ EOF # do initialization of input variables $self->{thisdone} = 0; $self->{retvaldone} = 0; $self->{deferred} = ""; %{ $self->{arg_list} } = (); $self->{gotRETVAL} = 0; $self->INPUT_handler($_); $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ENTER; # [[ EOF if (!$self->{thisdone} && defined($class)) { if (defined($static) or $self->{func_name} eq 'new') { print "\tchar *"; $self->{var_types}->{"CLASS"} = "char *"; $self->generate_init( { type => "char *", num => 1, var => "CLASS", printed_name => undef, } ); } else { print "\t" . map_type($self, "$class *"); $self->{var_types}->{"THIS"} = "$class *"; $self->generate_init( { type => "$class *", num => 1, var => "THIS", printed_name => undef, } ); } } # These are set if OUTPUT is found and/or CODE using RETVAL $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; my ($wantRETVAL); # do code if (/^\s*NOT_IMPLEMENTED_YET/) { print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n"; $_ = ''; } else { if ($self->{ret_type} ne "void") { print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" if !$self->{retvaldone}; $self->{args_match}->{"RETVAL"} = 0; $self->{var_types}->{"RETVAL"} = $self->{ret_type}; my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); print "\tdXSTARG;\n" if $self->{optimize} and $outputmap and $outputmap->targetable; } if (@fake_INPUT or @fake_INPUT_pre) { unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; $_ = ""; $self->{processing_arg_with_types} = 1; $self->INPUT_handler($_); } print $self->{deferred}; $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); if ($self->check_keyword("PPCODE")) { $self->print_section(); $self->death("PPCODE must be last thing") if @{ $self->{line} }; print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; print "\tPUTBACK;\n\treturn;\n"; } elsif ($self->check_keyword("CODE")) { my $consumed_code = $self->print_section(); if ($consumed_code =~ /\bRETVAL\b/) { $self->{have_CODE_with_RETVAL} = 1; } } elsif (defined($class) and $self->{func_name} eq "DESTROY") { print "\n\t"; print "delete THIS;\n"; } else { print "\n\t"; if ($self->{ret_type} ne "void") { print "RETVAL = "; $wantRETVAL = 1; } if (defined($static)) { if ($self->{func_name} eq 'new') { $self->{func_name} = "$class"; } else { print "${class}::"; } } elsif (defined($class)) { if ($self->{func_name} eq 'new') { $self->{func_name} .= " $class"; } else { print "THIS->"; } } my $strip = $self->{strip_c_func_prefix}; $self->{func_name} =~ s/^\Q$strip// if defined $strip; $self->{func_name} = 'XSFUNCTION' if $self->{interface}; print "$self->{func_name}($self->{func_args});\n"; } } # do output variables $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); # $wantRETVAL set if 'RETVAL =' autogenerated ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; undef %{ $self->{outargs} }; $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); # A CODE section with RETVAL, but no OUTPUT? FAIL! if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); } $self->generate_output( { type => $self->{var_types}->{$_}, num => $self->{args_match}->{$_}, var => $_, do_setmagic => $self->{DoSetMagic}, do_push => undef, } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; my $prepush_done; # all OUTPUT done, so now push the return value on the stack if ($self->{gotRETVAL} && $self->{RETVAL_code}) { print "\t$self->{RETVAL_code}\n"; } elsif ($self->{gotRETVAL} || $wantRETVAL) { my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable; my $var = 'RETVAL'; my $type = $self->{ret_type}; if ($trgt) { my $what = $self->eval_output_typemap_code( qq("$trgt->{what}"), {var => $var, type => $self->{ret_type}} ); if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; $prepush_done = 1; } else { my $tsize = $trgt->{what_size}; $tsize = '' unless defined $tsize; $tsize = $self->eval_output_typemap_code( qq("$tsize"), {var => $var, type => $self->{ret_type}} ); print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; $prepush_done = 1; } } else { # RETVAL almost never needs SvSETMAGIC() $self->generate_output( { type => $self->{ret_type}, num => 0, var => 'RETVAL', do_setmagic => 0, do_push => undef, } ); } } $xsreturn = 1 if $self->{ret_type} ne "void"; my $num = $xsreturn; my $c = @{ $outlist_ref }; print "\tXSprePUSH;" if $c and not $prepush_done; print "\tEXTEND(SP,$c);\n" if $c; $xsreturn += $c; $self->generate_output( { type => $self->{var_types}->{$_}, num => $num++, var => $_, do_setmagic => 0, do_push => 1, } ) for @{ $outlist_ref }; # do cleanup $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); print Q(<<"EOF") if $self->{ScopeThisXSUB}; # ]] EOF print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; # LEAVE; EOF # print function trailer print Q(<<"EOF"); # ]] EOF print Q(<<"EOF") if $self->{except}; # BEGHANDLERS # CATCHALL # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); # ENDHANDLERS EOF if ($self->check_keyword("CASE")) { $self->blurt("Error: No 'CASE:' at top of function") unless $self->{condnum}; $_ = "CASE: $_"; # Restore CASE: label next; } last if $_ eq "$END:"; $self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)"); } print Q(<<"EOF") if $self->{except}; # if (errbuf[0]) # Perl_croak(aTHX_ errbuf); EOF if ($xsreturn) { print Q(<<"EOF") unless $PPCODE; # XSRETURN($xsreturn); EOF } else { print Q(<<"EOF") unless $PPCODE; # XSRETURN_EMPTY; EOF } print Q(<<"EOF"); #]] # EOF $self->{proto} = ""; unless($self->{ProtoThisXSUB}) { $self->{newXS} = "newXS_deffile"; $self->{file} = ""; } else { # Build the prototype string for the xsub $self->{newXS} = "newXSproto_portable"; $self->{file} = ", file"; if ($self->{ProtoThisXSUB} eq 2) { # User has specified empty prototype } elsif ($self->{ProtoThisXSUB} eq 1) { my $s = ';'; if ($min_args < $num_args) { $s = ''; $self->{proto_arg}->[$min_args] .= ";"; } push @{ $self->{proto_arg} }, "$s\@" if $ellipsis; $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); } else { # User has specified a prototype $self->{proto} = $self->{ProtoThisXSUB}; } $self->{proto} = qq{, "$self->{proto}"}; } if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { $self->{XsubAliases}->{ $self->{pname} } = 0 unless defined $self->{XsubAliases}->{ $self->{pname} }; foreach my $xname (sort keys %{ $self->{XsubAliases} }) { my $value = $self->{XsubAliases}{$xname}; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # XSANY.any_i32 = $value; EOF } } elsif (@{ $self->{Attributes} }) { push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); EOF } elsif ($self->{interface}) { foreach my $yname (sort keys %{ $self->{Interfaces} }) { my $value = $self->{Interfaces}{$yname}; $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; push(@{ $self->{InitFileCode} }, Q(<<"EOF")); # cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); # $self->{interface_macro_set}(cv,$value); EOF } } elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro push(@{ $self->{InitFileCode} }, " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } else { push(@{ $self->{InitFileCode} }, " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } # END 'PARAGRAPH' 'while' loop if ($self->{Overload}) { # make it findable with fetchmethod print Q(<<"EOF"); #XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ #XS_EUPXS(XS_$self->{Packid}_nil) #{ # dXSARGS; # XSRETURN_EMPTY; #} # EOF unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK"); /* Making a sub named "$self->{Package}::()" allows the package */ /* to be findable via fetchmethod(), and causes */ /* overload::Overloaded("$self->{Package}") to return true. */ (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); MAKE_FETCHMETHOD_WORK } # print initialization routine print Q(<<"EOF"); ##ifdef __cplusplus #extern "C" ##endif EOF print Q(<<"EOF"); #XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ #XS_EXTERNAL(boot_$self->{Module_cname}) #[[ ##if PERL_VERSION_LE(5, 21, 5) # dVAR; dXSARGS; ##else # dVAR; ${\($self->{WantVersionChk} ? 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} ##endif EOF #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const #file name argument. If the wrong qualifier is used, it causes breakage with #C++ compilers and warnings with recent gcc. #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs #so 'file' is unused print Q(<<"EOF") if $self->{Full_func_name}; ##if (PERL_REVISION == 5 && PERL_VERSION < 9) # char* file = __FILE__; ##else # const char* file = __FILE__; ##endif # # PERL_UNUSED_VAR(file); EOF print Q("#\n"); print Q(<<"EOF"); # PERL_UNUSED_VAR(cv); /* -W */ # PERL_UNUSED_VAR(items); /* -W */ EOF if( $self->{WantVersionChk}){ print Q(<<"EOF") ; ##if PERL_VERSION_LE(5, 21, 5) # XS_VERSION_BOOTCHECK; ## ifdef XS_APIVERSION_BOOTCHECK # XS_APIVERSION_BOOTCHECK; ## endif ##endif EOF } else { print Q(<<"EOF") ; ##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) # XS_APIVERSION_BOOTCHECK; ##endif EOF } print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # { # CV * cv; # EOF print Q(<<"EOF") if ($self->{Overload}); # /* register the overloading (type 'A') magic */ ##if (PERL_REVISION == 5 && PERL_VERSION < 9) # PL_amagic_generation++; ##endif # /* The magic for overload gets a GV* via gv_fetchmeth as */ # /* mentioned above, and looks in the SV* slot of it for */ # /* the "fallback" status. */ # sv_setsv( # get_sv( "$self->{Package}::()", TRUE ), # $self->{Fallback} # ); EOF print @{ $self->{InitFileCode} }; print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; # } EOF if (@{ $BootCode_ref }) { print "\n /* Initialisation Section */\n\n"; @{ $self->{line} } = @{ $BootCode_ref }; $self->print_section(); print "\n /* End of Initialisation Section */\n\n"; } print Q(<<'EOF'); ##if PERL_VERSION_LE(5, 21, 5) ## if PERL_VERSION_GE(5, 9, 0) # if (PL_unitcheckav) # call_list(PL_scopestack_ix, PL_unitcheckav); ## endif # XSRETURN_YES; ##else # Perl_xs_boot_epilog(aTHX_ ax); ##endif #]] # EOF warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") unless $self->{ProtoUsed}; chdir($orig_cwd); select($orig_fh); untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; close $self->{FH}; return 1; } sub report_error_count { if (@_) { return $_[0]->{errors}||0; } else { return $Singleton->{errors}||0; } } # Input: ($self, $_, @{ $self->{line} }) == unparsed input. # Output: ($_, @{ $self->{line} }) == (rest of line, following lines). # Return: the matched keyword if found, otherwise 0 sub check_keyword { my $self = shift; $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; } sub print_section { my $self = shift; # the "do" is required for right semantics do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; my $consumed_code = ''; print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"", escape_file_for_line_directive($self->{filepathname}), "\"\n") if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { print "$_\n"; $consumed_code .= "$_\n"; } print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; return $consumed_code; } sub merge_section { my $self = shift; my $in = ''; while (!/\S/ && @{ $self->{line} }) { $_ = shift(@{ $self->{line} }); } for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { $in .= "$_\n"; } chomp $in; return $in; } sub process_keyword { my($self, $pattern) = @_; while (my $kwd = $self->check_keyword($pattern)) { my $method = $kwd . "_handler"; $self->$method($_); } } sub CASE_handler { my $self = shift; $_ = shift; $self->blurt("Error: 'CASE:' after unconditional 'CASE:'") if $self->{condnum} && $self->{cond} eq ''; $self->{cond} = $_; trim_whitespace($self->{cond}); print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); $_ = ''; } sub INPUT_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { last if /^\s*NOT_IMPLEMENTED_YET/; next unless /\S/; # skip blank lines trim_whitespace($_); my $ln = $_; # remove trailing semicolon if no initialisation s/\s*;$//g unless /[=;+].*\S/; # Process the length(foo) declarations if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; $self->{lengthof}->{$2} = undef; $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; } # check for optional initialisation code my $var_init = ''; $var_init = $1 if s/\s*([=;+].*)$//s; $var_init =~ s/"/\\"/g; # *sigh* It's valid to supply explicit input typemaps in the argument list... my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/; s/\s+/ /g; my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s or $self->blurt("Error: invalid argument declaration '$ln'"), next; # Check for duplicate definitions $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next if $self->{arg_list}->{$var_name}++ or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; $self->{thisdone} |= $var_name eq "THIS"; $self->{retvaldone} |= $var_name eq "RETVAL"; $self->{var_types}->{$var_name} = $var_type; # XXXX This check is a safeguard against the unfinished conversion of # generate_init(). When generate_init() is fixed, # one can use 2-args map_type() unconditionally. my $printed_name; if ($var_type =~ / \( \s* \* \s* \) /x) { # Function pointers are not yet supported with output_init()! print "\t" . map_type($self, $var_type, $var_name); $printed_name = 1; } else { print "\t" . map_type($self, $var_type, undef); $printed_name = 0; } $self->{var_num} = $self->{args_match}->{$var_name}; if ($self->{var_num}) { my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); $self->report_typemap_failure($self->{typemap}, $var_type, "death") if not $typemap and not $is_overridden_typemap; $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; } $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr; if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ and $var_init !~ /\S/) { if ($printed_name) { print ";\n"; } else { print "\t$var_name;\n"; } } elsif ($var_init =~ /\S/) { $self->output_init( { type => $var_type, num => $self->{var_num}, var => $var_name, init => $var_init, printed_name => $printed_name, } ); } elsif ($self->{var_num}) { $self->generate_init( { type => $var_type, num => $self->{var_num}, var => $var_name, printed_name => $printed_name, } ); } else { print ";\n"; } } } sub OUTPUT_handler { my $self = shift; $self->{have_OUTPUT} = 1; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); next; } my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next if $self->{outargs}->{$outarg}++; if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { # deal with RETVAL last $self->{RETVAL_code} = $outcode; $self->{gotRETVAL} = 1; next; } $self->blurt("Error: OUTPUT $outarg not an argument"), next unless defined($self->{args_match}->{$outarg}); $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next unless defined $self->{var_types}->{$outarg}; $self->{var_num} = $self->{args_match}->{$outarg}; if ($outcode) { print "\t$outcode\n"; print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; } else { $self->generate_output( { type => $self->{var_types}->{$outarg}, num => $self->{var_num}, var => $outarg, do_setmagic => $self->{DoSetMagic}, do_push => undef, } ); } delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; } } sub C_ARGS_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); $self->{func_args} = $in; } sub INTERFACE_MACRO_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); if ($in =~ /\s/) { # two ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; } else { $self->{interface_macro} = $in; $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later } $self->{interface} = 1; # local $self->{interfaces} = 1; # global } sub INTERFACE_handler { my $self = shift; $_ = shift; my $in = $self->merge_section(); trim_whitespace($in); foreach (split /[\s,]+/, $in) { my $iface_name = $_; $iface_name =~ s/^$self->{Prefix}//; $self->{Interfaces}->{$iface_name} = $_; } print Q(<<"EOF"); # XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); EOF $self->{interface} = 1; # local $self->{interfaces} = 1; # global } sub CLEANUP_handler { my $self = shift; $self->print_section(); } sub PREINIT_handler { my $self = shift; $self->print_section(); } sub POSTCALL_handler { my $self = shift; $self->print_section(); } sub INIT_handler { my $self = shift; $self->print_section(); } sub get_aliases { my $self = shift; my ($line) = @_; my ($orig) = $line; # Parse alias definitions # format is # alias = value alias = value ... while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { my ($alias, $value) = ($1, $2); my $orig_alias = $alias; # check for optional package definition in the alias $alias = $self->{Packprefix} . $alias if $alias !~ /::/; # check for duplicate alias name & duplicate value Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") if defined $self->{XsubAliases}->{$alias}; Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") if $self->{XsubAliasValues}->{$value}; $self->{XsubAliases}->{$alias} = $value; $self->{XsubAliasValues}->{$value} = $orig_alias; } blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") if $line; } sub ATTRS_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); push @{ $self->{Attributes} }, $_; } } sub ALIAS_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); $self->get_aliases($_) if $_; } } sub OVERLOAD_handler { my $self = shift; $_ = shift; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; trim_whitespace($_); while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { $self->{Overload} = 1 unless $self->{Overload}; my $overload = "$self->{Package}\::(".$1; push(@{ $self->{InitFileCode} }, " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); } } } sub FALLBACK_handler { my ($self, $setting) = @_; # the rest of the current line should contain either TRUE, # FALSE or UNDEF trim_whitespace($setting); $setting = uc($setting); my %map = ( TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", FALSE => "&PL_sv_no", 0 => "&PL_sv_no", UNDEF => "&PL_sv_undef", ); # check for valid FALLBACK value $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting}; $self->{Fallback} = $map{$setting}; } sub REQUIRE_handler { # the rest of the current line should contain a version number my ($self, $ver) = @_; trim_whitespace($ver); $self->death("Error: REQUIRE expects a version number") unless $ver; # check that the version number is of the form n.n $self->death("Error: REQUIRE: expected a number, got '$ver'") unless $ver =~ /^\d+(\.\d*)?/; $self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.") unless $VERSION >= $ver; } sub VERSIONCHECK_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; } sub PROTOTYPE_handler { my $self = shift; $_ = shift; my $specified; $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") if $self->{proto_in_this_xsub}++; for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { next unless /\S/; $specified = 1; trim_whitespace($_); if ($_ eq 'DISABLE') { $self->{ProtoThisXSUB} = 0; } elsif ($_ eq 'ENABLE') { $self->{ProtoThisXSUB} = 1; } else { # remove any whitespace s/\s+//g; $self->death("Error: Invalid prototype '$_'") unless valid_proto_string($_); $self->{ProtoThisXSUB} = C_string($_); } } # If no prototype specified, then assume empty prototype "" $self->{ProtoThisXSUB} = 2 unless $specified; $self->{ProtoUsed} = 1; } sub SCOPE_handler { # Rest of line should be either ENABLE or DISABLE my ($self, $setting) = @_; $self->death("Error: Only 1 SCOPE declaration allowed per xsub") if $self->{scope_in_this_xsub}++; trim_whitespace($setting); $self->death("Error: SCOPE: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)\b/i; $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); } sub PROTOTYPES_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: PROTOTYPES: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; $self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; $self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; $self->{ProtoUsed} = 1; } sub EXPORT_XSUB_SYMBOLS_handler { # the rest of the current line should contain either ENABLE or # DISABLE my ($self, $setting) = @_; trim_whitespace($setting); # check for ENABLE/DISABLE $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE") unless $setting =~ /^(ENABLE|DISABLE)/i; my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL'; print Q(<<"EOF"); ##undef XS_EUPXS ##if defined(PERL_EUPXS_ALWAYS_EXPORT) ## define XS_EUPXS(name) XS_EXTERNAL(name) ##elif defined(PERL_EUPXS_NEVER_EXPORT) ## define XS_EUPXS(name) XS_INTERNAL(name) ##else ## define XS_EUPXS(name) $xs_impl(name) ##endif EOF } sub PushXSStack { my $self = shift; my %args = @_; # Save the current file context. push(@{ $self->{XSStack} }, { type => 'file', LastLine => $self->{lastline}, LastLineNo => $self->{lastline_no}, Line => $self->{line}, LineNo => $self->{line_no}, Filename => $self->{filename}, Filepathname => $self->{filepathname}, Handle => $self->{FH}, IsPipe => scalar($self->{filename} =~ /\|\s*$/), %args, }); } sub INCLUDE_handler { my $self = shift; $_ = shift; # the rest of the current line should contain a valid filename trim_whitespace($_); $self->death("INCLUDE: filename missing") unless $_; $self->death("INCLUDE: output pipe is illegal") if /^\s*\|/; # simple minded recursion detector $self->death("INCLUDE loop detected") if $self->{IncludedFiles}->{$_}; ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; if (/\|\s*$/ && /^\s*perl\s/) { Warn( $self, "The INCLUDE directive with a command is discouraged." . " Use INCLUDE_COMMAND instead! In particular using 'perl'" . " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . " up the correct perl. The INCLUDE_COMMAND directive allows" . " the use of \$^X as the currently running perl, see" . " 'perldoc perlxs' for details."); } $self->PushXSStack(); $self->{FH} = Symbol::gensym(); # open the new file open($self->{FH}, $_) or $self->death("Cannot open '$_': $!"); print Q(<<"EOF"); # #/* INCLUDE: Including '$_' from '$self->{filename}' */ # EOF $self->{filename} = $_; $self->{filepathname} = ( $^O =~ /^mswin/i ) ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? : File::Spec->catfile($self->{dir}, $self->{filename}); # Prime the pump by reading the first # non-blank line # skip leading blank lines while (readline($self->{FH})) { last unless /^\s*$/; } $self->{lastline} = $_; $self->{lastline_no} = $.; } sub QuoteArgs { my $cmd = shift; my @args = split /\s+/, $cmd; $cmd = shift @args; for (@args) { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; } return join (' ', ($cmd, @args)); } # code copied from CPAN::HandleConfig::safe_quote # - that has doc saying leave if start/finish with same quote, but no code # given text, will conditionally quote it to protect from shell { my ($quote, $use_quote) = $^O eq 'MSWin32' ? (q{"}, q{"}) : (q{"'}, q{'}); sub _safe_quote { my ($self, $command) = @_; # Set up quote/default quote if (defined($command) and $command =~ /\s/ and $command !~ /[$quote]/) { return qq{$use_quote$command$use_quote} } return $command; } } sub INCLUDE_COMMAND_handler { my $self = shift; $_ = shift; # the rest of the current line should contain a valid command trim_whitespace($_); $_ = QuoteArgs($_) if $^O eq 'VMS'; $self->death("INCLUDE_COMMAND: command missing") unless $_; $self->death("INCLUDE_COMMAND: pipes are illegal") if /^\s*\|/ or /\|\s*$/; $self->PushXSStack( IsPipe => 1 ); $self->{FH} = Symbol::gensym(); # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be # the same perl interpreter as we're currently running my $X = $self->_safe_quote($^X); # quotes if has spaces s/^\s*\$\^X/$X/; # open the new file open ($self->{FH}, "-|", $_) or $self->death( $self, "Cannot run command '$_' to include its output: $!"); print Q(<<"EOF"); # #/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ # EOF $self->{filename} = $_; $self->{filepathname} = $self->{filename}; #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 # Prime the pump by reading the first # non-blank line # skip leading blank lines while (readline($self->{FH})) { last unless /^\s*$/; } $self->{lastline} = $_; $self->{lastline_no} = $.; } sub PopFile { my $self = shift; return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; my $data = pop @{ $self->{XSStack} }; my $ThisFile = $self->{filename}; my $isPipe = $data->{IsPipe}; --$self->{IncludedFiles}->{$self->{filename}} unless $isPipe; close $self->{FH}; $self->{FH} = $data->{Handle}; # $filename is the leafname, which for some reason is used for diagnostic # messages, whereas $filepathname is the full pathname, and is used for # #line directives. $self->{filename} = $data->{Filename}; $self->{filepathname} = $data->{Filepathname}; $self->{lastline} = $data->{LastLine}; $self->{lastline_no} = $data->{LastLineNo}; @{ $self->{line} } = @{ $data->{Line} }; @{ $self->{line_no} } = @{ $data->{LineNo} }; if ($isPipe and $? ) { --$self->{lastline_no}; print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; exit 1; } print Q(<<"EOF"); # #/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ # EOF return 1; } sub Q { my($text) = @_; $text =~ s/^#//gm; $text =~ s/\[\[/{/g; $text =~ s/\]\]/}/g; $text; } # Process "MODULE = Foo ..." lines and update global state accordingly sub _process_module_xs_line { my ($self, $module, $pkg, $prefix) = @_; ($self->{Module_cname} = $module) =~ s/\W/_/g; $self->{Package} = defined($pkg) ? $pkg : ''; $self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); ($self->{Packid} = $self->{Package}) =~ tr/:/_/; $self->{Packprefix} = $self->{Package}; $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; $self->{lastline} = ""; } # Skip any embedded POD sections sub _maybe_skip_pod { my ($self) = @_; while ($self->{lastline} =~ /^=/) { while ($self->{lastline} = readline($self->{FH})) { last if ($self->{lastline} =~ /^=cut\s*$/); } $self->death("Error: Unterminated pod") unless defined $self->{lastline}; $self->{lastline} = readline($self->{FH}); chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } } # This chunk of code strips out (and parses) embedded TYPEMAP blocks # which support a HEREdoc-alike block syntax. sub _maybe_parse_typemap_block { my ($self) = @_; # This is special cased from the usual paragraph-handler logic # due to the HEREdoc-ish syntax. if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) { my $end_marker = quotemeta(defined($1) ? $2 : $3); # Scan until we find $end_marker alone on a line. my @tmaplines; while (1) { $self->{lastline} = readline($self->{FH}); $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; last if $self->{lastline} =~ /^$end_marker\s*$/; push @tmaplines, $self->{lastline}; } my $tmap = ExtUtils::Typemaps->new( string => join("", @tmaplines), lineno_offset => 1 + ($self->current_line_number() || 0), fake_filename => $self->{filename}, ); $self->{typemap}->merge(typemap => $tmap, replace => 1); $self->{lastline} = ""; } } # Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). sub fetch_para { my $self = shift; # parse paragraph $self->death("Error: Unterminated '#if/#ifdef/#ifndef'") if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; @{ $self->{line} } = (); @{ $self->{line_no} } = (); return $self->PopFile() if not defined $self->{lastline}; # EOF if ($self->{lastline} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { $self->_process_module_xs_line($1, $2, $3); } for (;;) { $self->_maybe_skip_pod; $self->_maybe_parse_typemap_block; if ($self->{lastline} !~ /^\s*#/ # not a CPP directive # CPP directives: # ANSI: if ifdef ifndef elif else endif define undef # line error pragma # gcc: warning include_next # obj-c: import # others: ident (gcc notes that some cpps have this one) || $self->{lastline} =~ /^\#[ \t]* (?: (?:if|ifn?def|elif|else|endif| define|undef|pragma|error| warning|line\s+\d+|ident) \b | (?:include(?:_next)?|import) \s* ["<] .* [>"] ) /x ) { last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; push(@{ $self->{line} }, $self->{lastline}); push(@{ $self->{line_no} }, $self->{lastline_no}); } # Read next line and continuation lines last unless defined($self->{lastline} = readline($self->{FH})); $self->{lastline_no} = $.; my $tmp_line; $self->{lastline} .= $tmp_line while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); chomp $self->{lastline}; $self->{lastline} =~ s/^\s+$//; } # Nuke trailing "line" entries until there's one that's not empty pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) while @{ $self->{line} } && $self->{line}->[-1] eq ""; return 1; } sub output_init { my $self = shift; my $argsref = shift; my ($type, $num, $var, $init, $printed_name) = @{$argsref}{qw(type num var init printed_name)}; # local assign for efficiently passing in to eval_input_typemap_code local $argsref->{arg} = $num ? "ST(" . ($num-1) . ")" : "/* not a parameter */"; if ( $init =~ /^=/ ) { if ($printed_name) { $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); } else { $self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref); } } else { if ( $init =~ s/^\+// && $num ) { $self->generate_init( { type => $type, num => $num, var => $var, printed_name => $printed_name, } ); } elsif ($printed_name) { print ";\n"; $init =~ s/^;//; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref); $init =~ s/^;//; } $self->{deferred} .= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref); } } sub generate_init { my $self = shift; my $argsref = shift; my ($type, $num, $var, $printed_name) = @{$argsref}{qw(type num var printed_name)}; my $argoff = $num - 1; my $arg = "ST($argoff)"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); if (not $typemaps->get_typemap(ctype => $type)) { $self->report_typemap_failure($typemaps, $type); return; } (my $ntype = $type) =~ s/\s*\*/Ptr/g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $typem = $typemaps->get_typemap(ctype => $type); my $xstype = $typem->xstype; #this is an optimization from perl 5.0 alpha 6, class check is skipped #T_REF_IV_REF is missing since it has no untyped analog at the moment $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ if $self->{func_name} =~ /DESTROY$/; if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) { print "\t$var" unless $printed_name; print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; die "default value not supported with length(NAME) supplied" if defined $self->{defaults}->{$var}; return; } $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; my $inputmap = $typemaps->get_inputmap(xstype => $xstype); if (not defined $inputmap) { $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"); return; } my $expr = $inputmap->cleaned_code; # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); if (not $subtypemap) { $self->report_typemap_failure($typemaps, $subtype); return; } my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); if (not $subinputmap) { $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); return; } my $subexpr = $subinputmap->cleaned_code; $subexpr =~ s/\$type/\$subtype/g; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\n\t/\n\t\t/g; $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; $subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/; $expr =~ s/DO_ARRAY_ELEM/$subexpr/; } if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments $self->{ScopeThisXSUB} = 1; } my $eval_vars = { var => $var, printed_name => $printed_name, type => $type, ntype => $ntype, subtype => $subtype, num => $num, arg => $arg, argoff => $argoff, }; if (defined($self->{defaults}->{$var})) { $expr =~ s/(\t+)/$1 /g; $expr =~ s/ /\t/g; if ($printed_name) { print ";\n"; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); } if ($self->{defaults}->{$var} eq 'NO_INIT') { $self->{deferred} .= $self->eval_input_typemap_code( qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/, $eval_vars ); } else { $self->{deferred} .= $self->eval_input_typemap_code( qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/, $eval_vars ); } } elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { if ($printed_name) { print ";\n"; } else { $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); } $self->{deferred} .= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars); } else { die "panic: do not know how to handle this branch for function pointers" if $printed_name; $self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars); } } sub generate_output { my $self = shift; my $argsref = shift; my ($type, $num, $var, $do_setmagic, $do_push) = @{$argsref}{qw(type num var do_setmagic do_push)}; my $arg = "ST(" . ($num - ($num != 0)) . ")"; my $typemaps = $self->{typemap}; $type = ExtUtils::Typemaps::tidy_type($type); local $argsref->{type} = $type; if ($type =~ /^array\(([^,]*),(.*)\)/) { print "\t$arg = sv_newmortal();\n"; print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } else { my $typemap = $typemaps->get_typemap(ctype => $type); if (not $typemap) { $self->report_typemap_failure($typemaps, $type); return; } my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); if (not $outputmap) { $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); return; } (my $ntype = $type) =~ s/\s*\*/Ptr/g; $ntype =~ s/\(\)//g; (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg}; my $expr = $outputmap->cleaned_code; if ($expr =~ /DO_ARRAY_ELEM/) { my $subtypemap = $typemaps->get_typemap(ctype => $subtype); if (not $subtypemap) { $self->report_typemap_failure($typemaps, $subtype); return; } my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); if (not $suboutputmap) { $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); return; } my $subexpr = $suboutputmap->cleaned_code; $subexpr =~ s/ntype/subtype/g; $subexpr =~ s/\$arg/ST(ix_$var)/g; $subexpr =~ s/\$var/${var}\[ix_$var]/g; $subexpr =~ s/\n\t/\n\t\t/g; $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; } elsif ($var eq 'RETVAL') { my $orig_arg = $arg; my $indent; my $use_RETVALSV = 1; my $do_mortal = 0; my $do_copy_tmp = 1; my $pre_expr; local $eval_vars->{arg} = $arg = 'RETVALSV'; my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); if ($expr =~ /^\t\Q$arg\E = new/) { # We expect that $arg has refcnt 1, so we need to # mortalize it. $do_mortal = 1; } # If RETVAL is immortal, don't mortalize it. This code is not perfect: # It won't detect a func or expression that only returns immortals, for # example, this RE must be tried before next elsif. elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV $use_RETVALSV = 0; } elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { # We expect that $arg has refcnt >=1, so we need # to mortalize it! $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block $do_mortal = 1; } else { # Just hope that the entry would safely write it # over an already mortalized value. By # coincidence, something like $arg = &PL_sv_undef # works too, but should be caught above. $pre_expr = "RETVALSV = sv_newmortal();\n"; # new mortals don't have set magic $do_setmagic = 0; } if($use_RETVALSV) { print "\t{\n\t SV * RETVALSV;\n"; $indent = "\t "; } else { $indent = "\t"; } print $indent.$pre_expr if $pre_expr; if($use_RETVALSV) { #take control of 1 layer of indent, may or may not indent more $evalexpr =~ s/^(\t| )/$indent/gm; #"\t \t" doesn't draw right in some IDEs #break down all \t into spaces $evalexpr =~ s/\t/ /g; #rebuild back into \t'es, \t==8 spaces, indent==4 spaces $evalexpr =~ s/ /\t/g; } else { if($do_mortal || $do_setmagic) { #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code } else { #if no extra boilerplate (no mortal, no set magic) is needed #after $evalexport, get rid of RETVALSV's visual cluter and change $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) } } #stop " RETVAL = RETVAL;" for SVPtr type print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" if $do_mortal || $do_setmagic || $do_copy_tmp; print "\t}\n" if $use_RETVALSV; } elsif ($do_push) { print "\tPUSHs(sv_newmortal());\n"; local $eval_vars->{arg} = "ST($num)"; $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } elsif ($arg =~ /^ST\(\d+\)$/) { $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); print "\tSvSETMAGIC($arg);\n" if $do_setmagic; } } } # Just delegates to a clean package. # Shim to evaluate Perl code in the right variable context # for typemap code (having things such as $ALIAS set up). sub eval_output_typemap_code { my ($self, $code, $other) = @_; return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other); } sub eval_input_typemap_code { my ($self, $code, $other) = @_; return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other); } 1; # vim: ts=2 sw=2 et: perl5/ExtUtils/MM_OS2.pm 0000444 00000006235 14711220104 0010702 0 ustar 00 package ExtUtils::MM_OS2; use strict; use warnings; use ExtUtils::MakeMaker qw(neatvalue); use File::Spec; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix); =pod =head1 NAME ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 SYNOPSIS use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed =head1 DESCRIPTION See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. =head1 METHODS =over 4 =item init_dist Define TO_UNIX to convert OS2 linefeeds to Unix style. =cut sub init_dist { my($self) = @_; $self->{TO_UNIX} ||= <<'MAKE_TEXT'; $(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip MAKE_TEXT $self->SUPER::init_dist; } sub dlsyms { my($self,%attribs) = @_; if ($self->{IMPORTS} && %{$self->{IMPORTS}}) { # Make import files (needed for static build) -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp"; foreach my $name (sort keys %{$self->{IMPORTS}}) { my $exp = $self->{IMPORTS}->{$name}; my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; print $imp "$name $lib $id ?\n"; } close $imp or die "Can't close tmpimp.imp"; # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" and die "Cannot make import library: $!, \$?=$?"; # May be running under miniperl, so have no glob... eval { unlink <tmp_imp/*>; 1 } or system "rm tmp_imp/*"; system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" and die "Cannot extract import objects: $!, \$?=$?"; } return '' if $self->{SKIPHASH}{'dynamic'}; $self->xs_dlsyms_iterator(\%attribs); } sub xs_dlsyms_ext { '.def'; } sub xs_dlsyms_extra { join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS); } sub static_lib_pure_cmd { my($self) = @_; my $old = $self->SUPER::static_lib_pure_cmd; return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; $old . <<'EOC'; $(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/* $(RANLIB) "$@" EOC } sub replace_manpage_separator { my($self,$man) = @_; $man =~ s,/+,.,g; $man; } sub maybe_command { my($self,$file) = @_; $file =~ s,[/\\]+,/,g; return $file if -x $file && ! -d _; return "$file.exe" if -x "$file.exe" && ! -d _; return "$file.cmd" if -x "$file.cmd" && ! -d _; return; } =item init_linker =cut sub init_linker { my $self = shift; $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)"; $self->{PERL_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout ? '' : '$(PERL_INC)/libperl_override$(LIB_EXT)'; $self->{EXPORT_LIST} = '$(BASEEXT).def'; } =item os_flavor OS/2 is OS/2 =cut sub os_flavor { return('OS/2'); } =item xs_static_lib_is_xs =cut sub xs_static_lib_is_xs { return 1; } =back =cut 1; perl5/ExtUtils/MM_UWIN.pm 0000444 00000001742 14711220107 0011062 0 ustar 00 package ExtUtils::MM_UWIN; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); =head1 NAME ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix =head1 SYNOPSIS Don't use this module directly. Use ExtUtils::MM and let it choose. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for the AT&T U/WIN UNIX on Windows environment. Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods =over 4 =item os_flavor In addition to being Unix, we're U/WIN. =cut sub os_flavor { return('Unix', 'U/WIN'); } =item B<replace_manpage_separator> =cut sub replace_manpage_separator { my($self, $man) = @_; $man =~ s,/+,.,g; return $man; } =back =head1 AUTHOR Michael G Schwern <schwern@pobox.com> with code from ExtUtils::MM_Unix =head1 SEE ALSO L<ExtUtils::MM_Win32>, L<ExtUtils::MakeMaker> =cut 1; perl5/ExtUtils/Manifest.pm 0000444 00000055617 14711220111 0011462 0 ustar 00 package ExtUtils::Manifest; require Exporter; use Config; use File::Basename; use File::Copy 'copy'; use File::Find; use File::Spec 0.8; use Carp; use strict; use warnings; our $VERSION = '1.70'; our @ISA = ('Exporter'); our @EXPORT_OK = qw(mkmanifest manicheck filecheck fullcheck skipcheck manifind maniread manicopy maniadd maniskip ); our $Is_MacOS = $^O eq 'MacOS'; our $Is_VMS = $^O eq 'VMS'; our $Is_VMS_mode = 0; our $Is_VMS_lc = 0; our $Is_VMS_nodot = 0; # No dots in dir names or double dots in files if ($Is_VMS) { require VMS::Filespec if $Is_VMS; my $vms_unix_rpt; my $vms_efs; my $vms_case; $Is_VMS_mode = 1; $Is_VMS_lc = 1; $Is_VMS_nodot = 1; if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); $vms_efs = VMS::Feature::current("efs_charset"); $vms_case = VMS::Feature::current("efs_case_preserve"); } else { my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; $vms_efs = $efs_charset =~ /^[ET1]/i; $vms_case = $efs_case =~ /^[ET1]/i; } $Is_VMS_lc = 0 if ($vms_case); $Is_VMS_mode = 0 if ($vms_unix_rpt); $Is_VMS_nodot = 0 if ($vms_efs); } our $Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; our $Quiet = 0; our $MANIFEST = 'MANIFEST'; our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); =head1 NAME ExtUtils::Manifest - utilities to write and check a MANIFEST file =head1 VERSION version 1.70 =head1 SYNOPSIS use ExtUtils::Manifest qw(...funcs to import...); mkmanifest(); my @missing_files = manicheck; my @skipped = skipcheck; my @extra_files = filecheck; my($missing, $extra) = fullcheck; my $found = manifind(); my $manifest = maniread(); manicopy($read,$target); maniadd({$file => $comment, ...}); =head1 DESCRIPTION =head2 Functions ExtUtils::Manifest exports no functions by default. The following are exported on request =over 4 =item mkmanifest mkmanifest(); Writes all files in and below the current directory to your F<MANIFEST>. It works similar to the result of the Unix command find . > MANIFEST All files that match any regular expression in a file F<MANIFEST.SKIP> (if it exists) are ignored. Any existing F<MANIFEST> file will be saved as F<MANIFEST.bak>. =cut sub _sort { return sort { lc $a cmp lc $b } @_; } sub mkmanifest { my $manimiss = 0; my $read = (-r 'MANIFEST' && maniread()) or $manimiss++; $read = {} if $manimiss; local *M; my $bakbase = $MANIFEST; $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots rename $MANIFEST, "$bakbase.bak" unless $manimiss; open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!"; binmode M, ':raw'; my $skip = maniskip(); my $found = manifind(); my($key,$val,$file,%all); %all = (%$found, %$read); $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') . 'This list of files' if $manimiss; # add new MANIFEST to known file list foreach $file (_sort keys %all) { if ($skip->($file)) { # Policy: only remove files if they're listed in MANIFEST.SKIP. # Don't remove files just because they don't exist. warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file}; next; } if ($Verbose){ warn "Added to $MANIFEST: $file\n" unless exists $read->{$file}; } my $text = $all{$file}; $file = _unmacify($file); my $tabs = (5 - (length($file)+1)/8); $tabs = 1 if $tabs < 1; $tabs = 0 unless $text; if ($file =~ /\s/) { $file =~ s/([\\'])/\\$1/g; $file = "'$file'"; } print M $file, "\t" x $tabs, $text, "\n"; } close M; } # Geez, shouldn't this use File::Spec or File::Basename or something? # Why so careful about dependencies? sub clean_up_filename { my $filename = shift; $filename =~ s|^\./||; $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS; if ( $Is_VMS ) { $filename =~ s/\.$//; # trim trailing dot $filename = VMS::Filespec::unixify($filename); # unescape spaces, etc. if( $Is_VMS_lc ) { $filename = lc($filename); $filename = uc($filename) if $filename =~ /^MANIFEST(\.SKIP)?$/i; } } return $filename; } =item manifind my $found = manifind(); returns a hash reference. The keys of the hash are the files found below the current directory. =cut sub manifind { my $p = shift || {}; my $found = {}; my $wanted = sub { my $name = clean_up_filename($File::Find::name); warn "Debug: diskfile $name\n" if $Debug; return if -d $_; $found->{$name} = ""; }; # We have to use "$File::Find::dir/$_" in preprocess, because # $File::Find::name is unavailable. # Also, it's okay to use / here, because MANIFEST files use Unix-style # paths. find({wanted => $wanted, follow_fast => 1}, $Is_MacOS ? ":" : "."); return $found; } =item manicheck my @missing_files = manicheck(); checks if all the files within a C<MANIFEST> in the current directory really do exist. If C<MANIFEST> and the tree below the current directory are in sync it silently returns an empty list. Otherwise it returns a list of files which are listed in the C<MANIFEST> but missing from the directory, and by default also outputs these names to STDERR. =cut sub manicheck { return _check_files(); } =item filecheck my @extra_files = filecheck(); finds files below the current directory that are not mentioned in the C<MANIFEST> file. An optional file C<MANIFEST.SKIP> will be consulted. Any file matching a regular expression in such a file will not be reported as missing in the C<MANIFEST> file. The list of any extraneous files found is returned, and by default also reported to STDERR. =cut sub filecheck { return _check_manifest(); } =item fullcheck my($missing, $extra) = fullcheck(); does both a manicheck() and a filecheck(), returning then as two array refs. =cut sub fullcheck { return [_check_files()], [_check_manifest()]; } =item skipcheck my @skipped = skipcheck(); lists all the files that are skipped due to your C<MANIFEST.SKIP> file. =cut sub skipcheck { my($p) = @_; my $found = manifind(); my $matches = maniskip(); my @skipped = (); foreach my $file (_sort keys %$found){ if (&$matches($file)){ warn "Skipping $file\n" unless $Quiet; push @skipped, $file; next; } } return @skipped; } sub _check_files { my $p = shift; my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0); my $read = maniread() || {}; my $found = manifind($p); my(@missfile) = (); foreach my $file (_sort keys %$read){ warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; if ($dosnames){ $file = lc $file; $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge; $file =~ s=((\w|-)+)=substr ($1,0,8)=ge; } unless ( exists $found->{$file} ) { warn "No such file: $file\n" unless $Quiet; push @missfile, $file; } } return @missfile; } sub _check_manifest { my($p) = @_; my $read = maniread() || {}; my $found = manifind($p); my $skip = maniskip(); my @missentry = (); foreach my $file (_sort keys %$found){ next if $skip->($file); warn "Debug: manicheck checking from disk $file\n" if $Debug; unless ( exists $read->{$file} ) { my $canon = $Is_MacOS ? "\t" . _unmacify($file) : ''; warn "Not in $MANIFEST: $file$canon\n" unless $Quiet; push @missentry, $file; } } return @missentry; } =item maniread my $manifest = maniread(); my $manifest = maniread($manifest_file); reads a named C<MANIFEST> file (defaults to C<MANIFEST> in the current directory) and returns a HASH reference with files being the keys and comments being the values of the HASH. Blank lines and lines which start with C<#> in the C<MANIFEST> file are discarded. =cut sub maniread { my ($mfile) = @_; $mfile ||= $MANIFEST; my $read = {}; local *M; unless (open M, "< $mfile"){ warn "Problem opening $mfile: $!"; return $read; } local $_; while (<M>){ chomp; next if /^\s*#/; my($file, $comment); # filename may contain spaces if enclosed in '' # (in which case, \\ and \' are escapes) if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) { $file =~ s/\\([\\'])/$1/g; } else { ($file, $comment) = /^(\S+)\s*(.*)/; } next unless $file; if ($Is_MacOS) { $file = _macify($file); $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge; } elsif ($Is_VMS_mode) { require File::Basename; my($base,$dir) = File::Basename::fileparse($file); # Resolve illegal file specifications in the same way as tar if ($Is_VMS_nodot) { $dir =~ tr/./_/; my(@pieces) = split(/\./,$base); if (@pieces > 2) { $base = shift(@pieces) . '.' . join('_',@pieces); } my $okfile = "$dir$base"; warn "Debug: Illegal name $file changed to $okfile\n" if $Debug; $file = $okfile; } if( $Is_VMS_lc ) { $file = lc($file); $file = uc($file) if $file =~ /^MANIFEST(\.SKIP)?$/i; } } $read->{$file} = $comment; } close M; $read; } =item maniskip my $skipchk = maniskip(); my $skipchk = maniskip($manifest_skip_file); if ($skipchk->($file)) { .. } reads a named C<MANIFEST.SKIP> file (defaults to C<MANIFEST.SKIP> in the current directory) and returns a CODE reference that tests whether a given filename should be skipped. =cut # returns an anonymous sub that decides if an argument matches sub maniskip { my @skip ; my $mfile = shift || "$MANIFEST.SKIP"; _check_mskip_directives($mfile) if -f $mfile; local(*M, $_); open M, "< $mfile" or open M, "< $DEFAULT_MSKIP" or return sub {0}; while (<M>){ chomp; s/\r//; $_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$}; #my $comment = $3; my $filename = $2; if ( defined($1) ) { $filename = $1; $filename =~ s/\\(['\\])/$1/g; } next if (not defined($filename) or not $filename); push @skip, _macify($filename); } close M; return sub {0} unless (scalar @skip > 0); my $opts = $Is_VMS_mode ? '(?i)' : ''; # Make sure each entry is isolated in its own parentheses, in case # any of them contain alternations my $regex = join '|', map "(?:$_)", @skip; return sub { $_[0] =~ qr{$opts$regex} }; } # checks for the special directives # #!include_default # #!include /path/to/some/manifest.skip # in a custom MANIFEST.SKIP for, for including # the content of, respectively, the default MANIFEST.SKIP # and an external manifest.skip file sub _check_mskip_directives { my $mfile = shift; local (*M, $_); my @lines = (); my $flag = 0; unless (open M, "< $mfile") { warn "Problem opening $mfile: $!"; return; } while (<M>) { if (/^#!include_default\s*$/) { if (my @default = _include_mskip_file()) { push @lines, @default; warn "Debug: Including default MANIFEST.SKIP\n" if $Debug; $flag++; } next; } if (/^#!include\s+(.*)\s*$/) { my $external_file = $1; if (my @external = _include_mskip_file($external_file)) { push @lines, @external; warn "Debug: Including external $external_file\n" if $Debug; $flag++; } next; } push @lines, $_; } close M; return unless $flag; my $bakbase = $mfile; $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots rename $mfile, "$bakbase.bak"; warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug; unless (open M, "> $mfile") { warn "Problem opening $mfile: $!"; return; } binmode M, ':raw'; print M $_ for (@lines); close M; return; } # returns an array containing the lines of an external # manifest.skip file, if given, or $DEFAULT_MSKIP sub _include_mskip_file { my $mskip = shift || $DEFAULT_MSKIP; unless (-f $mskip) { warn qq{Included file "$mskip" not found - skipping}; return; } local (*M, $_); unless (open M, "< $mskip") { warn "Problem opening $mskip: $!"; return; } my @lines = (); push @lines, "\n#!start included $mskip\n"; push @lines, $_ while <M>; close M; push @lines, "#!end included $mskip\n\n"; return @lines; } =item manicopy manicopy(\%src, $dest_dir); manicopy(\%src, $dest_dir, $how); Copies the files that are the keys in %src to the $dest_dir. %src is typically returned by the maniread() function. manicopy( maniread(), $dest_dir ); This function is useful for producing a directory tree identical to the intended distribution tree. $how can be used to specify a different methods of "copying". Valid values are C<cp>, which actually copies the files, C<ln> which creates hard links, and C<best> which mostly links the files but copies any symbolic link to make a tree without any symbolic link. C<cp> is the default. =cut sub manicopy { my($read,$target,$how)=@_; croak "manicopy() called without target argument" unless defined $target; $how ||= 'cp'; require File::Path; require File::Basename; $target = VMS::Filespec::unixify($target) if $Is_VMS_mode; File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); foreach my $file (keys %$read){ if ($Is_MacOS) { if ($file =~ m!:!) { my $dir = _maccat($target, $file); $dir =~ s/[^:]+$//; File::Path::mkpath($dir,1,0755); } cp_if_diff($file, _maccat($target, $file), $how); } else { $file = VMS::Filespec::unixify($file) if $Is_VMS_mode; if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? my $dir = File::Basename::dirname($file); $dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode; File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); } cp_if_diff($file, "$target/$file", $how); } } } sub cp_if_diff { my($from, $to, $how)=@_; if (! -f $from) { carp "$from not found"; return; } my($diff) = 0; local(*F,*T); open(F,"< $from\0") or die "Can't read $from: $!\n"; if (open(T,"< $to\0")) { local $_; while (<F>) { $diff++,last if $_ ne <T>; } $diff++ unless eof(T); close T; } else { $diff++; } close F; if ($diff) { if (-e $to) { unlink($to) or confess "unlink $to: $!"; } STRICT_SWITCH: { best($from,$to), last STRICT_SWITCH if $how eq 'best'; cp($from,$to), last STRICT_SWITCH if $how eq 'cp'; ln($from,$to), last STRICT_SWITCH if $how eq 'ln'; croak("ExtUtils::Manifest::cp_if_diff " . "called with illegal how argument [$how]. " . "Legal values are 'best', 'cp', and 'ln'."); } } } sub cp { my ($srcFile, $dstFile) = @_; my ($access,$mod) = (stat $srcFile)[8,9]; copy($srcFile,$dstFile); utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; _manicopy_chmod($srcFile, $dstFile); } sub ln { my ($srcFile, $dstFile) = @_; # Fix-me - VMS can support links. return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); link($srcFile, $dstFile); unless( _manicopy_chmod($srcFile, $dstFile) ) { unlink $dstFile; return; } 1; } # 1) Strip off all group and world permissions. # 2) Let everyone read it. # 3) If the owner can execute it, everyone can. sub _manicopy_chmod { my($srcFile, $dstFile) = @_; my $perm = 0444 | (stat $srcFile)[2] & 0700; chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile ); } # Files that are often modified in the distdir. Don't hard link them. my @Exceptions = qw(MANIFEST META.yml SIGNATURE); sub best { my ($srcFile, $dstFile) = @_; my $is_exception = grep $srcFile =~ /$_/, @Exceptions; if ($is_exception or !$Config{d_link} or -l $srcFile) { cp($srcFile, $dstFile); } else { ln($srcFile, $dstFile) or cp($srcFile, $dstFile); } } sub _macify { my($file) = @_; return $file unless $Is_MacOS; $file =~ s|^\./||; if ($file =~ m|/|) { $file =~ s|/+|:|g; $file = ":$file"; } $file; } sub _maccat { my($f1, $f2) = @_; return "$f1/$f2" unless $Is_MacOS; $f1 .= ":$f2"; $f1 =~ s/([^:]:):/$1/g; return $f1; } sub _unmacify { my($file) = @_; return $file unless $Is_MacOS; $file =~ s|^:||; $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge; $file =~ y|:|/|; $file; } =item maniadd maniadd({ $file => $comment, ...}); Adds an entry to an existing F<MANIFEST> unless its already there. $file will be normalized (ie. Unixified). B<UNIMPLEMENTED> =cut sub maniadd { my($additions) = shift; _normalize($additions); _fix_manifest($MANIFEST); my $manifest = maniread(); my @needed = grep { !exists $manifest->{$_} } keys %$additions; return 1 unless @needed; open(MANIFEST, ">>$MANIFEST") or die "maniadd() could not open $MANIFEST: $!"; binmode MANIFEST, ':raw'; foreach my $file (_sort @needed) { my $comment = $additions->{$file} || ''; if ($file =~ /\s/) { $file =~ s/([\\'])/\\$1/g; $file = "'$file'"; } printf MANIFEST "%-40s %s\n", $file, $comment; } close MANIFEST or die "Error closing $MANIFEST: $!"; return 1; } # Make sure this MANIFEST is consistently written with native # newlines and has a terminal newline. sub _fix_manifest { my $manifest_file = shift; open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!"; local $/; my @manifest = split /(\015\012|\012|\015)/, <MANIFEST>, -1; close MANIFEST; my $must_rewrite = ""; if ($manifest[-1] eq ""){ # sane case: last line had a terminal newline pop @manifest; for (my $i=1; $i<=$#manifest; $i+=2) { unless ($manifest[$i] eq "\n") { $must_rewrite = "not a newline at pos $i"; last; } } } else { $must_rewrite = "last line without newline"; } if ( $must_rewrite ) { 1 while unlink $MANIFEST; # avoid multiple versions on VMS open MANIFEST, ">", $MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!"; binmode MANIFEST, ':raw'; for (my $i=0; $i<=$#manifest; $i+=2) { print MANIFEST "$manifest[$i]\n"; } close MANIFEST or die "could not write $MANIFEST: $!"; } } # UNIMPLEMENTED sub _normalize { return; } =back =head2 MANIFEST A list of files in the distribution, one file per line. The MANIFEST always uses Unix filepath conventions even if you're not on Unix. This means F<foo/bar> style not F<foo\bar>. Anything between white space and an end of line within a C<MANIFEST> file is considered to be a comment. Any line beginning with # is also a comment. Beginning with ExtUtils::Manifest 1.52, a filename may contain whitespace characters if it is enclosed in single quotes; single quotes or backslashes in that filename must be backslash-escaped. # this a comment some/file some/other/file comment about some/file 'some/third file' comment =head2 MANIFEST.SKIP The file MANIFEST.SKIP may contain regular expressions of files that should be ignored by mkmanifest() and filecheck(). The regular expressions should appear one on each line. Blank lines and lines which start with C<#> are skipped. Use C<\#> if you need a regular expression to start with a C<#>. For example: # Version control files and dirs. \bRCS\b \bCVS\b ,v$ \B\.svn\b # Makemaker generated files and dirs. ^MANIFEST\. ^Makefile$ ^blib/ ^MakeMaker-\d # Temp, old and emacs backup files. ~$ \.old$ ^#.*#$ ^\.# If no MANIFEST.SKIP file is found, a default set of skips will be used, similar to the example above. If you want nothing skipped, simply make an empty MANIFEST.SKIP file. In one's own MANIFEST.SKIP file, certain directives can be used to include the contents of other MANIFEST.SKIP files. At present two such directives are recognized. =over 4 =item #!include_default This inserts the contents of the default MANIFEST.SKIP file =item #!include /Path/to/another/manifest.skip This inserts the contents of the specified external file =back The included contents will be inserted into the MANIFEST.SKIP file in between I<#!start included /path/to/manifest.skip> and I<#!end included /path/to/manifest.skip> markers. The original MANIFEST.SKIP is saved as MANIFEST.SKIP.bak. =head2 EXPORT_OK C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>, C<&maniread>, and C<&manicopy> are exportable. =head2 GLOBAL VARIABLES C<$ExtUtils::Manifest::MANIFEST> defaults to C<MANIFEST>. Changing it results in both a different C<MANIFEST> and a different C<MANIFEST.SKIP> file. This is useful if you want to maintain different distributions for different audiences (say a user version and a developer version including RCS). C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, all functions act silently. C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value, or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be produced. =head1 DIAGNOSTICS All diagnostic output is sent to C<STDERR>. =over 4 =item C<Not in MANIFEST:> I<file> is reported if a file is found which is not in C<MANIFEST>. =item C<Skipping> I<file> is reported if a file is skipped due to an entry in C<MANIFEST.SKIP>. =item C<No such file:> I<file> is reported if a file mentioned in a C<MANIFEST> file does not exist. =item C<MANIFEST:> I<$!> is reported if C<MANIFEST> could not be opened. =item C<Added to MANIFEST:> I<file> is reported by mkmanifest() if $Verbose is set and a file is added to MANIFEST. $Verbose is set to 1 by default. =back =head1 ENVIRONMENT =over 4 =item B<PERL_MM_MANIFEST_DEBUG> Turns on debugging =back =head1 SEE ALSO L<ExtUtils::MakeMaker> which has handy targets for most of the functionality. =head1 AUTHOR Andreas Koenig C<andreas.koenig@anima.de> Currently maintained by the Perl Toolchain Gang. =head1 COPYRIGHT AND LICENSE This software is copyright (c) 1996- by Andreas Koenig. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut 1; perl5/ExtUtils/MM_Win95.pm 0000444 00000002415 14711220120 0011204 0 ustar 00 package ExtUtils::MM_Win95; use strict; use warnings; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Win32; our @ISA = qw(ExtUtils::MM_Win32); use ExtUtils::MakeMaker::Config; =head1 NAME ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X =head1 SYNOPSIS You should not be using this module directly. =head1 DESCRIPTION This is a subclass of L<ExtUtils::MM_Win32> containing changes necessary to get MakeMaker playing nice with command.com and other Win9Xisms. =head2 Overridden methods Most of these make up for limitations in the Win9x/nmake command shell. =over 4 =item max_exec_len Win98 chokes on things like Encode if we set the max length to nmake's max of 2K. So we go for a more conservative value of 1K. =cut sub max_exec_len { my $self = shift; return $self->{_MAX_EXEC_LEN} ||= 1024; } =item os_flavor Win95 and Win98 and WinME are collectively Win9x and Win32 =cut sub os_flavor { my $self = shift; return ($self->SUPER::os_flavor, 'Win9x'); } =back =head1 AUTHOR Code originally inside MM_Win32. Original author unknown. Currently maintained by Michael G Schwern C<schwern@pobox.com>. Send patches and ideas to C<makemaker@perl.org>. See https://metacpan.org/release/ExtUtils-MakeMaker. =cut 1; perl5/ExtUtils/MM_Darwin.pm 0000444 00000002711 14711220122 0011516 0 ustar 00 package ExtUtils::MM_Darwin; use strict; use warnings; BEGIN { require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Unix ); } our $VERSION = '7.62'; $VERSION =~ tr/_//d; =head1 NAME ExtUtils::MM_Darwin - special behaviors for OS X =head1 SYNOPSIS For internal MakeMaker use only =head1 DESCRIPTION See L<ExtUtils::MM_Unix> or L<ExtUtils::MM_Any> for documentation on the methods overridden here. =head2 Overridden Methods =head3 init_dist Turn off Apple tar's tendency to copy resource forks as "._foo" files. =cut sub init_dist { my $self = shift; # Thank you, Apple, for breaking tar and then breaking the work around. # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants # COPYFILE_DISABLE. I'm not going to push my luck and instead just # set both. $self->{TAR} ||= 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar'; $self->SUPER::init_dist(@_); } =head3 cflags Over-ride Apple's automatic setting of -Werror =cut sub cflags { my($self,$libperl)=@_; return $self->{CFLAGS} if $self->{CFLAGS}; return '' unless $self->needs_linking(); my $base = $self->SUPER::cflags($libperl); foreach (split /\n/, $base) { /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; }; $self->{CCFLAGS} .= " -Wno-error=implicit-function-declaration"; return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} }; } 1; perl5/ExtUtils/MY.pm 0000444 00000001244 14711220124 0010230 0 ustar 00 package ExtUtils::MY; use strict; require ExtUtils::MM; our $VERSION = '7.62'; $VERSION =~ tr/_//d; our @ISA = qw(ExtUtils::MM); { package MY; our @ISA = qw(ExtUtils::MY); } sub DESTROY {} =head1 NAME ExtUtils::MY - ExtUtils::MakeMaker subclass for customization =head1 SYNOPSIS # in your Makefile.PL sub MY::whatever { ... } =head1 DESCRIPTION B<FOR INTERNAL USE ONLY> ExtUtils::MY is a subclass of L<ExtUtils::MM>. Its provided in your Makefile.PL for you to add and override MakeMaker functionality. It also provides a convenient alias via the MY class. ExtUtils::MY might turn out to be a temporary solution, but MY won't go away. =cut perl5/ExtUtils/MM_BeOS.pm 0000444 00000002046 14711220124 0011065 0 ustar 00 package ExtUtils::MM_BeOS; use strict; use warnings; =head1 NAME ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 SYNOPSIS use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed =head1 DESCRIPTION See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. =over 4 =cut use ExtUtils::MakeMaker::Config; use File::Spec; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); our $VERSION = '7.62'; $VERSION =~ tr/_//d; =item os_flavor BeOS is BeOS. =cut sub os_flavor { return('BeOS'); } =item init_linker libperl.a equivalent to be linked to dynamic extensions. =cut sub init_linker { my($self) = shift; $self->{PERL_ARCHIVE} ||= File::Spec->catdir('$(PERL_INC)',$Config{libperl}); $self->{PERL_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; $self->{EXPORT_LIST} ||= ''; } =back =cut 1; __END__ perl5/ExtUtils/ParseXS.pod 0000444 00000010466 14711220126 0011406 0 ustar 00 =head1 NAME ExtUtils::ParseXS - converts Perl XS code into C code =head1 SYNOPSIS use ExtUtils::ParseXS; my $pxs = ExtUtils::ParseXS->new; $pxs->process_file( filename => 'foo.xs' ); $pxs->process_file( filename => 'foo.xs', output => 'bar.c', 'C++' => 1, typemap => 'path/to/typemap', hiertype => 1, except => 1, versioncheck => 1, linenumbers => 1, optimize => 1, prototypes => 1, ); # Legacy non-OO interface using a singleton: use ExtUtils::ParseXS qw(process_file); process_file( filename => 'foo.xs' ); =head1 DESCRIPTION C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs necessary to let C functions manipulate Perl values and creates the glue necessary to let Perl access those functions. The compiler uses typemaps to determine how to map C function parameters and variables to Perl values. The compiler will search for typemap files called I<typemap>. It will use the following search path to find default typemaps, with the rightmost typemap taking precedence. ../../../typemap:../../typemap:../typemap:typemap =head1 EXPORT None by default. C<process_file()> and/or C<report_error_count()> may be exported upon request. Using the functional interface is discouraged. =head1 METHODS =over 4 =item $pxs->new() Returns a new, empty XS parser/compiler object. =item $pxs->process_file() This method processes an XS file and sends output to a C file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. Named parameters control how the processing is done. The following parameters are accepted: =over 4 =item B<C++> Adds C<extern "C"> to the C code. Default is false. =item B<hiertype> Retains C<::> in type names so that C++ hierarchical types can be mapped. Default is false. =item B<except> Adds exception handling stubs to the C code. Default is false. =item B<typemap> Indicates that a user-supplied typemap should take precedence over the default typemaps. A single typemap may be specified as a string, or multiple typemaps can be specified in an array reference, with the last typemap having the highest precedence. =item B<prototypes> Generates prototype code for all xsubs. Default is false. =item B<versioncheck> Makes sure at run time that the object file (derived from the C<.xs> file) and the C<.pm> files have the same version number. Default is true. =item B<linenumbers> Adds C<#line> directives to the C output so error messages will look like they came from the original XS file. Default is true. =item B<optimize> Enables certain optimizations. The only optimization that is currently affected is the use of I<target>s by the output C code (see L<perlguts>). Not optimizing may significantly slow down the generated code, but this is the way B<xsubpp> of 5.005 and earlier operated. Default is to optimize. =item B<inout> Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. Default is true. =item B<argtypes> Enable recognition of ANSI-like descriptions of function signature. Default is true. =item B<s> I<Maintainer note:> I have no clue what this does. Strips function prefixes? =back =item $pxs->report_error_count() This method returns the number of [a certain kind of] errors encountered during processing of the XS file. The method may be called as a function (this is the legacy interface) and will then use a singleton as invocant. =back =head1 AUTHOR Based on xsubpp code, written by Larry Wall. Maintained by: =over 4 =item * Ken Williams, <ken@mathforum.org> =item * David Golden, <dagolden@cpan.org> =item * James Keenan, <jkeenan@cpan.org> =item * Steffen Mueller, <smueller@cpan.org> =back =head1 COPYRIGHT Copyright 2002-2014 by Ken Williams, David Golden and other contributors. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Based on the C<ExtUtils::xsubpp> code by Larry Wall and the Perl 5 Porters, which was released under the same license terms. =head1 SEE ALSO L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>. =cut perl5/ExtUtils/MM.pm 0000444 00000004210 14711220127 0010213 0 ustar 00 package ExtUtils::MM; use strict; use warnings; use ExtUtils::MakeMaker::Config; our $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::Liblist; require ExtUtils::MakeMaker; our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker); =head1 NAME ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass =head1 SYNOPSIS require ExtUtils::MM; my $mm = MM->new(...); =head1 DESCRIPTION B<FOR INTERNAL USE ONLY> ExtUtils::MM is a subclass of L<ExtUtils::MakeMaker> which automatically chooses the appropriate OS specific subclass for you (ie. L<ExtUtils::MM_Unix>, etc...). It also provides a convenient alias via the MM class (I didn't want MakeMaker modules outside of ExtUtils/). This class might turn out to be a temporary solution, but MM won't go away. =cut { # Convenient alias. package MM; our @ISA = qw(ExtUtils::MM); sub DESTROY {} } sub _is_win95 { # miniperl might not have the Win32 functions available and we need # to run in miniperl. my $have_win32 = eval { require Win32 }; return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95() : ! defined $ENV{SYSTEMROOT}; } my %Is = (); $Is{VMS} = $^O eq 'VMS'; $Is{OS2} = $^O eq 'os2'; $Is{MacOS} = $^O eq 'MacOS'; if( $^O eq 'MSWin32' ) { _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1; } $Is{UWIN} = $^O =~ /^uwin(-nt)?$/; $Is{Cygwin} = $^O eq 'cygwin'; $Is{NW5} = $Config{osname} eq 'NetWare'; # intentional $Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku'); $Is{DOS} = $^O eq 'dos'; if( $Is{NW5} ) { $^O = 'NetWare'; delete $Is{Win32}; } $Is{VOS} = $^O eq 'vos'; $Is{QNX} = $^O eq 'qnx'; $Is{AIX} = $^O eq 'aix'; $Is{Darwin} = $^O eq 'darwin'; $Is{OS390} = $^O eq 'os390'; $Is{Unix} = !grep { $_ } values %Is; map { delete $Is{$_} unless $Is{$_} } keys %Is; _assert( keys %Is == 1 ); my($OS) = keys %Is; my $class = "ExtUtils::MM_$OS"; eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic die $@ if $@; unshift @ISA, $class; sub _assert { my $sanity = shift; die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity; return; } perl5/ExtUtils/MM_Unix.pm 0000444 00000340764 14711220131 0011232 0 ustar 00 package ExtUtils::MM_Unix; require 5.006; use strict; use warnings; use Carp; use ExtUtils::MakeMaker::Config; use File::Basename qw(basename dirname); our %Config_Override; use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); # If we make $VERSION an our variable parse_version() breaks use vars qw($VERSION); $VERSION = '7.62'; $VERSION =~ tr/_//d; require ExtUtils::MM_Any; our @ISA = qw(ExtUtils::MM_Any); my %Is; BEGIN { $Is{OS2} = $^O eq 'os2'; $Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare'; $Is{Dos} = $^O eq 'dos'; $Is{VMS} = $^O eq 'VMS'; $Is{OSF} = $^O eq 'dec_osf'; $Is{IRIX} = $^O eq 'irix'; $Is{NetBSD} = $^O eq 'netbsd'; $Is{Interix} = $^O eq 'interix'; $Is{SunOS4} = $^O eq 'sunos'; $Is{Solaris} = $^O eq 'solaris'; $Is{SunOS} = $Is{SunOS4} || $Is{Solaris}; $Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or grep( $^O eq $_, qw(bsdos interix dragonfly) ) ); $Is{Android} = $^O =~ /android/; if ( $^O eq 'darwin' && $^X eq '/usr/bin/perl' ) { my @osvers = split /\./, $Config{osvers}; $Is{ApplCor} = ( $osvers[0] >= 18 ); } } BEGIN { if( $Is{VMS} ) { # For things like vmsify() require VMS::Filespec; VMS::Filespec->import; } } =head1 NAME ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker =head1 SYNOPSIS require ExtUtils::MM_Unix; =head1 DESCRIPTION The methods provided by this package are designed to be used in conjunction with L<ExtUtils::MakeMaker>. When MakeMaker writes a Makefile, it creates one or more objects that inherit their methods from a package L<MM|ExtUtils::MM>. MM itself doesn't provide any methods, but it ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating specific packages take the responsibility for all the methods provided by MM_Unix. We are trying to reduce the number of the necessary overrides by defining rather primitive operations within ExtUtils::MM_Unix. If you are going to write a platform specific MM package, please try to limit the necessary overrides to primitive methods, and if it is not possible to do so, let's work out how to achieve that gain. If you are overriding any of these methods in your Makefile.PL (in the MY class), please report that to the makemaker mailing list. We are trying to minimize the necessary method overrides and switch to data driven Makefile.PLs wherever possible. In the long run less methods will be overridable via the MY class. =head1 METHODS The following description of methods is still under development. Please refer to the code for not suitably documented sections and complain loudly to the makemaker@perl.org mailing list. Better yet, provide a patch. Not all of the methods below are overridable in a Makefile.PL. Overridable methods are marked as (o). All methods are overridable by a platform specific MM_*.pm file. Cross-platform methods are being moved into L<MM_Any|ExtUtils::MM_Any>. If you can't find something that used to be in here, look in MM_Any. =cut # So we don't have to keep calling the methods over and over again, # we have these globals to cache the values. Faster and shrtr. my $Curdir = __PACKAGE__->curdir; my $Updir = __PACKAGE__->updir; =head2 Methods =over 4 =item os_flavor Simply says that we're Unix. =cut sub os_flavor { return('Unix'); } =item c_o (o) Defines the suffix rules to compile different flavors of C files to object files. =cut sub c_o { # --- Translation Sections --- my($self) = shift; return '' unless $self->needs_linking(); my(@m); my $command = '$(CCCMD)'; my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)'; if ( $Is{ApplCor} ) { $flags =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/; } if (my $cpp = $Config{cpprun}) { my $cpp_cmd = $self->const_cccmd; $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/; push @m, qq{ .c.i: $cpp_cmd $flags \$*.c > \$*.i }; } my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*.s') : ''; push @m, sprintf <<'EOF', $command, $flags, $m_o; .c.s : %s -S %s $*.c %s EOF my @exts = qw(c cpp cxx cc); push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : ''; my $dbgout = $self->dbgoutflag; for my $ext (@exts) { push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags " .($dbgout?"$dbgout ":'') ."\$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n"; } return join "", @m; } =item xs_obj_opt Takes the object file as an argument, and returns the portion of compile command-line that will output to the specified object file. =cut sub xs_obj_opt { my ($self, $output_file) = @_; "-o $output_file"; } =item dbgoutflag Returns a CC flag that tells the CC to emit a separate debugging symbol file when compiling an object file. =cut sub dbgoutflag { ''; } =item cflags (o) Does very much the same as the cflags script in the perl distribution. It doesn't return the whole compiler command line, but initializes all of its parts. The const_cccmd method then actually returns the definition of the CCCMD macro which uses these parts. =cut #' sub cflags { my($self,$libperl)=@_; return $self->{CFLAGS} if $self->{CFLAGS}; return '' unless $self->needs_linking(); my($prog, $uc, $perltype, %cflags); $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; @cflags{qw(cc ccflags optimize shellflags)} = @Config{qw(cc ccflags optimize shellflags)}; # Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89) # flags to the %Config, and the modules in the core should be built # with the warning flags, but NOT the -std=c89 flags (the latter # would break using any system header files that are strict C99). my @ccextraflags = qw(ccwarnflags); if ($ENV{PERL_CORE}) { for my $x (@ccextraflags) { if (exists $Config{$x}) { $cflags{$x} = $Config{$x}; } } } my($optdebug) = ""; $cflags{shellflags} ||= ''; my(%map) = ( D => '-DDEBUGGING', E => '-DEMBED', DE => '-DDEBUGGING -DEMBED', M => '-DEMBED -DMULTIPLICITY', DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY', ); if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){ $uc = uc($1); } else { $uc = ""; # avoid warning } $perltype = $map{$uc} ? $map{$uc} : ""; if ($uc =~ /^D/) { $optdebug = "-g"; } my($name); ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; if ($prog = $Config{$name}) { # Expand hints for this extension via the shell print "Processing $name hint:\n" if $Verbose; my(@o)=`cc=\"$cflags{cc}\" ccflags=\"$cflags{ccflags}\" optimize=\"$cflags{optimize}\" perltype=\"$cflags{perltype}\" optdebug=\"$cflags{optdebug}\" eval '$prog' echo cc=\$cc echo ccflags=\$ccflags echo optimize=\$optimize echo perltype=\$perltype echo optdebug=\$optdebug `; foreach my $line (@o){ chomp $line; if ($line =~ /(.*?)=\s*(.*)\s*$/){ $cflags{$1} = $2; print " $1 = $2\n" if $Verbose; } else { print "Unrecognised result from hint: '$line'\n"; } } } if ($optdebug) { $cflags{optimize} = $optdebug; } for (qw(ccflags optimize perltype)) { $cflags{$_} ||= ''; $cflags{$_} =~ s/^\s+//; $cflags{$_} =~ s/\s+/ /g; $cflags{$_} =~ s/\s+$//; $self->{uc $_} ||= $cflags{$_}; } if ($self->{POLLUTE}) { $self->{CCFLAGS} .= ' -DPERL_POLLUTE '; } for my $x (@ccextraflags) { next unless exists $cflags{$x}; $self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x}; } my $pollute = ''; if ($Config{usemymalloc} and not $Config{bincompat5005} and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/ and $self->{PERL_MALLOC_OK}) { $pollute = '$(PERL_MALLOC_DEF)'; } return $self->{CFLAGS} = qq{ CCFLAGS = $self->{CCFLAGS} OPTIMIZE = $self->{OPTIMIZE} PERLTYPE = $self->{PERLTYPE} MPOLLUTE = $pollute }; } =item const_cccmd (o) Returns the full compiler call for C programs and stores the definition in CONST_CCCMD. =cut sub const_cccmd { my($self,$libperl)=@_; return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; return '' unless $self->needs_linking(); return $self->{CONST_CCCMD} = q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\ $(CCFLAGS) $(OPTIMIZE) \\ $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\ $(XS_DEFINE_VERSION)}; } =item const_config (o) Sets SHELL if needed, then defines a couple of constants in the Makefile that are imported from %Config. =cut sub const_config { # --- Constants Sections --- my($self) = shift; my @m = $self->specify_shell(); # Usually returns empty string push @m, <<"END"; # These definitions are from config.sh (via $INC{'Config.pm'}). # They may have been overridden via Makefile.PL or on the command line. END my(%once_only); foreach my $key (@{$self->{CONFIG}}){ # SITE*EXP macros are defined in &constants; avoid duplicates here next if $once_only{$key}; push @m, uc($key) , ' = ' , $self->{uc $key}, "\n"; $once_only{$key} = 1; } join('', @m); } =item const_loadlibs (o) Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See L<ExtUtils::Liblist> for details. =cut sub const_loadlibs { my($self) = shift; return "" unless $self->needs_linking; my @m; push @m, qq{ # $self->{NAME} might depend on some other libraries: # See ExtUtils::Liblist for details # }; for my $tmp (qw/ EXTRALIBS LDLOADLIBS BSLOADLIBS /) { next unless defined $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } # don't set LD_RUN_PATH if empty for my $tmp (qw/ LD_RUN_PATH /) { next unless $self->{$tmp}; push @m, "$tmp = $self->{$tmp}\n"; } return join "", @m; } =item constants (o) my $make_frag = $mm->constants; Prints out macros for lots of constants. =cut sub constants { my($self) = @_; my @m = (); $self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use for my $macro (qw( AR_STATIC_ARGS DIRFILESEP DFSEP NAME NAME_SYM VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR MAN1EXT MAN3EXT MAN1SECTION MAN3SECTION INSTALLDIRS INSTALL_BASE DESTDIR PREFIX PERLPREFIX SITEPREFIX VENDORPREFIX ), (map { ("INSTALL".$_, "DESTINSTALL".$_) } $self->installvars), qw( PERL_LIB PERL_ARCHLIB PERL_ARCHLIBDEP LIBPERL_A MYEXTLIB FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP PERL FULLPERL ABSPERL PERLRUN FULLPERLRUN ABSPERLRUN PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST PERL_CORE PERM_DIR PERM_RW PERM_RWX ) ) { next unless defined $self->{$macro}; # pathnames can have sharp signs in them; escape them so # make doesn't think it is a comment-start character. $self->{$macro} =~ s/#/\\#/g; $self->{$macro} = $self->quote_dep($self->{$macro}) if $ExtUtils::MakeMaker::macro_dep{$macro}; push @m, "$macro = $self->{$macro}\n"; } push @m, qq{ MAKEMAKER = $self->{MAKEMAKER} MM_VERSION = $self->{MM_VERSION} MM_REVISION = $self->{MM_REVISION} }; push @m, q{ # FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) # PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. }; for my $macro (qw/ MAKE FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT LDFROM LINKTYPE BOOTDEP / ) { next unless defined $self->{$macro}; push @m, "$macro = $self->{$macro}\n"; } push @m, " # Handy lists of source code files: XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})." C_FILES = ".$self->wraplist(sort @{$self->{C}})." O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})." H_FILES = ".$self->wraplist(sort @{$self->{H}})." MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})." MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})." "; push @m, q{ SDKROOT := $(shell xcrun --show-sdk-path) PERL_SYSROOT = $(SDKROOT) } if $Is{ApplCor} && $self->{'PERL_INC'} =~ m!^/System/Library/Perl/!; push @m, q{ # Where is the Config information that we are using/depend on CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_SYSROOT)$(PERL_INCDEP)$(DFSEP)config.h } if $Is{ApplCor}; push @m, q{ # Where is the Config information that we are using/depend on CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h } if -e $self->catfile( $self->{PERL_INC}, 'config.h' ) && !$Is{ApplCor}; push @m, qq{ # Where to build things INST_LIBDIR = $self->{INST_LIBDIR} INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR} INST_AUTODIR = $self->{INST_AUTODIR} INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} INST_STATIC = $self->{INST_STATIC} INST_DYNAMIC = $self->{INST_DYNAMIC} INST_BOOT = $self->{INST_BOOT} }; push @m, qq{ # Extra linker info EXPORT_LIST = $self->{EXPORT_LIST} PERL_ARCHIVE = $self->{PERL_ARCHIVE} PERL_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP} PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER} }; push @m, " TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n"; join('',@m); } =item depend (o) Same as macro for the depend attribute. =cut sub depend { my($self,%attribs) = @_; my(@m,$key,$val); for my $key (sort keys %attribs){ my $val = $attribs{$key}; next unless defined $key and defined $val; push @m, "$key : $val\n"; } join "", @m; } =item init_DEST $mm->init_DEST Defines the DESTDIR and DEST* variables paralleling the INSTALL*. =cut sub init_DEST { my $self = shift; # Initialize DESTDIR $self->{DESTDIR} ||= ''; # Make DEST variables. foreach my $var ($self->installvars) { my $destvar = 'DESTINSTALL'.$var; $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')'; } } =item init_dist $mm->init_dist; Defines a lot of macros for distribution support. macro description default TAR tar command to use tar TARFLAGS flags to pass to TAR cvf ZIP zip command to use zip ZIPFLAGS flags to pass to ZIP -r COMPRESS compression command to gzip --best use for tarfiles SUFFIX suffix to put on .gz compressed files SHAR shar command to use shar PREOP extra commands to run before making the archive POSTOP extra commands to run after making the archive TO_UNIX a command to convert linefeeds to Unix style in your archive CI command to checkin your ci -u sources to version control RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q just after CI is run DIST_CP $how argument to manicopy() best when the distdir is created DIST_DEFAULT default target to use to tardist create a distribution DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION) (minus suffixes) =cut sub init_dist { my $self = shift; $self->{TAR} ||= 'tar'; $self->{TARFLAGS} ||= 'cvf'; $self->{ZIP} ||= 'zip'; $self->{ZIPFLAGS} ||= '-r'; $self->{COMPRESS} ||= 'gzip --best'; $self->{SUFFIX} ||= '.gz'; $self->{SHAR} ||= 'shar'; $self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST $self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir $self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)'; $self->{CI} ||= 'ci -u'; $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q'; $self->{DIST_CP} ||= 'best'; $self->{DIST_DEFAULT} ||= 'tardist'; ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME}; $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION}; } =item dist (o) my $dist_macros = $mm->dist(%overrides); Generates a make fragment defining all the macros initialized in init_dist. %overrides can be used to override any of the above. =cut sub dist { my($self, %attribs) = @_; my $make = ''; if ( $attribs{SUFFIX} && $attribs{SUFFIX} !~ m!^\.! ) { $attribs{SUFFIX} = '.' . $attribs{SUFFIX}; } foreach my $key (qw( TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR PREOP POSTOP TO_UNIX CI RCS_LABEL DIST_CP DIST_DEFAULT DISTNAME DISTVNAME )) { my $value = $attribs{$key} || $self->{$key}; $make .= "$key = $value\n"; } return $make; } =item dist_basics (o) Defines the targets distclean, distcheck, skipcheck, manifest, veryclean. =cut sub dist_basics { my($self) = shift; return <<'MAKE_FRAG'; distclean :: realclean distcheck $(NOECHO) $(NOOP) distcheck : $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck skipcheck : $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck manifest : $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest veryclean : realclean $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old MAKE_FRAG } =item dist_ci (o) Defines a check in target for RCS. =cut sub dist_ci { my($self) = shift; return sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]); @all = sort keys %{ maniread() }; print(qq{Executing $(CI) @all\n}); system(qq{$(CI) @all}) == 0 or die $!; print(qq{Executing $(RCS_LABEL) ...\n}); system(qq{$(RCS_LABEL) @all}) == 0 or die $!; EOF } =item dist_core (o) my $dist_make_fragment = $MM->dist_core; Puts the targets necessary for 'make dist' together into one make fragment. =cut sub dist_core { my($self) = shift; my $make_frag = ''; foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile shdist)) { my $method = $target.'_target'; $make_frag .= "\n"; $make_frag .= $self->$method(); } return $make_frag; } =item B<dist_target> my $make_frag = $MM->dist_target; Returns the 'dist' target to make an archive for distribution. This target simply checks to make sure the Makefile is up-to-date and depends on $(DIST_DEFAULT). =cut sub dist_target { my($self) = shift; my $date_check = $self->oneliner(<<'CODE', ['-l']); print 'Warning: Makefile possibly out of date with $(VERSION_FROM)' if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)'; CODE return sprintf <<'MAKE_FRAG', $date_check; dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) $(NOECHO) %s MAKE_FRAG } =item B<tardist_target> my $make_frag = $MM->tardist_target; Returns the 'tardist' target which is simply so 'make tardist' works. The real work is done by the dynamically named tardistfile_target() method, tardist should have that as a dependency. =cut sub tardist_target { my($self) = shift; return <<'MAKE_FRAG'; tardist : $(DISTVNAME).tar$(SUFFIX) $(NOECHO) $(NOOP) MAKE_FRAG } =item B<zipdist_target> my $make_frag = $MM->zipdist_target; Returns the 'zipdist' target which is simply so 'make zipdist' works. The real work is done by the dynamically named zipdistfile_target() method, zipdist should have that as a dependency. =cut sub zipdist_target { my($self) = shift; return <<'MAKE_FRAG'; zipdist : $(DISTVNAME).zip $(NOECHO) $(NOOP) MAKE_FRAG } =item B<tarfile_target> my $make_frag = $MM->tarfile_target; The name of this target is the name of the tarball generated by tardist. This target does the actual work of turning the distdir into a tarball. =cut sub tarfile_target { my($self) = shift; return <<'MAKE_FRAG'; $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)' $(POSTOP) MAKE_FRAG } =item zipfile_target my $make_frag = $MM->zipfile_target; The name of this target is the name of the zip file generated by zipdist. This target does the actual work of turning the distdir into a zip file. =cut sub zipfile_target { my($self) = shift; return <<'MAKE_FRAG'; $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip' $(POSTOP) MAKE_FRAG } =item uutardist_target my $make_frag = $MM->uutardist_target; Converts the tarfile into a uuencoded file =cut sub uutardist_target { my($self) = shift; return <<'MAKE_FRAG'; uutardist : $(DISTVNAME).tar$(SUFFIX) uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu' MAKE_FRAG } =item shdist_target my $make_frag = $MM->shdist_target; Converts the distdir into a shell archive. =cut sub shdist_target { my($self) = shift; return <<'MAKE_FRAG'; shdist : distdir $(PREOP) $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar $(RM_RF) $(DISTVNAME) $(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar' $(POSTOP) MAKE_FRAG } =item dlsyms (o) Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files. Normally just returns an empty string. =cut sub dlsyms { return ''; } =item dynamic_bs (o) Defines targets for bootstrap files. =cut sub dynamic_bs { my($self, %attribs) = @_; return "\nBOOTSTRAP =\n" unless $self->has_link_code(); my @exts; if ($self->{XSMULTI}) { @exts = $self->_xs_list_basenames; } else { @exts = '$(BASEEXT)'; } return join "\n", "BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n", map { $self->_xs_make_bs($_) } @exts; } sub _xs_make_bs { my ($self, $basename) = @_; my ($v, $d, $f) = File::Spec->splitpath($basename); my @d = File::Spec->splitdir($d); shift @d if $self->{XSMULTI} and $d[0] eq 'lib'; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); $instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)'; my $instfile = $self->catfile($instdir, "$f.bs"); my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target # 1 2 3 return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists; # As Mkbootstrap might not write a file (if none is required) # we use touch to prevent make continually trying to remake it. # The DynaLoader only reads a non-empty file. %1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP) $(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))" $(NOECHO) $(PERLRUN) \ "-MExtUtils::Mkbootstrap" \ -e "Mkbootstrap('%1$s','$(BSLOADLIBS)');" $(NOECHO) $(TOUCH) "%1$s.bs" $(CHMOD) $(PERM_RW) "%1$s.bs" %2$s : %1$s.bs %3$s $(NOECHO) $(RM_RF) %2$s - $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW) MAKE_FRAG } =item dynamic_lib (o) Defines how to produce the *.so (or equivalent) files. =cut sub dynamic_lib { my($self, %attribs) = @_; return '' unless $self->needs_linking(); #might be because of a subdir return '' unless $self->has_link_code; my @m = $self->xs_dynamic_lib_macros(\%attribs); my @libs; my $dlsyms_ext = eval { $self->xs_dlsyms_ext }; if ($self->{XSMULTI}) { my @exts = $self->_xs_list_basenames; for my $ext (@exts) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; pop @d if $d[$#d] eq ''; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); # Dynamic library names may need special handling. eval { require DynaLoader }; if (defined &DynaLoader::mod2fname) { $f = &DynaLoader::mod2fname([@d, $f]); } my $instfile = $self->catfile($instdir, "$f.\$(DLEXT)"); my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT'); $objfile = "$ext\$(OBJ_EXT)" unless defined $objfile; my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM'); $ldfrom = $objfile unless defined $ldfrom; my $exportlist = "$ext.def"; my @libchunk = ($objfile, $instfile, $instdir, $ldfrom, $exportlist); push @libchunk, $dlsyms_ext ? $ext.$dlsyms_ext : undef; push @libs, \@libchunk; } } else { my @libchunk = qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST)); push @libchunk, $dlsyms_ext ? '$(BASEEXT)'.$dlsyms_ext : undef; @libs = (\@libchunk); } push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs; return join("\n",@m); } =item xs_dynamic_lib_macros Defines the macros for the C<dynamic_lib> section. =cut sub xs_dynamic_lib_macros { my ($self, $attribs) = @_; my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; my $armaybe = $self->_xs_armaybe($attribs); my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too? my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : ''; sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix; # This section creates the dynamically loadable objects from relevant # objects and possibly $(MYEXTLIB). ARMAYBE = %s OTHERLDFLAGS = %s INST_DYNAMIC_DEP = %s INST_DYNAMIC_FIX = %s EOF } sub _xs_armaybe { my ($self, $attribs) = @_; my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":"; $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':'); $armaybe; } =item xs_make_dynamic_lib Defines the recipes for the C<dynamic_lib> section. =cut sub xs_make_dynamic_lib { my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist, $dlsyms) = @_; $exportlist = '' if $exportlist ne '$(EXPORT_LIST)'; my $armaybe = $self->_xs_armaybe($attribs); my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP) %s'."\n", $to, $object, $todir, $exportlist, ($dlsyms || ''); my $dlsyms_arg = $self->xs_dlsyms_arg($dlsyms); if ($armaybe ne ':'){ $ldfrom = 'tmp$(LIB_EXT)'; push(@m," \$(ARMAYBE) cr $ldfrom $object\n"); push(@m," \$(RANLIB) $ldfrom\n"); } $ldfrom = "-all $ldfrom -none" if $Is{OSF}; # The IRIX linker doesn't use LD_RUN_PATH my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ? qq{-rpath "$self->{LD_RUN_PATH}"} : ''; # For example in AIX the shared objects/libraries from previous builds # linger quite a while in the shared dynalinker cache even when nobody # is using them. This is painful if one for instance tries to restart # a failed build because the link command will fail unnecessarily 'cos # the shared object/library is 'busy'. push(@m," \$(RM_F) \$\@\n"); my $libs = '$(LDLOADLIBS)'; if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') { # Use nothing on static perl platforms, and to the flags needed # to link against the shared libperl library on shared perl # platforms. We peek at lddlflags to see if we need -Wl,-R # or -R to add paths to the run-time library search path. if ($Config{'lddlflags'} =~ /-Wl,-R/) { $libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl'; } elsif ($Config{'lddlflags'} =~ /-R/) { $libs .= ' "-L$(PERL_INC)" "-R$(INSTALLARCHLIB)/CORE" "-R$(PERL_ARCHLIB)/CORE" -lperl'; } elsif ( $Is{Android} ) { # The Android linker will not recognize symbols from # libperl unless the module explicitly depends on it. $libs .= ' "-L$(PERL_INC)" -lperl'; } } my $ld_run_path_shell = ""; if ($self->{LD_RUN_PATH} ne "") { $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" '; } push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $dlsyms_arg, $ldfrom, $self->xs_obj_opt('$@'), $libs, $exportlist; %s$(LD) %s $(LDDLFLAGS) %s %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \ $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \ $(INST_DYNAMIC_FIX) $(CHMOD) $(PERM_RWX) $@ MAKE join '', @m; } =item exescan Deprecated method. Use libscan instead. =cut sub exescan { my($self,$path) = @_; $path; } =item extliblist Called by init_others, and calls ext ExtUtils::Liblist. See L<ExtUtils::Liblist> for details. =cut sub extliblist { my($self,$libs) = @_; require ExtUtils::Liblist; $self->ext($libs, $Verbose); } =item find_perl Finds the executables PERL and FULLPERL =cut sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; if ($trace >= 2){ print "Looking for perl $ver by these names: @$names in these dirs: @$dirs "; } my $stderr_duped = 0; local *STDERR_COPY; unless ($Is{BSD}) { # >& and lexical filehandles together give 5.6.2 indigestion if( open(STDERR_COPY, '>&STDERR') ) { ## no critic $stderr_duped = 1; } else { warn <<WARNING; find_perl() can't dup STDERR: $! You might see some garbage while we search for Perl WARNING } } foreach my $name (@$names){ my ($abs, $use_dir); if ($self->file_name_is_absolute($name)) { # /foo/bar $abs = $name; } elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo $use_dir = 1; } else { # foo/bar $abs = $self->catfile($Curdir, $name); } foreach my $dir ($use_dir ? @$dirs : 1){ next unless defined $dir; # $self->{PERL_SRC} may be undefined $abs = $self->catfile($dir, $name) if $use_dir; print "Checking $abs\n" if ($trace >= 2); next unless $self->maybe_command($abs); print "Executing $abs\n" if ($trace >= 2); my $val; my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"}; # To avoid using the unportable 2>&1 to suppress STDERR, # we close it before running the command. # However, thanks to a thread library bug in many BSDs # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 ) # we cannot use the fancier more portable way in here # but instead need to use the traditional 2>&1 construct. if ($Is{BSD}) { $val = `$version_check 2>&1`; } else { close STDERR if $stderr_duped; $val = `$version_check`; # 5.6.2's 3-arg open doesn't work with >& open STDERR, ">&STDERR_COPY" ## no critic if $stderr_duped; } if ($val =~ /^VER_OK/m) { print "Using PERL=$abs\n" if $trace; return $abs; } elsif ($trace >= 2) { print "Result: '$val' ".($? >> 8)."\n"; } } } print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; 0; # false and not empty } =item fixin $mm->fixin(@files); Inserts the sharpbang or equivalent magic number to a set of @files. =cut sub fixin { # stolen from the pink Camel book, more or less my ( $self, @files ) = @_; for my $file (@files) { my $file_new = "$file.new"; my $file_bak = "$file.bak"; open( my $fixin, '<', $file ) or croak "Can't process '$file': $!"; local $/ = "\n"; chomp( my $line = <$fixin> ); next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file. my $shb = $self->_fixin_replace_shebang( $file, $line ); next unless defined $shb; open( my $fixout, ">", "$file_new" ) or do { warn "Can't create new $file: $!\n"; next; }; # Print out the new #! line (or equivalent). local $\; local $/; print $fixout $shb, <$fixin>; close $fixin; close $fixout; chmod 0666, $file_bak; unlink $file_bak; unless ( _rename( $file, $file_bak ) ) { warn "Can't rename $file to $file_bak: $!"; next; } unless ( _rename( $file_new, $file ) ) { warn "Can't rename $file_new to $file: $!"; unless ( _rename( $file_bak, $file ) ) { warn "Can't rename $file_bak back to $file either: $!"; warn "Leaving $file renamed as $file_bak\n"; } next; } unlink $file_bak; } continue { system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; } } sub _rename { my($old, $new) = @_; foreach my $file ($old, $new) { if( $Is{VMS} and basename($file) !~ /\./ ) { # rename() in 5.8.0 on VMS will not rename a file if it # does not contain a dot yet it returns success. $file = "$file."; } } return rename($old, $new); } sub _fixin_replace_shebang { my ( $self, $file, $line ) = @_; # Now figure out the interpreter name. my ( $origcmd, $arg ) = split ' ', $line, 2; (my $cmd = $origcmd) =~ s!^.*/!!; # Now look (in reverse) for interpreter in absolute PATH (unless perl). my $interpreter; if ( defined $ENV{PERL_MM_SHEBANG} && $ENV{PERL_MM_SHEBANG} eq "relocatable" ) { $interpreter = "/usr/bin/env perl"; } elsif ( $cmd =~ m{^perl(?:\z|[^a-z])} ) { if ( $Config{startperl} =~ m,^\#!.*/perl, ) { $interpreter = $Config{startperl}; $interpreter =~ s,^\#!,,; } else { $interpreter = $Config{perlpath}; } } else { my (@absdirs) = reverse grep { $self->file_name_is_absolute($_) } $self->path; $interpreter = ''; foreach my $dir (@absdirs) { my $maybefile = $self->catfile($dir,$cmd); if ( $self->maybe_command($maybefile) ) { warn "Ignoring $interpreter in $file\n" if $Verbose && $interpreter; $interpreter = $maybefile; } } # If the shebang is absolute and exists in PATH, but was not # the first one found, leave it alone if it's actually the # same file as first one. This avoids packages built on # merged-/usr systems with /usr/bin before /bin in the path # breaking when installed on systems without merged /usr if ($origcmd ne $interpreter and $self->file_name_is_absolute($origcmd)) { my $origdir = dirname($origcmd); if ($self->maybe_command($origcmd) && grep { $_ eq $origdir } @absdirs) { my ($odev, $oino) = stat $origcmd; my ($idev, $iino) = stat $interpreter; if ($odev == $idev && $oino == $iino) { warn "$origcmd is the same as $interpreter, leaving alone" if $Verbose; $interpreter = $origcmd; } } } } # Figure out how to invoke interpreter on this machine. my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; my ($shb) = ""; if ($interpreter) { print "Changing sharpbang in $file to $interpreter" if $Verbose; # this is probably value-free on DOSISH platforms if ($does_shbang) { $shb .= "$Config{'sharpbang'}$interpreter"; $shb .= ' ' . $arg if defined $arg; $shb .= "\n"; } } else { warn "Can't find $cmd in PATH, $file unchanged" if $Verbose; return; } return $shb } =item force (o) Writes an empty FORCE: target. =cut sub force { my($self) = shift; '# Phony target to force checking subdirectories. FORCE : $(NOECHO) $(NOOP) '; } =item guess_name Guess the name of this package by examining the working directory's name. MakeMaker calls this only if the developer has not supplied a NAME attribute. =cut # '; sub guess_name { my($self) = @_; use Cwd 'cwd'; my $name = basename(cwd()); $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we # strip minus or underline # followed by a float or some such print "Warning: Guessing NAME [$name] from current directory name.\n"; $name; } =item has_link_code Returns true if C, XS, MYEXTLIB or similar objects exist within this object that need a compiler. Does not descend into subdirectories as needs_linking() does. =cut sub has_link_code { my($self) = shift; return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE}; if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){ $self->{HAS_LINK_CODE} = 1; return 1; } return $self->{HAS_LINK_CODE} = 0; } =item init_dirscan Scans the directory structure and initializes DIR, XS, XS_FILES, C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES. Called by init_main. =cut sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) my($self) = @_; my(%dir, %xs, %c, %o, %h, %pl_files, %pm); my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t); # ignore the distdir $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1 : $ignore{$self->{DISTVNAME}} = 1; my $distprefix = $Is{VMS} ? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i : qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/; @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS}; if ( defined $self->{XS} and !defined $self->{C} ) { my @c_files = grep { m/\.c(pp|xx)?\z/i } values %{$self->{XS}}; my @o_files = grep { m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i } values %{$self->{XS}}; %c = map { $_ => 1 } @c_files; %o = map { $_ => 1 } @o_files; } foreach my $name ($self->lsdir($Curdir)){ next if $name =~ /\#/; next if $name =~ $distprefix && -d $name; $name = lc($name) if $Is{VMS}; next if $name eq $Curdir or $name eq $Updir or $ignore{$name}; next unless $self->libscan($name); if (-d $name){ next if -l $name; # We do not support symlinks at all next if $self->{NORECURS}; $dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL")); } elsif ($name =~ /\.xs\z/){ my($c); ($c = $name) =~ s/\.xs\z/.c/; $xs{$name} = $c; $c{$c} = 1; } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc $c{$name} = 1 unless $name =~ m/perlmain\.c/; # See MAP_TARGET } elsif ($name =~ /\.h\z/i){ $h{$name} = 1; } elsif ($name =~ /\.PL\z/) { ($pl_files{$name} = $name) =~ s/\.PL\z// ; } elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) { # case-insensitive filesystem, one dot per name, so foo.h.PL # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl; if ($txt =~ /Extracting \S+ \(with variable substitutions/) { ($pl_files{$name} = $name) =~ s/[._]pl\z//i ; } else { $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); } } elsif ($name =~ /\.(p[ml]|pod)\z/){ $pm{$name} = $self->catfile($self->{INST_LIBDIR},$name); } } $self->{PL_FILES} ||= \%pl_files; $self->{DIR} ||= [sort keys %dir]; $self->{XS} ||= \%xs; $self->{C} ||= [sort keys %c]; $self->{H} ||= [sort keys %h]; $self->{PM} ||= \%pm; my @o_files = @{$self->{C}}; %o = (%o, map { $_ => 1 } grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files); $self->{O_FILES} = [sort keys %o]; } =item init_MANPODS Determines if man pages should be generated and initializes MAN1PODS and MAN3PODS as appropriate. =cut sub init_MANPODS { my $self = shift; # Set up names of manual pages to generate from pods foreach my $man (qw(MAN1 MAN3)) { if ( $self->{"${man}PODS"} or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/ ) { $self->{"${man}PODS"} ||= {}; } else { my $init_method = "init_${man}PODS"; $self->$init_method(); } } # logic similar to picking man${num}ext in perl's Configure script foreach my $num (1,3) { my $installdirs = uc $self->{INSTALLDIRS}; $installdirs = '' if $installdirs eq 'PERL'; my @mandirs = File::Spec->splitdir( $self->_expand_macros( $self->{ "INSTALL${installdirs}MAN${num}DIR" } ) ); my $mandir = pop @mandirs; my $section = $num; foreach ($num, "${num}p", "${num}pm", qw< l n o C L >, "L$num") { if ( $mandir =~ /^(?:man|cat)$_$/ ) { $section = $_; last; } } $self->{"MAN${num}SECTION"} = $section; } } sub _has_pod { my($self, $file) = @_; my($ispod)=0; if (open( my $fh, '<', $file )) { while (<$fh>) { if (/^=(?:head\d+|item|pod)\b/) { $ispod=1; last; } } close $fh; } else { # If it doesn't exist yet, we assume, it has pods in it $ispod = 1; } return $ispod; } =item init_MAN1PODS Initializes MAN1PODS from the list of EXE_FILES. =cut sub init_MAN1PODS { my($self) = @_; if ( exists $self->{EXE_FILES} ) { foreach my $name (@{$self->{EXE_FILES}}) { next unless $self->_has_pod($name); $self->{MAN1PODS}->{$name} = $self->catfile("\$(INST_MAN1DIR)", basename($name).".\$(MAN1EXT)"); } } } =item init_MAN3PODS Initializes MAN3PODS from the list of PM files. =cut sub init_MAN3PODS { my $self = shift; my %manifypods = (); # we collect the keys first, i.e. the files # we have to convert to pod foreach my $name (keys %{$self->{PM}}) { if ($name =~ /\.pod\z/ ) { $manifypods{$name} = $self->{PM}{$name}; } elsif ($name =~ /\.p[ml]\z/ ) { if( $self->_has_pod($name) ) { $manifypods{$name} = $self->{PM}{$name}; } } } my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; # Remove "Configure.pm" and similar, if it's not the only pod listed # To force inclusion, just name it "Configure.pod", or override # MAN3PODS foreach my $name (keys %manifypods) { if ( ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or ( $name =~ m/^README\.pod$/i ) # don't manify top-level README.pod ) { delete $manifypods{$name}; next; } my($manpagename) = $name; $manpagename =~ s/\.p(od|m|l)\z//; # everything below lib is ok unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) { $manpagename = $self->catfile( split(/::/,$self->{PARENT_NAME}),$manpagename ); } $manpagename = $self->replace_manpage_separator($manpagename); $self->{MAN3PODS}->{$name} = $self->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); } } =item init_PM Initializes PMLIBDIRS and PM from PMLIBDIRS. =cut sub init_PM { my $self = shift; # Some larger extensions often wish to install a number of *.pm/pl # files into the library in various locations. # The attribute PMLIBDIRS holds an array reference which lists # subdirectories which we should search for library files to # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We # recursively search through the named directories (skipping any # which don't exist or contain Makefile.PL files). # For each *.pm or *.pl file found $self->libscan() is called with # the default installation path in $_[1]. The return value of # libscan defines the actual installation location. The default # libscan function simply returns the path. The file is skipped # if libscan returns false. # The default installation location passed to libscan in $_[1] is: # # ./*.pm => $(INST_LIBDIR)/*.pm # ./xyz/... => $(INST_LIBDIR)/xyz/... # ./lib/... => $(INST_LIB)/... # # In this way the 'lib' directory is seen as the root of the actual # perl library whereas the others are relative to INST_LIBDIR # (which includes PARENT_NAME). This is a subtle distinction but one # that's important for nested modules. unless( $self->{PMLIBDIRS} ) { if( $Is{VMS} ) { # Avoid logical name vs directory collisions $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"]; } else { $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}]; } } #only existing directories that aren't in $dir are allowed # Avoid $_ wherever possible: # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}}; my (@pmlibdirs) = @{$self->{PMLIBDIRS}}; @{$self->{PMLIBDIRS}} = (); my %dir = map { ($_ => $_) } @{$self->{DIR}}; foreach my $pmlibdir (@pmlibdirs) { -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir; } unless( $self->{PMLIBPARENTDIRS} ) { @{$self->{PMLIBPARENTDIRS}} = ('lib'); } return if $self->{PM} and $self->{ARGS}{PM}; if (@{$self->{PMLIBDIRS}}){ print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n" if ($Verbose >= 2); require File::Find; File::Find::find(sub { if (-d $_){ unless ($self->libscan($_)){ $File::Find::prune = 1; } return; } return if /\#/; return if /~$/; # emacs temp files return if /,v$/; # RCS files return if m{\.swp$}; # vim swap files my $path = $File::Find::name; my $prefix = $self->{INST_LIBDIR}; my $striplibpath; my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; $prefix = $self->{INST_LIB} if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W} {$1}i; my($inst) = $self->catfile($prefix,$striplibpath); local($_) = $inst; # for backwards compatibility $inst = $self->libscan($inst); print "libscan($path) => '$inst'\n" if ($Verbose >= 2); return unless $inst; if ($self->{XSMULTI} and $inst =~ /\.xs\z/) { my($base); ($base = $path) =~ s/\.xs\z//; $self->{XS}{$path} = "$base.c"; push @{$self->{C}}, "$base.c"; push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}"; } else { $self->{PM}{$path} = $inst; } }, @{$self->{PMLIBDIRS}}); } } =item init_DIRFILESEP Using / for Unix. Called by init_main. =cut sub init_DIRFILESEP { my($self) = shift; $self->{DIRFILESEP} = '/'; } =item init_main Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE, EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*, INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME, OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB, PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION, VERSION_SYM, XS_VERSION. =cut sub init_main { my($self) = @_; # --- Initialize Module Name and Paths # NAME = Foo::Bar::Oracle # FULLEXT = Foo/Bar/Oracle # BASEEXT = Oracle # PARENT_NAME = Foo::Bar ### Only UNIX: ### ($self->{FULLEXT} = ### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket $self->{FULLEXT} = $self->catdir(split /::/, $self->{NAME}); # Copied from DynaLoader: my(@modparts) = split(/::/,$self->{NAME}); my($modfname) = $modparts[-1]; # Some systems have restrictions on files names for DLL's etc. # mod2fname returns appropriate file base name (typically truncated) # It may also edit @modparts if required. # We require DynaLoader to make sure that mod2fname is loaded eval { require DynaLoader }; if (defined &DynaLoader::mod2fname) { $modfname = &DynaLoader::mod2fname(\@modparts); } ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ; $self->{PARENT_NAME} ||= ''; if (defined &DynaLoader::mod2fname) { # As of 5.001m, dl_os2 appends '_' $self->{DLBASE} = $modfname; } else { $self->{DLBASE} = '$(BASEEXT)'; } # --- Initialize PERL_LIB, PERL_SRC # *Real* information: where did we get these two from? ... my $inc_config_dir = dirname($INC{'Config.pm'}); my $inc_carp_dir = dirname($INC{'Carp.pm'}); unless ($self->{PERL_SRC}){ foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting my $dir = $self->catdir(($Updir) x $dir_count); if (-f $self->catfile($dir,"config_h.SH") && -f $self->catfile($dir,"perl.h") && -f $self->catfile($dir,"lib","strict.pm") ) { $self->{PERL_SRC}=$dir ; last; } } } warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if $self->{PERL_CORE} and !$self->{PERL_SRC}; if ($self->{PERL_SRC}){ $self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib"); $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; $self->{PERL_INC} = ($Is{Win32}) ? $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; # catch a situation that has occurred a few times in the past: unless ( -s $self->catfile($self->{PERL_SRC},'cflags') or $Is{VMS} && -s $self->catfile($self->{PERL_SRC},'vmsish.h') or $Is{Win32} ){ warn qq{ You cannot build extensions below the perl source tree after executing a 'make clean' in the perl source tree. To rebuild extensions distributed with the perl source you should simply Configure (to include those extensions) and then build perl as normal. After installing perl the source tree can be deleted. It is not needed for building extensions by running 'perl Makefile.PL' usually without extra arguments. It is recommended that you unpack and build additional extensions away from the perl source tree. }; } } else { # we should also consider $ENV{PERL5LIB} here my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC}; $self->{PERL_LIB} ||= $Config{privlibexp}; $self->{PERL_ARCHLIB} ||= $Config{archlibexp}; $self->{PERL_INC} = $self->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now my $perl_h; if (not -f ($perl_h = $self->catfile($self->{PERL_INC},"perl.h")) and not $old){ # Maybe somebody tries to build an extension with an # uninstalled Perl outside of Perl build tree my $lib; for my $dir (@INC) { $lib = $dir, last if -e $self->catfile($dir, "Config.pm"); } if ($lib) { # Win32 puts its header files in /perl/src/lib/CORE. # Unix leaves them in /perl/src. my $inc = $Is{Win32} ? $self->catdir($lib, "CORE" ) : dirname $lib; if (-e $self->catfile($inc, "perl.h")) { $self->{PERL_LIB} = $lib; $self->{PERL_ARCHLIB} = $lib; $self->{PERL_INC} = $inc; $self->{UNINSTALLED_PERL} = 1; print <<EOP; ... Detected uninstalled Perl. Trying to continue. EOP } } } } if ($Is{Android}) { # Android fun times! # ../../perl -I../../lib -MFile::Glob -e1 works # ../../../perl -I../../../lib -MFile::Glob -e1 fails to find # the .so for File::Glob. # This always affects core perl, but may also affect an installed # perl built with -Duserelocatableinc. $self->{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB}); $self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB}); } $self->{PERL_INCDEP} = $self->{PERL_INC}; $self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB}; # We get SITELIBEXP and SITEARCHEXP directly via # Get_from_Config. When we are running standard modules, these # won't matter, we will set INSTALLDIRS to "perl". Otherwise we # set it to "site". I prefer that INSTALLDIRS be set from outside # MakeMaker. $self->{INSTALLDIRS} ||= "site"; $self->{MAN1EXT} ||= $Config{man1ext}; $self->{MAN3EXT} ||= $Config{man3ext}; # Get some stuff out of %Config if we haven't yet done so print "CONFIG must be an array ref\n" if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY'); $self->{CONFIG} = [] unless (ref $self->{CONFIG}); push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config); push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags}; my(%once_only); foreach my $m (@{$self->{CONFIG}}){ next if $once_only{$m}; print "CONFIG key '$m' does not exist in Config.pm\n" unless exists $Config{$m}; $self->{uc $m} ||= $Config{$m}; $once_only{$m} = 1; } # This is too dangerous: # if ($^O eq "next") { # $self->{AR} = "libtool"; # $self->{AR_STATIC_ARGS} = "-o"; # } # But I leave it as a placeholder $self->{AR_STATIC_ARGS} ||= "cr"; # These should never be needed $self->{OBJ_EXT} ||= '.o'; $self->{LIB_EXT} ||= '.a'; $self->{MAP_TARGET} ||= "perl"; $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}"; # make a simple check if we find strict warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory (strict.pm not found)" unless -f $self->catfile("$self->{PERL_LIB}","strict.pm") || $self->{NAME} eq "ExtUtils::MakeMaker"; } =item init_tools Initializes tools to use their common (and faster) Unix commands. =cut sub init_tools { my $self = shift; $self->{ECHO} ||= 'echo'; $self->{ECHO_N} ||= 'echo -n'; $self->{RM_F} ||= "rm -f"; $self->{RM_RF} ||= "rm -rf"; $self->{TOUCH} ||= "touch"; $self->{TEST_F} ||= "test -f"; $self->{TEST_S} ||= "test -s"; $self->{CP} ||= "cp"; $self->{MV} ||= "mv"; $self->{CHMOD} ||= "chmod"; $self->{FALSE} ||= 'false'; $self->{TRUE} ||= 'true'; $self->{LD} ||= 'ld'; return $self->SUPER::init_tools(@_); # After SUPER::init_tools so $Config{shell} has a # chance to get set. $self->{SHELL} ||= '/bin/sh'; return; } =item init_linker Unix has no need of special linker flags. =cut sub init_linker { my($self) = shift; $self->{PERL_ARCHIVE} ||= ''; $self->{PERL_ARCHIVEDEP} ||= ''; $self->{PERL_ARCHIVE_AFTER} ||= ''; $self->{EXPORT_LIST} ||= ''; } =begin _protected =item init_lib2arch $mm->init_lib2arch =end _protected =cut sub init_lib2arch { my($self) = shift; # The user who requests an installation directory explicitly # should not have to tell us an architecture installation directory # as well. We look if a directory exists that is named after the # architecture. If not we take it as a sign that it should be the # same as the requested installation directory. Otherwise we take # the found one. for my $libpair ({l=>"privlib", a=>"archlib"}, {l=>"sitelib", a=>"sitearch"}, {l=>"vendorlib", a=>"vendorarch"}, ) { my $lib = "install$libpair->{l}"; my $Lib = uc $lib; my $Arch = uc "install$libpair->{a}"; if( $self->{$Lib} && ! $self->{$Arch} ){ my($ilib) = $Config{$lib}; $self->prefixify($Arch,$ilib,$self->{$Lib}); unless (-d $self->{$Arch}) { print "Directory $self->{$Arch} not found\n" if $Verbose; $self->{$Arch} = $self->{$Lib}; } print "Defaulting $Arch to $self->{$Arch}\n" if $Verbose; } } } =item init_PERL $mm->init_PERL; Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the *PERLRUN* permutations. PERL is allowed to be miniperl FULLPERL must be a complete perl ABSPERL is PERL converted to an absolute path *PERLRUN contains everything necessary to run perl, find it's libraries, etc... *PERLRUNINST is *PERLRUN + everything necessary to find the modules being built. =cut sub init_PERL { my($self) = shift; my @defpath = (); foreach my $component ($self->{PERL_SRC}, $self->path(), $Config{binexp}) { push @defpath, $component if defined $component; } # Build up a set of file names (not command names). my $thisperl = $self->canonpath($^X); $thisperl .= $Config{exe_ext} unless # VMS might have a file version # at the end $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i : $thisperl =~ m/$Config{exe_ext}$/i; # We need a relative path to perl when in the core. $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE}; my @perls = ($thisperl); push @perls, map { "$_$Config{exe_ext}" } ("perl$Config{version}", 'perl5', 'perl'); # miniperl has priority over all but the canonical perl when in the # core. Otherwise its a last resort. my $miniperl = "miniperl$Config{exe_ext}"; if( $self->{PERL_CORE} ) { splice @perls, 1, 0, $miniperl; } else { push @perls, $miniperl; } $self->{PERL} ||= $self->find_perl(5.0, \@perls, \@defpath, $Verbose ); my $perl = $self->{PERL}; $perl =~ s/^"//; my $has_mcr = $perl =~ s/^MCR\s*//; my $perlflags = ''; my $stripped_perl; while ($perl) { ($stripped_perl = $perl) =~ s/"$//; last if -x $stripped_perl; last unless $perl =~ s/(\s+\S+)$//; $perlflags = $1.$perlflags; } $self->{PERL} = $stripped_perl; $self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS}; # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe. my $perl_name = 'perl'; $perl_name = 'ndbgperl' if $Is{VMS} && defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define'; # XXX This logic is flawed. If "miniperl" is anywhere in the path # it will get confused. It should be fixed to work only on the filename. # Define 'FULLPERL' to be a non-miniperl (used in test: target) unless ($self->{FULLPERL}) { ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i; $self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags; } # Can't have an image name with quotes, and findperl will have # already escaped spaces. $self->{FULLPERL} =~ tr/"//d if $Is{VMS}; # `dmake` can fail for image (aka, executable) names which start with double-quotes # * push quote inward by at least one character (or the drive prefix, if present) # * including any initial directory separator preserves the `file_name_is_absolute` property $self->{FULLPERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake'); # Little hack to get around VMS's find_perl putting "MCR" in front # sometimes. $self->{ABSPERL} = $self->{PERL}; $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//; if( $self->file_name_is_absolute($self->{ABSPERL}) ) { $self->{ABSPERL} = '$(PERL)'; } else { $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL}); # Quote the perl command if it contains whitespace $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL}) if $self->{ABSPERL} =~ /\s/; $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr; } $self->{PERL} = qq{"$self->{PERL}"}.$perlflags; # Can't have an image name with quotes, and findperl will have # already escaped spaces. $self->{PERL} =~ tr/"//d if $Is{VMS}; # `dmake` can fail for image (aka, executable) names which start with double-quotes # * push quote inward by at least one character (or the drive prefix, if present) # * including any initial directory separator preserves the `file_name_is_absolute` property $self->{PERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake'); # Are we building the core? $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE}; $self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE}; # Make sure perl can find itself before it's installed. my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE} ? ( $self->{PERL_ARCHLIB} && $self->{PERL_LIB} && $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ) ? q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"} : undef; my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB} ? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"' : 'RUN)'.$perlflags.' "-I$(INST_LIB)"'; # How do we run perl? foreach my $perl (qw(PERL FULLPERL ABSPERL)) { my $run = $perl.'RUN'; $self->{$run} = qq{\$($perl)}; $self->{$run} .= $lib_paths if $lib_paths; $self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths; } return 1; } =item init_platform =item platform_constants Add MM_Unix_VERSION. =cut sub init_platform { my($self) = shift; $self->{MM_Unix_VERSION} = $VERSION; $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '. '-Dfree=Perl_mfree -Drealloc=Perl_realloc '. '-Dcalloc=Perl_calloc'; } sub platform_constants { my($self) = shift; my $make_frag = ''; foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF)) { next unless defined $self->{$macro}; $make_frag .= "$macro = $self->{$macro}\n"; } return $make_frag; } =item init_PERM $mm->init_PERM Called by init_main. Initializes PERL_* =cut sub init_PERM { my($self) = shift; $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR}; $self->{PERM_RW} = 644 unless defined $self->{PERM_RW}; $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX}; return 1; } =item init_xs $mm->init_xs Sets up macros having to do with XS code. Currently just INST_STATIC, INST_DYNAMIC and INST_BOOT. =cut sub init_xs { my $self = shift; if ($self->has_link_code()) { $self->{INST_STATIC} = $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)'); $self->{INST_DYNAMIC} = $self->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)'); $self->{INST_BOOT} = $self->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs'); if ($self->{XSMULTI}) { my @exts = $self->_xs_list_basenames; my (@statics, @dynamics, @boots); for my $ext (@exts) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if defined $d[0] and $d[0] eq 'lib'; pop @d if $d[$#d] eq ''; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); my $instfile = $self->catfile($instdir, $f); push @statics, "$instfile\$(LIB_EXT)"; # Dynamic library names may need special handling. my $dynfile = $instfile; eval { require DynaLoader }; if (defined &DynaLoader::mod2fname) { $dynfile = $self->catfile($instdir, &DynaLoader::mod2fname([@d, $f])); } push @dynamics, "$dynfile.\$(DLEXT)"; push @boots, "$instfile.bs"; } $self->{INST_STATIC} = join ' ', @statics; $self->{INST_DYNAMIC} = join ' ', @dynamics; $self->{INST_BOOT} = join ' ', @boots; } } else { $self->{INST_STATIC} = ''; $self->{INST_DYNAMIC} = ''; $self->{INST_BOOT} = ''; } } =item install (o) Defines the install target. =cut sub install { my($self, %attribs) = @_; my(@m); push @m, q{ install :: pure_install doc_install $(NOECHO) $(NOOP) install_perl :: pure_perl_install doc_perl_install $(NOECHO) $(NOOP) install_site :: pure_site_install doc_site_install $(NOECHO) $(NOOP) install_vendor :: pure_vendor_install doc_vendor_install $(NOECHO) $(NOOP) pure_install :: pure_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) doc_install :: doc_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) pure__install : pure_site_install $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site doc__install : doc_site_install $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site pure_perl_install :: all $(NOECHO) $(MOD_INSTALL) \ }; push @m, q{ read "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \ write "}.$self->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \ } unless $self->{NO_PACKLIST}; push @m, q{ "$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \ "$(INST_BIN)" "$(DESTINSTALLBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)" $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ "}.$self->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{" pure_site_install :: all $(NOECHO) $(MOD_INSTALL) \ }; push @m, q{ read "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ write "}.$self->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \ } unless $self->{NO_PACKLIST}; push @m, q{ "$(INST_LIB)" "$(DESTINSTALLSITELIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \ "$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)" $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ "}.$self->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{" pure_vendor_install :: all $(NOECHO) $(MOD_INSTALL) \ }; push @m, q{ read "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ write "}.$self->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \ } unless $self->{NO_PACKLIST}; push @m, q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \ "$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)" }; push @m, q{ doc_perl_install :: all $(NOECHO) $(NOOP) doc_site_install :: all $(NOECHO) $(NOOP) doc_vendor_install :: all $(NOECHO) $(NOOP) } if $self->{NO_PERLLOCAL}; push @m, q{ doc_perl_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" doc_site_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" doc_vendor_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLVENDORLIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" } unless $self->{NO_PERLLOCAL}; push @m, q{ uninstall :: uninstall_from_$(INSTALLDIRS)dirs $(NOECHO) $(NOOP) uninstall_from_perldirs :: $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" uninstall_from_sitedirs :: $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" uninstall_from_vendordirs :: $(NOECHO) $(UNINSTALL) "}.$self->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" }; join("",@m); } =item installbin (o) Defines targets to make and to install EXE_FILES. =cut sub installbin { my($self) = shift; return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; my @exefiles = sort @{$self->{EXE_FILES}}; return "" unless @exefiles; @exefiles = map vmsify($_), @exefiles if $Is{VMS}; my %fromto; for my $from (@exefiles) { my($path)= $self->catfile('$(INST_SCRIPT)', basename($from)); local($_) = $path; # for backwards compatibility my $to = $self->libscan($path); print "libscan($from) => '$to'\n" if ($Verbose >=2); $to = vmsify($to) if $Is{VMS}; $fromto{$from} = $to; } my @to = sort values %fromto; my @m; push(@m, qq{ EXE_FILES = @exefiles pure_all :: @to \$(NOECHO) \$(NOOP) realclean :: }); # realclean can get rather large. push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to); push @m, "\n"; # A target for each exe file. my @froms = sort keys %fromto; for my $from (@froms) { # 1 2 push @m, _sprintf562 <<'MAKE', $from, $fromto{$from}; %2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists $(NOECHO) $(RM_F) %2$s $(CP) %1$s %2$s $(FIXIN) %2$s -$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s MAKE } join "", @m; } =item linkext (o) Defines the linkext target which in turn defines the LINKTYPE. =cut # LINKTYPE => static or dynamic or '' sub linkext { my($self, %attribs) = @_; my $linktype = $attribs{LINKTYPE}; $linktype = $self->{LINKTYPE} unless defined $linktype; if (defined $linktype and $linktype eq '') { warn "Warning: LINKTYPE set to '', no longer necessary\n"; } $linktype = '$(LINKTYPE)' unless defined $linktype; " linkext :: $linktype \$(NOECHO) \$(NOOP) "; } =item lsdir Takes as arguments a directory name and a regular expression. Returns all entries in the directory that match the regular expression. =cut sub lsdir { # $self my(undef, $dir, $regex) = @_; opendir(my $dh, defined($dir) ? $dir : ".") or return; my @ls = readdir $dh; closedir $dh; @ls = grep(/$regex/, @ls) if defined $regex; @ls; } =item macro (o) Simple subroutine to insert the macros defined by the macro attribute into the Makefile. =cut sub macro { my($self,%attribs) = @_; my @m; foreach my $key (sort keys %attribs) { my $val = $attribs{$key}; push @m, "$key = $val\n"; } join "", @m; } =item makeaperl (o) Called by staticmake. Defines how to write the Makefile to produce a static new perl. By default the Makefile produced includes all the static extensions in the perl library. (Purified versions of library files, e.g., DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) =cut sub makeaperl { my($self, %attribs) = @_; my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; s/^(.*)/"-I$1"/ for @{$perlinc || []}; my(@m); push @m, " # --- MakeMaker makeaperl section --- MAP_TARGET = $target FULLPERL = $self->{FULLPERL} MAP_PERLINC = @{$perlinc || []} "; return join '', @m if $self->{PARENT}; my($dir) = join ":", @{$self->{DIR}}; unless ($self->{MAKEAPERL}) { push @m, q{ $(MAP_TARGET) :: $(MAKE_APERL_FILE) $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ $(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) $(NOECHO) $(PERLRUNINST) \ Makefile.PL DIR="}, $dir, q{" \ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=}; foreach (@ARGV){ my $arg = $_; # avoid lvalue aliasing if ( $arg =~ /(^.*?=)(.*['\s].*)/ ) { $arg = $1 . $self->quote_literal($2); } push @m, " \\\n\t\t$arg"; } push @m, "\n"; return join '', @m; } my $cccmd = $self->const_cccmd($libperl); $cccmd =~ s/^CCCMD\s*=\s*//; $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /; $cccmd .= " $Config{cccdlflags}" if ($Config{useshrplib} eq 'true'); $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; # The front matter of the linkcommand... my $linkcmd = join ' ', "\$(CC)", grep($_, @Config{qw(ldflags ccdlflags)}); $linkcmd =~ s/\s+/ /g; $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; # Which *.a files could we make use of... my $staticlib21 = $self->_find_static_libs($searchdirs); # We trust that what has been handed in as argument, will be buildable $static = [] unless $static; @$staticlib21{@{$static}} = (1) x @{$static}; $extra = [] unless $extra && ref $extra eq 'ARRAY'; for (sort keys %$staticlib21) { next unless /\Q$self->{LIB_EXT}\E\z/; $_ = dirname($_) . "/extralibs.ld"; push @$extra, $_; } s/^(.*)/"-I$1"/ for @{$perlinc || []}; $target ||= "perl"; $tmp ||= "."; # MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we # regenerate the Makefiles, MAP_STATIC and the dependencies for # extralibs.all are computed correctly my @map_static = reverse sort keys %$staticlib21; push @m, " MAP_LINKCMD = $linkcmd MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), " MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), " MAP_PRELIBS = $Config{perllibs} $Config{cryptlib} "; my $lperl; if (defined $libperl) { ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/; } unless ($libperl && -f $lperl) { # Ilya's code... my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; $libperl ||= "libperl$self->{LIB_EXT}"; $libperl = "$dir/$libperl"; $lperl ||= "libperl$self->{LIB_EXT}"; $lperl = "$dir/$lperl"; if (! -f $libperl and ! -f $lperl) { # We did not find a static libperl. Maybe there is a shared one? if ($Is{SunOS}) { $lperl = $libperl = "$dir/$Config{libperl}"; # SUNOS ld does not take the full path to a shared library $libperl = '' if $Is{SunOS4}; } } print <<EOF unless -f $lperl || defined($self->{PERL_SRC}); Warning: $libperl not found If you're going to build a static perl binary, make sure perl is installed otherwise ignore this warning EOF } # SUNOS ld does not take the full path to a shared library my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl'; my $libperl_dep = $self->quote_dep($libperl); push @m, " MAP_LIBPERL = $libperl MAP_LIBPERLDEP = $libperl_dep LLIBPERL = $llibperl "; push @m, ' $(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).' $(NOECHO) $(RM_F) $@ $(NOECHO) $(TOUCH) $@ '; foreach my $catfile (@$extra){ push @m, "\tcat $catfile >> \$\@\n"; } my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)'; # 1 2 3 4 push @m, _sprintf562 <<'EOF', $tmp, $ldfrom, $self->xs_obj_opt('$@'), $makefilename; $(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all $(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS) $(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call" $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)" $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean" %1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c EOF push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n"; my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : ''; push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader; %1$s/perlmain.c: %2$s $(NOECHO) $(ECHO) Writing $@ $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \ -e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t $(MV) $@t $@ EOF push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain" } if (defined (&Dos::UseLFN) && Dos::UseLFN()==0); push @m, q{ doc_inst_perl : $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Perl binary" "$(MAP_TARGET)" \ MAP_STATIC "$(MAP_STATIC)" \ MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ MAP_LIBPERL "$(MAP_LIBPERL)" \ >> "}.$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" }; push @m, q{ inst_perl : pure_inst_perl doc_inst_perl pure_inst_perl : $(MAP_TARGET) }.$self->{CP}.q{ $(MAP_TARGET) "}.$self->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{" clean :: map_clean map_clean : }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all }; join '', @m; } # utility method sub _find_static_libs { my ($self, $searchdirs) = @_; # don't use File::Spec here because on Win32 F::F still uses "/" my $installed_version = join('/', 'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" ); my %staticlib21; require File::Find; File::Find::find(sub { if ($File::Find::name =~ m{/auto/share\z}) { # in a subdir of auto/share, prune because e.g. # Alien::pkgconfig uses File::ShareDir to put .a files # there. do not want $File::Find::prune = 1; return; } return unless m/\Q$self->{LIB_EXT}\E$/; return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation # Skip perl's libraries. return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/; # Skip purified versions of libraries # (e.g., DynaLoader_pure_p1_c0_032.a) return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; if( exists $self->{INCLUDE_EXT} ){ my $found = 0; (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; $xx =~ s,/?$_,,; $xx =~ s,/,::,g; # Throw away anything not explicitly marked for inclusion. # DynaLoader is implied. foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ if( $xx eq $incl ){ $found++; last; } } return unless $found; } elsif( exists $self->{EXCLUDE_EXT} ){ (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; $xx =~ s,/?$_,,; $xx =~ s,/,::,g; # Throw away anything explicitly marked for exclusion foreach my $excl (@{$self->{EXCLUDE_EXT}}){ return if( $xx eq $excl ); } } # don't include the installed version of this extension. I # leave this line here, although it is not necessary anymore: # I patched minimod.PL instead, so that Miniperl.pm won't # include duplicates # Once the patch to minimod.PL is in the distribution, I can # drop it return if $File::Find::name =~ m:\Q$installed_version\E\z:; return if !$self->xs_static_lib_is_xs($_); use Cwd 'cwd'; $staticlib21{cwd() . "/" . $_}++; }, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) ); return \%staticlib21; } =item xs_static_lib_is_xs (o) Called by a utility method of makeaperl. Checks whether a given file is an XS library by seeing whether it defines any symbols starting with C<boot_> (with an optional leading underscore - needed on MacOS). =cut sub xs_static_lib_is_xs { my ($self, $libfile) = @_; my $devnull = File::Spec->devnull; return `nm $libfile 2>$devnull` =~ /\b_?boot_/; } =item makefile (o) Defines how to rewrite the Makefile. =cut sub makefile { my($self) = shift; my $m; # We do not know what target was originally specified so we # must force a manual rerun to be sure. But as it should only # happen very rarely it is not a significant problem. $m = ' $(OBJECT) : $(FIRST_MAKEFILE) ' if $self->{OBJECT}; my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?'; my $mpl_args = join " ", map qq["$_"], @ARGV; my $cross = ''; if (defined $::Cross::platform) { # Inherited from win32/buildext.pl $cross = "-MCross=$::Cross::platform "; } $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $cross, $mpl_args; # We take a very conservative approach here, but it's worth it. # We move Makefile to Makefile.old here to avoid gnu make looping. $(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) $(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s" $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) $(PERLRUN) %sMakefile.PL %s $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" $(FALSE) MAKE_FRAG return $m; } =item maybe_command Returns true, if the argument is likely to be a command. =cut sub maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d $file; return; } =item needs_linking (o) Does this module need linking? Looks into subdirectory objects (see also has_link_code()) =cut sub needs_linking { my($self) = shift; my $caller = (caller(0))[3]; confess("needs_linking called too early") if $caller =~ /^ExtUtils::MakeMaker::/; return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING}; if ($self->has_link_code or $self->{MAKEAPERL}){ $self->{NEEDS_LINKING} = 1; return 1; } foreach my $child (keys %{$self->{CHILDREN}}) { if ($self->{CHILDREN}->{$child}->needs_linking) { $self->{NEEDS_LINKING} = 1; return 1; } } return $self->{NEEDS_LINKING} = 0; } =item parse_abstract parse a file and return what you think is the ABSTRACT =cut sub parse_abstract { my($self,$parsefile) = @_; my $result; local $/ = "\n"; open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; binmode $fh; my $inpod = 0; my $pod_encoding; my $package = $self->{DISTNAME}; $package =~ s/-/::/g; while (<$fh>) { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if !$inpod; s#\r*\n\z##; # handle CRLF input if ( /^=encoding\s*(.*)$/i ) { $pod_encoding = $1; } if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) { $result = $2; next; } next unless $result; if ( $result && ( /^\s*$/ || /^\=/ ) ) { last; } $result = join ' ', $result, $_; } close $fh; if ( $pod_encoding and !( "$]" < 5.008 or !$Config{useperlio} ) ) { # Have to wrap in an eval{} for when running under PERL_CORE # Encode isn't available during build phase and parsing # ABSTRACT isn't important there eval { require Encode; $result = Encode::decode($pod_encoding, $result); } } return $result; } =item parse_version my $version = MM->parse_version($file); Parse a $file and return what $VERSION is set to by the first assignment. It will return the string "undef" if it can't figure out what $VERSION is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION are okay, but C<my $VERSION> is not. C<package Foo VERSION> is also checked for. The first version declaration found is used, but this may change as it differs from how Perl does it. parse_version() will try to C<use version> before checking for C<$VERSION> so the following will work. $VERSION = qv(1.2.3); =cut sub parse_version { my($self,$parsefile) = @_; my $result; local $/ = "\n"; local $_; open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; my $inpod = 0; while (<$fh>) { $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; next if $inpod || /^\s*#/; chop; next if /^\s*(if|unless|elsif)/; if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* (;|\{) }x ) { no warnings; $result = $1; } elsif ( m{(?<!\\) ([\$*]) (([\w\:\']*) \bVERSION)\b .* (?<![<>=!])\=[^=]}x ) { $result = $self->get_version($parsefile, $1, $2); } else { next; } last if defined $result; } close $fh; if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) { require version; my $normal = eval { version->new( $result ) }; $result = $normal if defined $normal; } if ( defined $result ) { $result = "undef" unless $result =~ m!^v?[\d_\.]+$! or eval { version->parse( $result ) }; } $result = "undef" unless defined $result; return $result; } sub get_version { my ($self, $parsefile, $sigil, $name) = @_; my $line = $_; # from the while() loop in parse_version { package ExtUtils::MakeMaker::_version; undef *version; # in case of unexpected version() sub eval { require version; version::->import; }; no strict; no warnings; local *{$name}; $line = $1 if $line =~ m{^(.+)}s; eval($line); ## no critic return ${$name}; } } =item pasthru (o) Defines the string that is passed to recursive make calls in subdirectories. The variables like C<PASTHRU_DEFINE> are used in each level, and passed downwards on the command-line with e.g. the value of that level's DEFINE. Example: # Level 0 has DEFINE = -Dfunky # This code will define level 0's PASTHRU=PASTHRU_DEFINE="$(DEFINE) # $(PASTHRU_DEFINE)" # Level 0's $(CCCMD) will include macros $(DEFINE) and $(PASTHRU_DEFINE) # So will level 1's, so when level 1 compiles, it will get right values # And so ad infinitum =cut sub pasthru { my($self) = shift; my(@m); my(@pasthru); my($sep) = $Is{VMS} ? ',' : ''; $sep .= "\\\n\t"; foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE PREFIX INSTALL_BASE) ) { next unless defined $self->{$key}; push @pasthru, "$key=\"\$($key)\""; } foreach my $key (qw(DEFINE INC)) { # default to the make var my $val = qq{\$($key)}; # expand within perl if given since need to use quote_literal # since INC might include space-protecting ""! chomp($val = $self->{$key}) if defined $self->{$key}; $val .= " \$(PASTHRU_$key)"; my $quoted = $self->quote_literal($val); push @pasthru, qq{PASTHRU_$key=$quoted}; } push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; join "", @m; } =item perl_script Takes one argument, a file name, and returns the file name, if the argument is likely to be a perl script. On MM_Unix this is true for any ordinary, readable file. =cut sub perl_script { my($self,$file) = @_; return $file if -r $file && -f _; return; } =item perldepend (o) Defines the dependency from all *.h files that come with the perl distribution. =cut sub perldepend { my($self) = shift; my(@m); my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm'); push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC}; # Check for unpropogated config.sh changes. Should never happen. # We do NOT just update config.h because that is not sufficient. # An out of date config.h is not fatal but complains loudly! $(PERL_INCDEP)/config.h: $(PERL_SRC)/config.sh -$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE) $(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh $(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" %s MAKE_FRAG return join "", @m unless $self->needs_linking; if ($self->{OBJECT}) { # Need to add an object file dependency on the perl headers. # this is very important for XS modules in perl.git development. push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h } push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}}; return join "\n", @m; } =item pm_to_blib Defines target that copies all files in the hash PM to their destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION> =cut sub pm_to_blib { my $self = shift; my($autodir) = $self->catdir('$(INST_LIB)','auto'); my $r = q{ pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM) }; # VMS will swallow '' and PM_FILTER is often empty. So use q[] my $pm_to_blib = $self->oneliner(<<CODE, ['-MExtUtils::Install']); pm_to_blib({\@ARGV}, '$autodir', q[\$(PM_FILTER)], '\$(PERM_DIR)') CODE my @cmds = $self->split_command($pm_to_blib, map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}}); $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds; $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n}; return $r; } # transform dot-separated version string into comma-separated quadruple # examples: '1.2.3.4.5' => '1,2,3,4' # '1.2.3' => '1,2,3,0' sub _ppd_version { my ($self, $string) = @_; return join ',', ((split /\./, $string), (0) x 4)[0..3]; } =item ppd Defines target that creates a PPD (Perl Package Description) file for a binary distribution. =cut sub ppd { my($self) = @_; my $abstract = $self->{ABSTRACT} || ''; $abstract =~ s/\n/\\n/sg; $abstract =~ s/</</g; $abstract =~ s/>/>/g; my $author = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']}); $author =~ s/</</g; $author =~ s/>/>/g; my $ppd_file = "$self->{DISTNAME}.ppd"; my @ppd_chunks = qq(<SOFTPKG NAME="$self->{DISTNAME}" VERSION="$self->{VERSION}">\n); push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author; <ABSTRACT>%s</ABSTRACT> <AUTHOR>%s</AUTHOR> PPD_HTML push @ppd_chunks, " <IMPLEMENTATION>\n"; if ( $self->{MIN_PERL_VERSION} ) { my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION}); push @ppd_chunks, sprintf <<'PPD_PERLVERS', $min_perl_version; <PERLCORE VERSION="%s" /> PPD_PERLVERS } # Don't add "perl" to requires. perl dependencies are # handles by ARCHITECTURE. my %prereqs = %{$self->{PREREQ_PM}}; delete $prereqs{perl}; # Build up REQUIRE foreach my $prereq (sort keys %prereqs) { my $name = $prereq; $name .= '::' unless $name =~ /::/; my $version = $prereqs{$prereq}; my %attrs = ( NAME => $name ); $attrs{VERSION} = $version if $version; my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs; push @ppd_chunks, qq( <REQUIRE $attrs />\n); } my $archname = $Config{archname}; # archname did not change from 5.6 to 5.8, but those versions may # not be not binary compatible so now we append the part of the # version that changes when binary compatibility may change if ("$]" >= 5.008) { $archname .= "-$Config{api_revision}.$Config{api_version}"; } push @ppd_chunks, sprintf <<'PPD_OUT', $archname; <ARCHITECTURE NAME="%s" /> PPD_OUT if ($self->{PPM_INSTALL_SCRIPT}) { if ($self->{PPM_INSTALL_EXEC}) { push @ppd_chunks, sprintf qq{ <INSTALL EXEC="%s">%s</INSTALL>\n}, $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT}; } else { push @ppd_chunks, sprintf qq{ <INSTALL>%s</INSTALL>\n}, $self->{PPM_INSTALL_SCRIPT}; } } if ($self->{PPM_UNINSTALL_SCRIPT}) { if ($self->{PPM_UNINSTALL_EXEC}) { push @ppd_chunks, sprintf qq{ <UNINSTALL EXEC="%s">%s</UNINSTALL>\n}, $self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT}; } else { push @ppd_chunks, sprintf qq{ <UNINSTALL>%s</UNINSTALL>\n}, $self->{PPM_UNINSTALL_SCRIPT}; } } my ($bin_location) = $self->{BINARY_LOCATION} || ''; $bin_location =~ s/\\/\\\\/g; push @ppd_chunks, sprintf <<'PPD_XML', $bin_location; <CODEBASE HREF="%s" /> </IMPLEMENTATION> </SOFTPKG> PPD_XML my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file); return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds; # Creates a PPD (Perl Package Description) for a binary distribution. ppd : %s PPD_OUT } =item prefixify $MM->prefixify($var, $prefix, $new_prefix, $default); Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to replace it's $prefix with a $new_prefix. Should the $prefix fail to match I<AND> a PREFIX was given as an argument to WriteMakefile() it will set it to the $new_prefix + $default. This is for systems whose file layouts don't neatly fit into our ideas of prefixes. This is for heuristics which attempt to create directory structures that mirror those of the installed perl. For example: $MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1'); this will attempt to remove '/usr' from the front of the $MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir} if necessary) and replace it with '/home/foo'. If this fails it will simply use '/home/foo/man/man1'. =cut sub prefixify { my($self,$var,$sprefix,$rprefix,$default) = @_; my $path = $self->{uc $var} || $Config_Override{lc $var} || $Config{lc $var} || ''; $rprefix .= '/' if $sprefix =~ m|/$|; warn " prefixify $var => $path\n" if $Verbose >= 2; warn " from $sprefix to $rprefix\n" if $Verbose >= 2; if( $self->{ARGS}{PREFIX} && $path !~ s{^\Q$sprefix\E\b}{$rprefix}s ) { warn " cannot prefix, using default.\n" if $Verbose >= 2; warn " no default!\n" if !$default && $Verbose >= 2; $path = $self->catdir($rprefix, $default) if $default; } print " now $path\n" if $Verbose >= 2; return $self->{uc $var} = $path; } =item processPL (o) Defines targets to run *.PL files. =cut sub processPL { my $self = shift; my $pl_files = $self->{PL_FILES}; return "" unless $pl_files; my $m = ''; foreach my $plfile (sort keys %$pl_files) { my $targets = $pl_files->{$plfile}; my $list = ref($targets) eq 'HASH' ? [ sort keys %$targets ] : ref($targets) eq 'ARRAY' ? $pl_files->{$plfile} : [$pl_files->{$plfile}]; foreach my $target (@$list) { if( $Is{VMS} ) { $plfile = vmsify($self->eliminate_macros($plfile)); $target = vmsify($self->eliminate_macros($target)); } # Normally a .PL file runs AFTER pm_to_blib so it can have # blib in its @INC and load the just built modules. BUT if # the generated module is something in $(TO_INST_PM) which # pm_to_blib depends on then it can't depend on pm_to_blib # else we have a dependency loop. my $pm_dep; my $perlrun; if( defined $self->{PM}{$target} ) { $pm_dep = ''; $perlrun = 'PERLRUN'; } else { $pm_dep = 'pm_to_blib'; $perlrun = 'PERLRUNINST'; } my $extra_inputs = ''; if( ref($targets) eq 'HASH' ) { my $inputs = ref($targets->{$target}) ? $targets->{$target} : [$targets->{$target}]; for my $input (@$inputs) { if( $Is{VMS} ) { $input = vmsify($self->eliminate_macros($input)); } $extra_inputs .= ' '.$input; } } $m .= <<MAKE_FRAG; pure_all :: $target \$(NOECHO) \$(NOOP) $target :: $plfile $pm_dep $extra_inputs \$($perlrun) $plfile $target $extra_inputs MAKE_FRAG } } return $m; } =item specify_shell Specify SHELL if needed - not done on Unix. =cut sub specify_shell { return ''; } =item quote_paren Backslashes parentheses C<()> in command line arguments. Doesn't handle recursive Makefile C<$(...)> constructs, but handles simple ones. =cut sub quote_paren { my $arg = shift; $arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...) $arg =~ s{(?<!\\)([()])}{\\$1}g; # quote unprotected $arg =~ s{\$\\\\\((.+?)\\\\\)}{\$($1)}g; # unprotect $(...) return $arg; } =item replace_manpage_separator my $man_name = $MM->replace_manpage_separator($file_path); Takes the name of a package, which may be a nested package, in the form 'Foo/Bar.pm' and replaces the slash with C<::> or something else safe for a man page file name. Returns the replacement. =cut sub replace_manpage_separator { my($self,$man) = @_; $man =~ s,/+,::,g; return $man; } =item cd =cut sub cd { my($self, $dir, @cmds) = @_; # No leading tab and no trailing newline makes for easier embedding my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds; return $make_frag; } =item oneliner =cut sub oneliner { my($self, $cmd, $switches) = @_; $switches = [] unless defined $switches; # Strip leading and trailing newlines $cmd =~ s{^\n+}{}; $cmd =~ s{\n+$}{}; my @cmds = split /\n/, $cmd; $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds; $cmd = $self->escape_newlines($cmd); $switches = join ' ', @$switches; return qq{\$(ABSPERLRUN) $switches -e $cmd --}; } =item quote_literal Quotes macro literal value suitable for being used on a command line so that when expanded by make, will be received by command as given to this method: my $quoted = $mm->quote_literal(q{it isn't}); # returns: # 'it isn'\''t' print MAKEFILE "target:\n\techo $quoted\n"; # when run "make target", will output: # it isn't =cut sub quote_literal { my($self, $text, $opts) = @_; $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; # Quote single quotes $text =~ s{'}{'\\''}g; $text = $opts->{allow_variables} ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); return "'$text'"; } =item escape_newlines =cut sub escape_newlines { my($self, $text) = @_; $text =~ s{\n}{\\\n}g; return $text; } =item max_exec_len Using L<POSIX>::ARG_MAX. Otherwise falling back to 4096. =cut sub max_exec_len { my $self = shift; if (!defined $self->{_MAX_EXEC_LEN}) { if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) { $self->{_MAX_EXEC_LEN} = $arg_max; } else { # POSIX minimum exec size $self->{_MAX_EXEC_LEN} = 4096; } } return $self->{_MAX_EXEC_LEN}; } =item static (o) Defines the static target. =cut sub static { # --- Static Loading Sections --- my($self) = shift; ' ## $(INST_PM) has been moved to the all: target. ## It remains here for awhile to allow for old usage: "make static" static :: $(FIRST_MAKEFILE) $(INST_STATIC) $(NOECHO) $(NOOP) '; } sub static_lib { my($self) = @_; return '' unless $self->has_link_code; my(@m); my @libs; if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my ($v, $d, $f) = File::Spec->splitpath($ext); my @d = File::Spec->splitdir($d); shift @d if $d[0] eq 'lib'; my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)"); my $objfile = "$ext\$(OBJ_EXT)"; push @libs, [ $objfile, $instfile, $instdir ]; } } else { @libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]); } push @m, map { $self->xs_make_static_lib(@$_); } @libs; join "\n", @m; } =item xs_make_static_lib Defines the recipes for the C<static_lib> section. =cut sub xs_make_static_lib { my ($self, $from, $to, $todir) = @_; my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir; push @m, "\t\$(RM_F) \"\$\@\"\n"; push @m, $self->static_lib_fixtures; push @m, $self->static_lib_pure_cmd($from); push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; push @m, $self->static_lib_closures($todir); join '', @m; } =item static_lib_closures Records C<$(EXTRALIBS)> in F<extralibs.ld> and F<$(PERL_SRC)/ext.libs>. =cut sub static_lib_closures { my ($self, $todir) = @_; my @m = sprintf <<'MAKE_FRAG', $todir; $(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld MAKE_FRAG # Old mechanism - still available: push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS}; $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs MAKE_FRAG @m; } =item static_lib_fixtures Handles copying C<$(MYEXTLIB)> as starter for final static library that then gets added to. =cut sub static_lib_fixtures { my ($self) = @_; # If this extension has its own library (eg SDBM_File) # then copy that to $(INST_STATIC) and add $(OBJECT) into it. return unless $self->{MYEXTLIB}; "\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n"; } =item static_lib_pure_cmd Defines how to run the archive utility. =cut sub static_lib_pure_cmd { my ($self, $from) = @_; my $ar; if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) { # Prefer the absolute pathed ar if available so that PATH # doesn't confuse us. Perl itself is built with the full_ar. $ar = 'FULL_AR'; } else { $ar = 'AR'; } sprintf <<'MAKE_FRAG', $ar, $from; $(%s) $(AR_STATIC_ARGS) "$@" %s $(RANLIB) "$@" MAKE_FRAG } =item staticmake (o) Calls makeaperl. =cut sub staticmake { my($self, %attribs) = @_; my(@static); my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB}); # And as it's not yet built, we add the current extension # but only if it has some C code (or XS code, which implies C code) if (@{$self->{C}}) { @static = $self->catfile($self->{INST_ARCHLIB}, "auto", $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" ); } # Either we determine now, which libraries we will produce in the # subdirectories or we do it at runtime of the make. # We could ask all subdir objects, but I cannot imagine, why it # would be necessary. # Instead we determine all libraries for the new perl at # runtime. my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB}); $self->makeaperl(MAKE => $self->{MAKEFILE}, DIRS => \@searchdirs, STAT => \@static, INCL => \@perlinc, TARGET => $self->{MAP_TARGET}, TMP => "", LIBPERL => $self->{LIBPERL_A} ); } =item subdir_x (o) Helper subroutine for subdirs =cut sub subdir_x { my($self, $subdir) = @_; my $subdir_cmd = $self->cd($subdir, '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)' ); return sprintf <<'EOT', $subdir_cmd; subdirs :: $(NOECHO) %s EOT } =item subdirs (o) Defines targets to process subdirectories. =cut sub subdirs { # --- Sub-directory Sections --- my($self) = shift; my(@m); # This method provides a mechanism to automatically deal with # subdirectories containing further Makefile.PL scripts. # It calls the subdir_x() method for each subdirectory. foreach my $dir (@{$self->{DIR}}){ push @m, $self->subdir_x($dir); #### print "Including $dir subdirectory\n"; } if (@m){ unshift @m, <<'EOF'; # The default clean, realclean and test targets in this Makefile # have automatically been given entries for each subdir. EOF } else { push(@m, "\n# none") } join('',@m); } =item test (o) Defines the test targets. =cut sub test { my($self, %attribs) = @_; my $tests = $attribs{TESTS} || ''; if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) { $tests = $self->find_tests_recursive; } elsif (!$tests && -d 't') { $tests = $self->find_tests; } # have to do this because nmake is broken $tests =~ s!/!\\!g if $self->is_make_type('nmake'); # note: 'test.pl' name is also hardcoded in init_dirscan() my @m; my $default_testtype = $Config{usedl} ? 'dynamic' : 'static'; push @m, <<EOF; TEST_VERBOSE=0 TEST_TYPE=test_\$(LINKTYPE) TEST_FILE = test.pl TEST_FILES = $tests TESTDB_SW = -d testdb :: testdb_\$(LINKTYPE) \$(NOECHO) \$(NOOP) test :: \$(TEST_TYPE) \$(NOECHO) \$(NOOP) # Occasionally we may face this degenerate target: test_ : test_$default_testtype \$(NOECHO) \$(NOOP) EOF for my $linktype (qw(dynamic static)) { my $directdeps = join ' ', grep !$self->{SKIPHASH}{$_}, $linktype, "pure_all"; # no depend on a linktype if SKIPped push @m, "subdirs-test_$linktype :: $directdeps\n"; foreach my $dir (@{ $self->{DIR} }) { my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)"); push @m, "\t\$(NOECHO) $test\n"; } push @m, "\n"; if ($tests or -f "test.pl") { for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) { my ($db, $switch) = @$testspec; my ($command, $deps); # if testdb, build all but don't test all $deps = $db eq 'db' ? $directdeps : "subdirs-test_$linktype"; if ($linktype eq 'static' and $self->needs_linking) { my $target = File::Spec->rel2abs('$(MAP_TARGET)'); $command = qq{"$target" \$(MAP_PERLINC)}; $deps .= ' $(MAP_TARGET)'; } else { $command = '$(FULLPERLRUN)' . $switch; } push @m, "test${db}_$linktype :: $deps\n"; if ($db eq 'db') { push @m, $self->test_via_script($command, '$(TEST_FILE)') } else { push @m, $self->test_via_script($command, '$(TEST_FILE)') if -f "test.pl"; push @m, $self->test_via_harness($command, '$(TEST_FILES)') if $tests; } push @m, "\n"; } } else { push @m, _sprintf562 <<'EOF', $linktype; testdb_%1$s test_%1$s :: subdirs-test_%1$s $(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.' EOF } } join "", @m; } =item test_via_harness (override) For some reason which I forget, Unix machines like to have PERL_DL_NONLAZY set for tests. =cut sub test_via_harness { my($self, $perl, $tests) = @_; return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests); } =item test_via_script (override) Again, the PERL_DL_NONLAZY thing. =cut sub test_via_script { my($self, $perl, $script) = @_; return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script); } =item tool_xsubpp (o) Determines typemaps, xsubpp version, prototype behaviour. =cut sub tool_xsubpp { my($self) = shift; return "" unless $self->needs_linking; my $xsdir; my @xsubpp_dirs = @INC; # Make sure we pick up the new xsubpp if we're building perl. unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE}; my $foundxsubpp = 0; foreach my $dir (@xsubpp_dirs) { $xsdir = $self->catdir($dir, 'ExtUtils'); if( -r $self->catfile($xsdir, "xsubpp") ) { $foundxsubpp = 1; last; } } die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp; my $tmdir = $self->catdir($self->{PERL_LIB},"ExtUtils"); my(@tmdeps) = $self->catfile($tmdir,'typemap'); if( $self->{TYPEMAPS} ){ foreach my $typemap (@{$self->{TYPEMAPS}}){ if( ! -f $typemap ) { warn "Typemap $typemap not found.\n"; } else { $typemap = vmsify($typemap) if $Is{VMS}; push(@tmdeps, $typemap); } } } push(@tmdeps, "typemap") if -f "typemap"; # absolutised because with deep-located typemaps, eg "lib/XS/typemap", # if xsubpp is called from top level with # $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs" # it says: # Can't find lib/XS/type map in (fulldir)/lib/XS # because ExtUtils::ParseXS::process_file chdir's to .xs file's # location. This is the only way to get all specified typemaps used, # wherever located. my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps; $_ = $self->quote_dep($_) for @tmdeps; if( exists $self->{XSOPT} ){ unshift( @tmargs, $self->{XSOPT} ); } if ($Is{VMS} && $Config{'ldflags'} && $Config{'ldflags'} =~ m!/Debug!i && (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/) ) { unshift(@tmargs,'-nolinenumbers'); } $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG}; my $xsdirdep = $self->quote_dep($xsdir); # -dep for use when dependency not command return qq{ XSUBPPDIR = $xsdir XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp" XSUBPPRUN = \$(PERLRUN) \$(XSUBPP) XSPROTOARG = $self->{XSPROTOARG} XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp XSUBPPARGS = @tmargs XSUBPP_EXTRA_ARGS = }; } =item all_target Build man pages, too =cut sub all_target { my $self = shift; return <<'MAKE_EXT'; all :: pure_all manifypods $(NOECHO) $(NOOP) MAKE_EXT } =item top_targets (o) Defines the targets all, subdirs, config, and O_FILES =cut sub top_targets { # --- Target Sections --- my($self) = shift; my(@m); push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'}; push @m, sprintf <<'EOF'; pure_all :: config pm_to_blib subdirs linkext $(NOECHO) $(NOOP) subdirs :: $(MYEXTLIB) $(NOECHO) $(NOOP) config :: $(FIRST_MAKEFILE) blibdirs $(NOECHO) $(NOOP) EOF push @m, ' $(O_FILES) : $(H_FILES) ' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; push @m, q{ help : perldoc ExtUtils::MakeMaker }; join('',@m); } =item writedoc Obsolete, deprecated method. Not used since Version 5.21. =cut sub writedoc { # --- perllocal.pod section --- my($self,$what,$name,@attribs)=@_; my $time = gmtime($ENV{SOURCE_DATE_EPOCH} || time); print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n"; print join "\n\n=item *\n\n", map("C<$_>",@attribs); print "\n\n=back\n\n"; } =item xs_c (o) Defines the suffix rules to compile XS files to C. =cut sub xs_c { my($self) = shift; return '' unless $self->needs_linking(); ' .xs.c: $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc $(MV) $*.xsc $*.c '; } =item xs_cpp (o) Defines the suffix rules to compile XS files to C++. =cut sub xs_cpp { my($self) = shift; return '' unless $self->needs_linking(); ' .xs.cpp: $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc $(MV) $*.xsc $*.cpp '; } =item xs_o (o) Defines suffix rules to go from XS to object files directly. This was originally only intended for broken make implementations, but is now necessary for per-XS file under C<XSMULTI>, since each XS file might have an individual C<$(VERSION)>. =cut sub xs_o { my ($self) = @_; return '' unless $self->needs_linking(); my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : ''; my $dbgout = $self->dbgoutflag; $dbgout = $dbgout ? "$dbgout " : ''; my $frag = ''; # dmake makes noise about ambiguous rule $frag .= sprintf <<'EOF', $dbgout, $m_o unless $self->is_make_type('dmake'); .xs$(OBJ_EXT) : $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc $(MV) $*.xsc $*.c $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) %s$*.c %s EOF if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { my $pmfile = "$ext.pm"; croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile; my $version = $self->parse_version($pmfile); my $cccmd = $self->{CONST_CCCMD}; $cccmd =~ s/^\s*CCCMD\s*=\s*//; $cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/; $cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/; $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC'); my $define = '$(DEFINE)'; $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE'); # 1 2 3 4 5 $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define, $dbgout; %1$s$(OBJ_EXT): %1$s.xs $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc $(MV) $*.xsc $*.c %2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s %5$s$*.c %3$s EOF } } $frag =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/sg if $Is{ApplCor}; $frag; } # param gets modified sub _xsbuild_replace_macro { my ($self, undef, $xstype, $ext, $varname) = @_; my $value = $self->_xsbuild_value($xstype, $ext, $varname); return unless defined $value; $_[1] =~ s/\$\($varname\)/$value/; } sub _xsbuild_value { my ($self, $xstype, $ext, $varname) = @_; return $self->{XSBUILD}{$xstype}{$ext}{$varname} if $self->{XSBUILD}{$xstype}{$ext}{$varname}; return $self->{XSBUILD}{$xstype}{all}{$varname} if $self->{XSBUILD}{$xstype}{all}{$varname}; (); } 1; =back =head1 SEE ALSO L<ExtUtils::MakeMaker> =cut __END__ perl5/ExtUtils/Install.pm 0000444 00000117211 14711220165 0011320 0 ustar 00 package ExtUtils::Install; use strict; use vars qw(@ISA @EXPORT $VERSION $MUST_REBOOT %Config); use AutoSplit; use Carp (); use Config qw(%Config); use Cwd qw(cwd); use Exporter; use ExtUtils::Packlist; use File::Basename qw(dirname); use File::Compare qw(compare); use File::Copy; use File::Find qw(find); use File::Path; use File::Spec; @ISA = ('Exporter'); @EXPORT = ('install','uninstall','pm_to_blib', 'install_default'); =pod =head1 NAME ExtUtils::Install - install files from here to there =head1 SYNOPSIS use ExtUtils::Install; install({ 'blib/lib' => 'some/install/dir' } ); uninstall($packlist); pm_to_blib({ 'lib/Foo/Bar.pm' => 'blib/lib/Foo/Bar.pm' }); =head1 VERSION 2.06 =cut $VERSION = '2.06'; # <-- do not forget to update the POD section just above this line! $VERSION = eval $VERSION; =pod =head1 DESCRIPTION Handles the installing and uninstalling of perl modules, scripts, man pages, etc... Both install() and uninstall() are specific to the way ExtUtils::MakeMaker handles the installation and deinstallation of perl modules. They are not designed as general purpose tools. On some operating systems such as Win32 installation may not be possible until after a reboot has occurred. This can have varying consequences: removing an old DLL does not impact programs using the new one, but if a new DLL cannot be installed properly until reboot then anything depending on it must wait. The package variable $ExtUtils::Install::MUST_REBOOT is used to store this status. If this variable is true then such an operation has occurred and anything depending on this module cannot proceed until a reboot has occurred. If this value is defined but false then such an operation has ocurred, but should not impact later operations. =over =begin _private =item _chmod($$;$) Wrapper to chmod() for debugging and error trapping. =item _warnonce(@) Warns about something only once. =item _choke(@) Dies with a special message. =back =end _private =cut my $Is_VMS = $^O eq 'VMS'; my $Is_MacPerl = $^O eq 'MacOS'; my $Is_Win32 = $^O eq 'MSWin32'; my $Is_cygwin = $^O eq 'cygwin'; my $CanMoveAtBoot = ($Is_Win32 || $Is_cygwin); my $Inc_uninstall_warn_handler; # install relative to here my $INSTALL_ROOT = $ENV{PERL_INSTALL_ROOT}; my $INSTALL_QUIET = $ENV{PERL_INSTALL_QUIET}; my $Curdir = File::Spec->curdir; my $Updir = File::Spec->updir; sub _estr(@) { return join "\n",'!' x 72,@_,'!' x 72,''; } {my %warned; sub _warnonce(@) { my $first=shift; my $msg=_estr "WARNING: $first",@_; warn $msg unless $warned{$msg}++; }} sub _choke(@) { my $first=shift; my $msg=_estr "ERROR: $first",@_; Carp::croak($msg); } sub _chmod($$;$) { my ( $mode, $item, $verbose )=@_; $verbose ||= 0; if (chmod $mode, $item) { printf "chmod(0%o, %s)\n",$mode, $item if $verbose > 1; } else { my $err="$!"; _warnonce sprintf "WARNING: Failed chmod(0%o, %s): %s\n", $mode, $item, $err if -e $item; } } =begin _private =over =item _move_file_at_boot( $file, $target, $moan ) OS-Specific, Win32/Cygwin Schedules a file to be moved/renamed/deleted at next boot. $file should be a filespec of an existing file $target should be a ref to an array if the file is to be deleted otherwise it should be a filespec for a rename. If the file is existing it will be replaced. Sets $MUST_REBOOT to 0 to indicate a deletion operation has occurred and sets it to 1 to indicate that a move operation has been requested. returns 1 on success, on failure if $moan is false errors are fatal. If $moan is true then returns 0 on error and warns instead of dies. =end _private =cut { my $Has_Win32API_File; sub _move_file_at_boot { #XXX OS-SPECIFIC my ( $file, $target, $moan )= @_; Carp::confess("Panic: Can't _move_file_at_boot on this platform!") unless $CanMoveAtBoot; my $descr= ref $target ? "'$file' for deletion" : "'$file' for installation as '$target'"; # *note* CanMoveAtBoot is only incidentally the same condition as below # this needs not hold true in the future. $Has_Win32API_File = ($Is_Win32 || $Is_cygwin) ? (eval {require Win32API::File; 1} || 0) : 0 unless defined $Has_Win32API_File; if ( ! $Has_Win32API_File ) { my @msg=( "Cannot schedule $descr at reboot.", "Try installing Win32API::File to allow operations on locked files", "to be scheduled during reboot. Or try to perform the operation by", "hand yourself. (You may need to close other perl processes first)" ); if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } return 0; } my $opts= Win32API::File::MOVEFILE_DELAY_UNTIL_REBOOT(); $opts= $opts | Win32API::File::MOVEFILE_REPLACE_EXISTING() unless ref $target; _chmod( 0666, $file ); _chmod( 0666, $target ) unless ref $target; if (Win32API::File::MoveFileEx( $file, $target, $opts )) { $MUST_REBOOT ||= ref $target ? 0 : 1; return 1; } else { my @msg=( "MoveFileEx $descr at reboot failed: $^E", "You may try to perform the operation by hand yourself. ", "(You may need to close other perl processes first).", ); if ( $moan ) { _warnonce(@msg) } else { _choke(@msg) } } return 0; } } =begin _private =item _unlink_or_rename( $file, $tryhard, $installing ) OS-Specific, Win32/Cygwin Tries to get a file out of the way by unlinking it or renaming it. On some OS'es (Win32 based) DLL files can end up locked such that they can be renamed but not deleted. Likewise sometimes a file can be locked such that it cant even be renamed or changed except at reboot. To handle these cases this routine finds a tempfile name that it can either rename the file out of the way or use as a proxy for the install so that the rename can happen later (at reboot). $file : the file to remove. $tryhard : should advanced tricks be used for deletion $installing : we are not merely deleting but we want to overwrite When $tryhard is not true if the unlink fails its fatal. When $tryhard is true then the file is attempted to be renamed. The renamed file is then scheduled for deletion. If the rename fails then $installing governs what happens. If it is false the failure is fatal. If it is true then an attempt is made to schedule installation at boot using a temporary file to hold the new file. If this fails then a fatal error is thrown, if it succeeds it returns the temporary file name (which will be a derivative of the original in the same directory) so that the caller can use it to install under. In all other cases of success returns $file. On failure throws a fatal error. =end _private =cut sub _unlink_or_rename { #XXX OS-SPECIFIC my ( $file, $tryhard, $installing )= @_; # this chmod was originally unconditional. However, its not needed on # POSIXy systems since permission to unlink a file is specified by the # directory rather than the file; and in fact it screwed up hard- and # symlinked files. Keep it for other platforms in case its still # needed there. if ($^O =~ /^(dos|os2|MSWin32|VMS)$/) { _chmod( 0666, $file ); } my $unlink_count = 0; while (unlink $file) { $unlink_count++; } return $file if $unlink_count > 0; my $error="$!"; _choke("Cannot unlink '$file': $!") unless $CanMoveAtBoot && $tryhard; my $tmp= "AAA"; ++$tmp while -e "$file.$tmp"; $tmp= "$file.$tmp"; warn "WARNING: Unable to unlink '$file': $error\n", "Going to try to rename it to '$tmp'.\n"; if ( rename $file, $tmp ) { warn "Rename successful. Scheduling '$tmp'\nfor deletion at reboot.\n"; # when $installing we can set $moan to true. # IOW, if we cant delete the renamed file at reboot its # not the end of the world. The other cases are more serious # and need to be fatal. _move_file_at_boot( $tmp, [], $installing ); return $file; } elsif ( $installing ) { _warnonce("Rename failed: $!. Scheduling '$tmp'\nfor". " installation as '$file' at reboot.\n"); _move_file_at_boot( $tmp, $file ); return $tmp; } else { _choke("Rename failed:$!", "Cannot proceed."); } } =pod =back =head2 Functions =begin _private =over =item _get_install_skip Handles loading the INSTALL.SKIP file. Returns an array of patterns to use. =cut sub _get_install_skip { my ( $skip, $verbose )= @_; if ($ENV{EU_INSTALL_IGNORE_SKIP}) { print "EU_INSTALL_IGNORE_SKIP is set, ignore skipfile settings\n" if $verbose>2; return []; } if ( ! defined $skip ) { print "Looking for install skip list\n" if $verbose>2; for my $file ( 'INSTALL.SKIP', $ENV{EU_INSTALL_SITE_SKIPFILE} ) { next unless $file; print "\tChecking for $file\n" if $verbose>2; if (-e $file) { $skip= $file; last; } } } if ($skip && !ref $skip) { print "Reading skip patterns from '$skip'.\n" if $verbose; if (open my $fh,$skip ) { my @patterns; while (<$fh>) { chomp; next if /^\s*(?:#|$)/; print "\tSkip pattern: $_\n" if $verbose>3; push @patterns, $_; } $skip= \@patterns; } else { warn "Can't read skip file:'$skip':$!\n"; $skip=[]; } } elsif ( UNIVERSAL::isa($skip,'ARRAY') ) { print "Using array for skip list\n" if $verbose>2; } elsif ($verbose) { print "No skip list found.\n" if $verbose>1; $skip= []; } warn "Got @{[0+@$skip]} skip patterns.\n" if $verbose>3; return $skip } =pod =item _have_write_access Abstract a -w check that tries to use POSIX::access() if possible. =cut { my $has_posix; sub _have_write_access { my $dir=shift; unless (defined $has_posix) { $has_posix= (!$Is_cygwin && !$Is_Win32 && eval 'local $^W; require POSIX; 1') || 0; } if ($has_posix) { return POSIX::access($dir, POSIX::W_OK()); } else { return -w $dir; } } } =pod =item _can_write_dir(C<$dir>) Checks whether a given directory is writable, taking account the possibility that the directory might not exist and would have to be created first. Returns a list, containing: C<($writable, $determined_by, @create)> C<$writable> says whether the directory is (hypothetically) writable C<$determined_by> is the directory the status was determined from. It will be either the C<$dir>, or one of its parents. C<@create> is a list of directories that would probably have to be created to make the requested directory. It may not actually be correct on relative paths with C<..> in them. But for our purposes it should work ok =cut sub _can_write_dir { my $dir=shift; return unless defined $dir and length $dir; my ($vol, $dirs, $file) = File::Spec->splitpath($dir,1); my @dirs = File::Spec->splitdir($dirs); unshift @dirs, File::Spec->curdir unless File::Spec->file_name_is_absolute($dir); my $path=''; my @make; while (@dirs) { if ($Is_VMS) { $dir = File::Spec->catdir($vol,@dirs); } else { $dir = File::Spec->catdir(@dirs); $dir = File::Spec->catpath($vol,$dir,'') if defined $vol and length $vol; } next if ( $dir eq $path ); if ( ! -e $dir ) { unshift @make,$dir; next; } if ( _have_write_access($dir) ) { return 1,$dir,@make } else { return 0,$dir,@make } } continue { pop @dirs; } return 0; } =pod =item _mkpath($dir,$show,$mode,$verbose,$dry_run) Wrapper around File::Path::mkpath() to handle errors. If $verbose is true and >1 then additional diagnostics will be produced, also this will force $show to true. If $dry_run is true then the directory will not be created but a check will be made to see whether it would be possible to write to the directory, or that it would be possible to create the directory. If $dry_run is not true dies if the directory can not be created or is not writable. =cut sub _mkpath { my ($dir,$show,$mode,$verbose,$dry_run)=@_; if ( $verbose && $verbose > 1 && ! -d $dir) { $show= 1; printf "mkpath(%s,%d,%#o)\n", $dir, $show, $mode; } if (!$dry_run) { if ( ! eval { File::Path::mkpath($dir,$show,$mode); 1 } ) { _choke("Can't create '$dir'","$@"); } } my ($can,$root,@make)=_can_write_dir($dir); if (!$can) { my @msg=( "Can't create '$dir'", $root ? "Do not have write permissions on '$root'" : "Unknown Error" ); if ($dry_run) { _warnonce @msg; } else { _choke @msg; } } elsif ($show and $dry_run) { print "$_\n" for @make; } } =pod =item _copy($from,$to,$verbose,$dry_run) Wrapper around File::Copy::copy to handle errors. If $verbose is true and >1 then additional diagnostics will be emitted. If $dry_run is true then the copy will not actually occur. Dies if the copy fails. =cut sub _copy { my ( $from, $to, $verbose, $dry_run)=@_; if ($verbose && $verbose>1) { printf "copy(%s,%s)\n", $from, $to; } if (!$dry_run) { File::Copy::copy($from,$to) or Carp::croak( _estr "ERROR: Cannot copy '$from' to '$to': $!" ); } } =pod =item _chdir($from) Wrapper around chdir to catch errors. If not called in void context returns the cwd from before the chdir. dies on error. =cut sub _chdir { my ($dir)= @_; my $ret; if (defined wantarray) { $ret= cwd; } chdir $dir or _choke("Couldn't chdir to '$dir': $!"); return $ret; } =pod =back =end _private =over =item B<install> # deprecated forms install(\%from_to); install(\%from_to, $verbose, $dry_run, $uninstall_shadows, $skip, $always_copy, \%result); # recommended form as of 1.47 install([ from_to => \%from_to, verbose => 1, dry_run => 0, uninstall_shadows => 1, skip => undef, always_copy => 1, result => \%install_results, ]); Copies each directory tree of %from_to to its corresponding value preserving timestamps and permissions. There are two keys with a special meaning in the hash: "read" and "write". These contain packlist files. After the copying is done, install() will write the list of target files to $from_to{write}. If $from_to{read} is given the contents of this file will be merged into the written file. The read and the written file may be identical, but on AFS it is quite likely that people are installing to a different directory than the one where the files later appear. If $verbose is true, will print out each file removed. Default is false. This is "make install VERBINST=1". $verbose values going up to 5 show increasingly more diagnostics output. If $dry_run is true it will only print what it was going to do without actually doing it. Default is false. If $uninstall_shadows is true any differing versions throughout @INC will be uninstalled. This is "make install UNINST=1" As of 1.37_02 install() supports the use of a list of patterns to filter out files that shouldn't be installed. If $skip is omitted or undefined then install will try to read the list from INSTALL.SKIP in the CWD. This file is a list of regular expressions and is just like the MANIFEST.SKIP file used by L<ExtUtils::Manifest>. A default site INSTALL.SKIP may be provided by setting then environment variable EU_INSTALL_SITE_SKIPFILE, this will only be used when there isn't a distribution specific INSTALL.SKIP. If the environment variable EU_INSTALL_IGNORE_SKIP is true then no install file filtering will be performed. If $skip is undefined then the skip file will be autodetected and used if it is found. If $skip is a reference to an array then it is assumed the array contains the list of patterns, if $skip is a true non reference it is assumed to be the filename holding the list of patterns, any other value of $skip is taken to mean that no install filtering should occur. B<Changes As of Version 1.47> As of version 1.47 the following additions were made to the install interface. Note that the new argument style and use of the %result hash is recommended. The $always_copy parameter which when true causes files to be updated regardless as to whether they have changed, if it is defined but false then copies are made only if the files have changed, if it is undefined then the value of the environment variable EU_INSTALL_ALWAYS_COPY is used as default. The %result hash will be populated with the various keys/subhashes reflecting the install. Currently these keys and their structure are: install => { $target => $source }, install_fail => { $target => $source }, install_unchanged => { $target => $source }, install_filtered => { $source => $pattern }, uninstall => { $uninstalled => $source }, uninstall_fail => { $uninstalled => $source }, where C<$source> is the filespec of the file being installed. C<$target> is where it is being installed to, and C<$uninstalled> is any shadow file that is in C<@INC> or C<$ENV{PERL5LIB}> or other standard locations, and C<$pattern> is the pattern that caused a source file to be skipped. In future more keys will be added, such as to show created directories, however this requires changes in other modules and must therefore wait. These keys will be populated before any exceptions are thrown should there be an error. Note that all updates of the %result are additive, the hash will not be cleared before use, thus allowing status results of many installs to be easily aggregated. B<NEW ARGUMENT STYLE> If there is only one argument and it is a reference to an array then the array is assumed to contain a list of key-value pairs specifying the options. In this case the option "from_to" is mandatory. This style means that you do not have to supply a cryptic list of arguments and can use a self documenting argument list that is easier to understand. This is now the recommended interface to install(). B<RETURN> If all actions were successful install will return a hashref of the results as described above for the $result parameter. If any action is a failure then install will die, therefore it is recommended to pass in the $result parameter instead of using the return value. If the result parameter is provided then the returned hashref will be the passed in hashref. =cut sub install { #XXX OS-SPECIFIC my($from_to,$verbose,$dry_run,$uninstall_shadows,$skip,$always_copy,$result) = @_; if (@_==1 and eval { 1+@$from_to }) { my %opts = @$from_to; $from_to = $opts{from_to} or Carp::confess("from_to is a mandatory parameter"); $verbose = $opts{verbose}; $dry_run = $opts{dry_run}; $uninstall_shadows = $opts{uninstall_shadows}; $skip = $opts{skip}; $always_copy = $opts{always_copy}; $result = $opts{result}; } $result ||= {}; $verbose ||= 0; $dry_run ||= 0; $skip= _get_install_skip($skip,$verbose); $always_copy = $ENV{EU_INSTALL_ALWAYS_COPY} || $ENV{EU_ALWAYS_COPY} || 0 unless defined $always_copy; my(%from_to) = %$from_to; my(%pack, $dir, %warned); my($packlist) = ExtUtils::Packlist->new(); local(*DIR); for (qw/read write/) { $pack{$_}=$from_to{$_}; delete $from_to{$_}; } my $tmpfile = install_rooted_file($pack{"read"}); $packlist->read($tmpfile) if (-f $tmpfile); my $cwd = cwd(); my @found_files; my %check_dirs; MOD_INSTALL: foreach my $source (sort keys %from_to) { #copy the tree to the target directory without altering #timestamp and permission and remember for the .packlist #file. The packlist file contains the absolute paths of the #install locations. AFS users may call this a bug. We'll have #to reconsider how to add the means to satisfy AFS users also. #October 1997: we want to install .pm files into archlib if #there are any files in arch. So we depend on having ./blib/arch #hardcoded here. my $targetroot = install_rooted_dir($from_to{$source}); my $blib_lib = File::Spec->catdir('blib', 'lib'); my $blib_arch = File::Spec->catdir('blib', 'arch'); if ($source eq $blib_lib and exists $from_to{$blib_arch} and directory_not_empty($blib_arch) ){ $targetroot = install_rooted_dir($from_to{$blib_arch}); print "Files found in $blib_arch: installing files in $blib_lib into architecture dependent library tree\n"; } next unless -d $source; _chdir($source); # 5.5.3's File::Find missing no_chdir option # XXX OS-SPECIFIC # File::Find seems to always be Unixy except on MacPerl :( my $current_directory= $Is_MacPerl ? $Curdir : '.'; find(sub { my ($mode,$size,$atime,$mtime) = (stat)[2,7,8,9]; return if !-f _; my $origfile = $_; return if $origfile eq ".exists"; my $targetdir = File::Spec->catdir($targetroot, $File::Find::dir); my $targetfile = File::Spec->catfile($targetdir, $origfile); my $sourcedir = File::Spec->catdir($source, $File::Find::dir); my $sourcefile = File::Spec->catfile($sourcedir, $origfile); for my $pat (@$skip) { if ( $sourcefile=~/$pat/ ) { print "Skipping $targetfile (filtered)\n" if $verbose>1; $result->{install_filtered}{$sourcefile} = $pat; return; } } # we have to do this for back compat with old File::Finds # and because the target is relative my $save_cwd = _chdir($cwd); my $diff = 0; # XXX: I wonder how useful this logic is actually -- demerphq if ( $always_copy or !-f $targetfile or -s $targetfile != $size) { $diff++; } else { # we might not need to copy this file $diff = compare($sourcefile, $targetfile); } $check_dirs{$targetdir}++ unless -w $targetfile; push @found_files, [ $diff, $File::Find::dir, $origfile, $mode, $size, $atime, $mtime, $targetdir, $targetfile, $sourcedir, $sourcefile, ]; #restore the original directory we were in when File::Find #called us so that it doesn't get horribly confused. _chdir($save_cwd); }, $current_directory ); _chdir($cwd); } foreach my $targetdir (sort keys %check_dirs) { _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); } foreach my $found (@found_files) { my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, $targetdir, $targetfile, $sourcedir, $sourcefile)= @$found; my $realtarget= $targetfile; if ($diff) { eval { if (-f $targetfile) { print "_unlink_or_rename($targetfile)\n" if $verbose>1; $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) unless $dry_run; } elsif ( ! -d $targetdir ) { _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); } print "Installing $targetfile\n"; _copy( $sourcefile, $targetfile, $verbose, $dry_run, ); #XXX OS-SPECIFIC print "utime($atime,$mtime,$targetfile)\n" if $verbose>1; utime($atime,$mtime + $Is_VMS,$targetfile) unless $dry_run>1; $mode = 0444 | ( $mode & 0111 ? 0111 : 0 ); $mode = $mode | 0222 if $realtarget ne $targetfile; _chmod( $mode, $targetfile, $verbose ); $result->{install}{$targetfile} = $sourcefile; 1 } or do { $result->{install_fail}{$targetfile} = $sourcefile; die $@; }; } else { $result->{install_unchanged}{$targetfile} = $sourcefile; print "Skipping $targetfile (unchanged)\n" if $verbose; } if ( $uninstall_shadows ) { inc_uninstall($sourcefile,$ffd, $verbose, $dry_run, $realtarget ne $targetfile ? $realtarget : "", $result); } # Record the full pathname. $packlist->{$targetfile}++; } if ($pack{'write'}) { $dir = install_rooted_dir(dirname($pack{'write'})); _mkpath( $dir, 0, 0755, $verbose, $dry_run ); print "Writing $pack{'write'}\n" if $verbose; $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run; } _do_cleanup($verbose); return $result; } =begin _private =item _do_cleanup Standardize finish event for after another instruction has occurred. Handles converting $MUST_REBOOT to a die for instance. =end _private =cut sub _do_cleanup { my ($verbose) = @_; if ($MUST_REBOOT) { die _estr "Operation not completed! ", "You must reboot to complete the installation.", "Sorry."; } elsif (defined $MUST_REBOOT & $verbose) { warn _estr "Installation will be completed at the next reboot.\n", "However it is not necessary to reboot immediately.\n"; } } =begin _undocumented =item install_rooted_file( $file ) Returns $file, or catfile($INSTALL_ROOT,$file) if $INSTALL_ROOT is defined. =item install_rooted_dir( $dir ) Returns $dir, or catdir($INSTALL_ROOT,$dir) if $INSTALL_ROOT is defined. =end _undocumented =cut sub install_rooted_file { if (defined $INSTALL_ROOT) { File::Spec->catfile($INSTALL_ROOT, $_[0]); } else { $_[0]; } } sub install_rooted_dir { if (defined $INSTALL_ROOT) { File::Spec->catdir($INSTALL_ROOT, $_[0]); } else { $_[0]; } } =begin _undocumented =item forceunlink( $file, $tryhard ) Tries to delete a file. If $tryhard is true then we will use whatever devious tricks we can to delete the file. Currently this only applies to Win32 in that it will try to use Win32API::File to schedule a delete at reboot. A wrapper for _unlink_or_rename(). =end _undocumented =cut sub forceunlink { my ( $file, $tryhard )= @_; #XXX OS-SPECIFIC _unlink_or_rename( $file, $tryhard, not("installing") ); } =begin _undocumented =item directory_not_empty( $dir ) Returns 1 if there is an .exists file somewhere in a directory tree. Returns 0 if there is not. =end _undocumented =cut sub directory_not_empty ($) { my($dir) = @_; my $files = 0; find(sub { return if $_ eq ".exists"; if (-f) { $File::Find::prune++; $files = 1; } }, $dir); return $files; } =pod =item B<install_default> I<DISCOURAGED> install_default(); install_default($fullext); Calls install() with arguments to copy a module from blib/ to the default site installation location. $fullext is the name of the module converted to a directory (ie. Foo::Bar would be Foo/Bar). If $fullext is not specified, it will attempt to read it from @ARGV. This is primarily useful for install scripts. B<NOTE> This function is not really useful because of the hard-coded install location with no way to control site vs core vs vendor directories and the strange way in which the module name is given. Consider its use discouraged. =cut sub install_default { @_ < 2 or Carp::croak("install_default should be called with 0 or 1 argument"); my $FULLEXT = @_ ? shift : $ARGV[0]; defined $FULLEXT or die "Do not know to where to write install log"; my $INST_LIB = File::Spec->catdir($Curdir,"blib","lib"); my $INST_ARCHLIB = File::Spec->catdir($Curdir,"blib","arch"); my $INST_BIN = File::Spec->catdir($Curdir,'blib','bin'); my $INST_SCRIPT = File::Spec->catdir($Curdir,'blib','script'); my $INST_MAN1DIR = File::Spec->catdir($Curdir,'blib','man1'); my $INST_MAN3DIR = File::Spec->catdir($Curdir,'blib','man3'); my @INST_HTML; if($Config{installhtmldir}) { my $INST_HTMLDIR = File::Spec->catdir($Curdir,'blib','html'); @INST_HTML = ($INST_HTMLDIR => $Config{installhtmldir}); } install({ read => "$Config{sitearchexp}/auto/$FULLEXT/.packlist", write => "$Config{installsitearch}/auto/$FULLEXT/.packlist", $INST_LIB => (directory_not_empty($INST_ARCHLIB)) ? $Config{installsitearch} : $Config{installsitelib}, $INST_ARCHLIB => $Config{installsitearch}, $INST_BIN => $Config{installbin} , $INST_SCRIPT => $Config{installscript}, $INST_MAN1DIR => $Config{installman1dir}, $INST_MAN3DIR => $Config{installman3dir}, @INST_HTML, },1,0,0); } =item B<uninstall> uninstall($packlist_file); uninstall($packlist_file, $verbose, $dont_execute); Removes the files listed in a $packlist_file. If $verbose is true, will print out each file removed. Default is false. If $dont_execute is true it will only print what it was going to do without actually doing it. Default is false. =cut sub uninstall { my($fil,$verbose,$dry_run) = @_; $verbose ||= 0; $dry_run ||= 0; die _estr "ERROR: no packlist file found: '$fil'" unless -f $fil; # my $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al)); # require $my_req; # Hairy, but for the first my ($packlist) = ExtUtils::Packlist->new($fil); foreach (sort(keys(%$packlist))) { chomp; print "unlink $_\n" if $verbose; forceunlink($_,'tryhard') unless $dry_run; } print "unlink $fil\n" if $verbose; forceunlink($fil, 'tryhard') unless $dry_run; _do_cleanup($verbose); } =begin _undocumented =item inc_uninstall($filepath,$libdir,$verbose,$dry_run,$ignore,$results) Remove shadowed files. If $ignore is true then it is assumed to hold a filename to ignore. This is used to prevent spurious warnings from occurring when doing an install at reboot. We now only die when failing to remove a file that has precedence over our own, when our install has precedence we only warn. $results is assumed to contain a hashref which will have the keys 'uninstall' and 'uninstall_fail' populated with keys for the files removed and values of the source files they would shadow. =end _undocumented =cut sub inc_uninstall { my($filepath,$libdir,$verbose,$dry_run,$ignore,$results) = @_; my($dir); $ignore||=""; my $file = (File::Spec->splitpath($filepath))[2]; my %seen_dir = (); my @PERL_ENV_LIB = split $Config{path_sep}, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'} || ''; my @dirs=( @PERL_ENV_LIB, @INC, @Config{qw(archlibexp privlibexp sitearchexp sitelibexp)}); #warn join "\n","---",@dirs,"---"; my $seen_ours; foreach $dir ( @dirs ) { my $canonpath = $Is_VMS ? $dir : File::Spec->canonpath($dir); next if $canonpath eq $Curdir; next if $seen_dir{$canonpath}++; my $targetfile = File::Spec->catfile($canonpath,$libdir,$file); next unless -f $targetfile; # The reason why we compare file's contents is, that we cannot # know, which is the file we just installed (AFS). So we leave # an identical file in place my $diff = 0; if ( -f $targetfile && -s _ == -s $filepath) { # We have a good chance, we can skip this one $diff = compare($filepath,$targetfile); } else { $diff++; } print "#$file and $targetfile differ\n" if $diff && $verbose > 1; if (!$diff or $targetfile eq $ignore) { $seen_ours = 1; next; } if ($dry_run) { $results->{uninstall}{$targetfile} = $filepath; if ($verbose) { $Inc_uninstall_warn_handler ||= ExtUtils::Install::Warn->new(); $libdir =~ s|^\./||s ; # That's just cosmetics, no need to port. It looks prettier. $Inc_uninstall_warn_handler->add( File::Spec->catfile($libdir, $file), $targetfile ); } # if not verbose, we just say nothing } else { print "Unlinking $targetfile (shadowing?)\n" if $verbose; eval { die "Fake die for testing" if $ExtUtils::Install::Testing and ucase(File::Spec->canonpath($ExtUtils::Install::Testing)) eq ucase($targetfile); forceunlink($targetfile,'tryhard'); $results->{uninstall}{$targetfile} = $filepath; 1; } or do { $results->{fail_uninstall}{$targetfile} = $filepath; if ($seen_ours) { warn "Failed to remove probably harmless shadow file '$targetfile'\n"; } else { die "$@\n"; } }; } } } =begin _undocumented =item run_filter($cmd,$src,$dest) Filter $src using $cmd into $dest. =end _undocumented =cut sub run_filter { my ($cmd, $src, $dest) = @_; local(*CMD, *SRC); open(CMD, "|$cmd >$dest") || die "Cannot fork: $!"; open(SRC, $src) || die "Cannot open $src: $!"; my $buf; my $sz = 1024; while (my $len = sysread(SRC, $buf, $sz)) { syswrite(CMD, $buf, $len); } close SRC; close CMD or die "Filter command '$cmd' failed for $src"; } =pod =item B<pm_to_blib> pm_to_blib(\%from_to); pm_to_blib(\%from_to, $autosplit_dir); pm_to_blib(\%from_to, $autosplit_dir, $filter_cmd); Copies each key of %from_to to its corresponding value efficiently. If an $autosplit_dir is provided, all .pm files will be autosplit into it. Any destination directories are created. $filter_cmd is an optional shell command to run each .pm file through prior to splitting and copying. Input is the contents of the module, output the new module contents. You can have an environment variable PERL_INSTALL_ROOT set which will be prepended as a directory to each installed file (and directory). By default verbose output is generated, setting the PERL_INSTALL_QUIET environment variable will silence this output. =cut sub pm_to_blib { my($fromto,$autodir,$pm_filter) = @_; _mkpath($autodir,0,0755) if defined $autodir; while(my($from, $to) = each %$fromto) { if( -f $to && -s $from == -s $to && -M $to < -M $from ) { print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; next; } # When a pm_filter is defined, we need to pre-process the source first # to determine whether it has changed or not. Therefore, only perform # the comparison check when there's no filter to be ran. # -- RAM, 03/01/2001 my $need_filtering = defined $pm_filter && length $pm_filter && $from =~ /\.pm$/; if (!$need_filtering && 0 == compare($from,$to)) { print "Skip $to (unchanged)\n" unless $INSTALL_QUIET; next; } if (-f $to){ # we wont try hard here. its too likely to mess things up. forceunlink($to); } else { _mkpath(dirname($to),0,0755); } if ($need_filtering) { run_filter($pm_filter, $from, $to); print "$pm_filter <$from >$to\n"; } else { _copy( $from, $to ); print "cp $from $to\n" unless $INSTALL_QUIET; } my($mode,$atime,$mtime) = (stat $from)[2,8,9]; utime($atime,$mtime+$Is_VMS,$to); _chmod(0444 | ( $mode & 0111 ? 0111 : 0 ),$to); next unless $from =~ /\.pm$/; _autosplit($to,$autodir) if defined $autodir; } } =begin _private =item _autosplit From 1.0307 back, AutoSplit will sometimes leave an open filehandle to the file being split. This causes problems on systems with mandatory locking (ie. Windows). So we wrap it and close the filehandle. =end _private =cut sub _autosplit { #XXX OS-SPECIFIC my $retval = autosplit(@_); close *AutoSplit::IN if defined *AutoSplit::IN{IO}; return $retval; } package ExtUtils::Install::Warn; sub new { bless {}, shift } sub add { my($self,$file,$targetfile) = @_; push @{$self->{$file}}, $targetfile; } sub DESTROY { unless(defined $INSTALL_ROOT) { my $self = shift; my($file,$i,$plural); foreach $file (sort keys %$self) { $plural = @{$self->{$file}} > 1 ? "s" : ""; print "## Differing version$plural of $file found. You might like to\n"; for (0..$#{$self->{$file}}) { print "rm ", $self->{$file}[$_], "\n"; $i++; } } $plural = $i>1 ? "all those files" : "this file"; my $inst = (_invokant() eq 'ExtUtils::MakeMaker') ? ( $Config::Config{make} || 'make' ).' install' . ( $Is_VMS ? '/MACRO="UNINST"=1' : ' UNINST=1' ) : './Build install uninst=1'; print "## Running '$inst' will unlink $plural for you.\n"; } } =begin _private =item _invokant Does a heuristic on the stack to see who called us for more intelligent error messages. Currently assumes we will be called only by Module::Build or by ExtUtils::MakeMaker. =end _private =cut sub _invokant { my @stack; my $frame = 0; while (my $file = (caller($frame++))[1]) { push @stack, (File::Spec->splitpath($file))[2]; } my $builder; my $top = pop @stack; if ($top =~ /^Build/i || exists($INC{'Module/Build.pm'})) { $builder = 'Module::Build'; } else { $builder = 'ExtUtils::MakeMaker'; } return $builder; } =pod =back =head1 ENVIRONMENT =over 4 =item B<PERL_INSTALL_ROOT> Will be prepended to each install path. =item B<EU_INSTALL_IGNORE_SKIP> Will prevent the automatic use of INSTALL.SKIP as the install skip file. =item B<EU_INSTALL_SITE_SKIPFILE> If there is no INSTALL.SKIP file in the make directory then this value can be used to provide a default. =item B<EU_INSTALL_ALWAYS_COPY> If this environment variable is true then normal install processes will always overwrite older identical files during the install process. Note that the alias EU_ALWAYS_COPY will be supported if EU_INSTALL_ALWAYS_COPY is not defined until at least the 1.50 release. Please ensure you use the correct EU_INSTALL_ALWAYS_COPY. =back =head1 AUTHOR Original author lost in the mists of time. Probably the same as Makemaker. Production release currently maintained by demerphq C<yves at cpan.org>, extensive changes by Michael G. Schwern. Send bug reports via http://rt.cpan.org/. Please send your generated Makefile along with your report. =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L<http://www.perl.com/perl/misc/Artistic.html> =cut 1; perl5/ExtUtils/MANIFEST.SKIP 0000444 00000001713 14711220175 0011252 0 ustar 00 # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this \b_eumm/ # 7.05_05 and above # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # and Module::Build::Tiny generated files \b_build_params$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ \..*\.sw.?$ # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid prove files \B\.prove$ # Avoid MYMETA files ^MYMETA\. perl5/x86_64-linux-thread-multi/.meta/common-sense-3.75/install.json 0000444 00000000322 14711220177 0020622 0 ustar 00 {"provides":{"common::sense":{"version":3.75,"file":"sense.pm.PL"}},"target":"common::sense","version":3.75,"name":"common::sense","dist":"common-sense-3.75","pathname":"M/ML/MLEHMANN/common-sense-3.75.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/common-sense-3.75/MYMETA.json 0000444 00000001474 14711220177 0020161 0 ustar 00 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "common-sense", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : 3.75 } perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.16/install.json 0000444 00000000425 14711220200 0017264 0 ustar 00 {"provides":{"IO::Tty::Constant":{"version":1.16,"file":"Tty/Constant.pm"},"IO::Pty":{"version":1.16,"file":"Pty.pm"},"IO::Tty":{"version":1.16,"file":"Tty.pm"}},"target":"IO::Tty","version":1.16,"name":"IO::Tty","dist":"IO-Tty-1.16","pathname":"T/TO/TODDR/IO-Tty-1.16.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/IO-Tty-1.16/MYMETA.json 0000444 00000002236 14711220202 0016616 0 ustar 00 { "abstract" : "Pseudo ttys and constants", "author" : [ "Roland Giersig <RGiersig@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "IO-Tty", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/toddr/IO-Tty/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/toddr/IO-Tty" } }, "version" : "1.16", "x_serialization_backend" : "JSON::PP version 4.04" } perl5/x86_64-linux-thread-multi/.meta/Types-Serialiser-1.01/install.json 0000444 00000000660 14711220203 0021401 0 ustar 00 {"provides":{"JSON::PP::Boolean":{"version":1.01,"file":"Serialiser.pm"},"Types::Serialiser":{"version":1.01,"file":"Serialiser.pm"},"Types::Serialiser::BooleanBase":{"version":1.01,"file":"Serialiser.pm"},"Types::Serialiser::Error":{"version":1.01,"file":"Serialiser.pm"}},"target":"Types::Serialiser","version":1.01,"name":"Types::Serialiser","dist":"Types-Serialiser-1.01","pathname":"M/ML/MLEHMANN/Types-Serialiser-1.01.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Types-Serialiser-1.01/MYMETA.json 0000444 00000001556 14711220204 0020735 0 ustar 00 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Types-Serialiser", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "common::sense" : "0" } } }, "release_status" : "stable", "version" : "1.01" } perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0209/install.json 0000444 00000005143 14711220205 0020100 0 ustar 00 {"provides":{"XML::LibXML::PI":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0209,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0209,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0209,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0209,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0209,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0209,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0209,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0209,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0209,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0209,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0209,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0209,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0209,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0209,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0209,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0209,"name":"XML::LibXML","dist":"XML-LibXML-2.0209","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0209.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0209/MYMETA.json 0000444 00000004733 14711220207 0017434 0 ustar 00 { "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library", "author" : [ "Petr Pajas <PAJAS@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "keywords" : [ "dom", "html", "libxml", "object oriented", "oop", "parse", "parser", "parsing", "pullparser", "sax", "sgml", "xml", "xpath", "XPath", "xs" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-LibXML", "no_index" : { "directory" : [ "t", "inc", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Alien::Base::Wrapper" : "0", "Alien::Libxml2" : "0.14", "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "DynaLoader" : "0", "Encode" : "0", "Exporter" : "5.57", "IO::Handle" : "0", "Scalar::Util" : "0", "Tie::Hash" : "0", "XML::NamespaceSupport" : "1.07", "XML::SAX" : "0.11", "XML::SAX::Base" : "0", "XML::SAX::DocumentLocator" : "0", "XML::SAX::Exception" : "0", "base" : "0", "constant" : "0", "overload" : "0", "parent" : "0", "perl" : "5.008001", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Config" : "0", "Errno" : "0", "IO::File" : "0", "IO::Handle" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Test::More" : "0", "locale" : "0", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/shlomif/perl-XML-LibXML.git", "web" : "https://github.com/shlomif/perl-XML-LibXML" } }, "version" : "2.0209", "x_serialization_backend" : "JSON::PP version 4.16" } perl5/x86_64-linux-thread-multi/.meta/XML-NamespaceSupport-1.12/install.json 0000444 00000000416 14711220210 0022123 0 ustar 00 {"provides":{"XML::NamespaceSupport":{"version":"1.12","file":"lib/XML/NamespaceSupport.pm"}},"target":"XML::NamespaceSupport","version":"1.12","name":"XML::NamespaceSupport","dist":"XML-NamespaceSupport-1.12","pathname":"P/PE/PERIGRIN/XML-NamespaceSupport-1.12.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-NamespaceSupport-1.12/MYMETA.json 0000444 00000010440 14711220210 0021447 0 ustar 00 { "abstract" : "A simple generic namespace processor", "author" : [ "Robin Berjon <robin@knowscape.com>", "Chris Prather <chris@prather.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-NamespaceSupport", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::Authority" : "0", "Dist::Zilla::Plugin::AutoPrereqs" : "0", "Dist::Zilla::Plugin::CPANFile" : "0", "Dist::Zilla::Plugin::CheckChangesHasContent" : "0", "Dist::Zilla::Plugin::CheckMetaResources" : "0", "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0", "Dist::Zilla::Plugin::ConfirmRelease" : "0", "Dist::Zilla::Plugin::CopyFilesFromBuild" : "0", "Dist::Zilla::Plugin::ExecDir" : "0", "Dist::Zilla::Plugin::Git::Check" : "0", "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0", "Dist::Zilla::Plugin::Git::Commit" : "0", "Dist::Zilla::Plugin::Git::Contributors" : "0", "Dist::Zilla::Plugin::Git::GatherDir" : "0", "Dist::Zilla::Plugin::Git::NextVersion" : "0", "Dist::Zilla::Plugin::Git::Push" : "0", "Dist::Zilla::Plugin::Git::Tag" : "0", "Dist::Zilla::Plugin::GithubMeta" : "0", "Dist::Zilla::Plugin::InsertCopyright" : "0", "Dist::Zilla::Plugin::License" : "0", "Dist::Zilla::Plugin::MakeMaker" : "0", "Dist::Zilla::Plugin::Manifest" : "0", "Dist::Zilla::Plugin::ManifestSkip" : "0", "Dist::Zilla::Plugin::MetaJSON" : "0", "Dist::Zilla::Plugin::MetaNoIndex" : "0", "Dist::Zilla::Plugin::MetaProvides::Package" : "0", "Dist::Zilla::Plugin::MetaYAML" : "0", "Dist::Zilla::Plugin::MinimumPerl" : "0", "Dist::Zilla::Plugin::NextRelease" : "0", "Dist::Zilla::Plugin::OurPkgVersion" : "0", "Dist::Zilla::Plugin::PodWeaver" : "0", "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0", "Dist::Zilla::Plugin::PromptIfStale" : "0", "Dist::Zilla::Plugin::PruneCruft" : "0", "Dist::Zilla::Plugin::RunExtraTests" : "0", "Dist::Zilla::Plugin::ShareDir" : "0", "Dist::Zilla::Plugin::TestRelease" : "0", "Dist::Zilla::Plugin::UploadToCPAN" : "0", "Software::License::Perl_5" : "0" } }, "runtime" : { "requires" : { "constant" : "0", "perl" : "5.006", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "provides" : { "XML::NamespaceSupport" : { "file" : "lib/XML/NamespaceSupport.pm", "version" : "1.12" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/perigrin/xml-namespacesupport/issues" }, "homepage" : "https://github.com/perigrin/xml-namespacesupport", "repository" : { "type" : "git", "url" : "https://github.com/perigrin/xml-namespacesupport.git", "web" : "https://github.com/perigrin/xml-namespacesupport" } }, "version" : "1.12", "x_authority" : "cpan:PERIGRIN", "x_contributors" : [ "Chris Prather <cprather@hdpublishing.com>", "David Steinbrunner <dsteinbrunner@pobox.com>", "Paul Cochrane <paul@liekut.de>", "Paulo Custodio <pauloscustodio@gmail.com>" ], "x_serialization_backend" : "Cpanel::JSON::XS version 3.0231" } perl5/x86_64-linux-thread-multi/.meta/XML-Parser-2.46/install.json 0000444 00000001064 14711220210 0020076 0 ustar 00 {"provides":{"XML::Parser::Expat":{"version":2.46,"file":"Expat/Expat.pm"},"XML::Parser::Style::Tree":{"file":"Parser/Style/Tree.pm"},"XML::Parser::Style::Stream":{"file":"Parser/Style/Stream.pm"},"XML::Parser::Style::Objects":{"file":"Parser/Style/Objects.pm"},"XML::Parser":{"version":2.46,"file":"Parser.pm"},"XML::Parser::Style::Subs":{"file":"Parser/Style/Subs.pm"},"XML::Parser::Style::Debug":{"file":"Parser/Style/Debug.pm"}},"target":"XML::Parser","version":2.46,"name":"XML::Parser","dist":"XML-Parser-2.46","pathname":"T/TO/TODDR/XML-Parser-2.46.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-Parser-2.46/MYMETA.json 0000444 00000002510 14711220210 0017421 0 ustar 00 { "abstract" : "A perl module for parsing XML documents", "author" : [ "Clark Cooper (coopercc@netheaven.com)" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-Parser", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "LWP::UserAgent" : "0", "perl" : "5.004050" } }, "test" : { "requires" : { "Test::More" : "0", "warnings" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/toddr/XML-Parser/issues" }, "repository" : { "url" : "http://github.com/toddr/XML-Parser" } }, "version" : "2.46", "x_serialization_backend" : "JSON::PP version 2.97001" } perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.41/install.json 0000444 00000015763 14711220210 0020277 0 ustar 00 {"provides":{"Alien::Build::Plugin::Core::Setup":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/Setup.pm"},"Alien::Build::Plugin::Extract::ArchiveZip":{"version":2.41,"file":"lib/Alien/Build/Plugin/Extract/ArchiveZip.pm"},"Alien::Build::Plugin::Core::Tail":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/Tail.pm"},"Alien::Build::Plugin::Fetch::CurlCommand":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/CurlCommand.pm"},"Alien::Build::Plugin::Decode::DirListing":{"version":2.41,"file":"lib/Alien/Build/Plugin/Decode/DirListing.pm"},"Alien::Build::Plugin::Build::MSYS":{"version":2.41,"file":"lib/Alien/Build/Plugin/Build/MSYS.pm"},"Test::Alien":{"version":2.41,"file":"lib/Test/Alien.pm"},"Alien::Build::Interpolate":{"version":2.41,"file":"lib/Alien/Build/Interpolate.pm"},"Alien::Build::Plugin::Extract::Negotiate":{"version":2.41,"file":"lib/Alien/Build/Plugin/Extract/Negotiate.pm"},"Alien::Build::Meta":{"version":2.41,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin::PkgConfig::LibPkgConf":{"version":2.41,"file":"lib/Alien/Build/Plugin/PkgConfig/LibPkgConf.pm"},"Alien::Build::Plugin::Gather::IsolateDynamic":{"version":2.41,"file":"lib/Alien/Build/Plugin/Gather/IsolateDynamic.pm"},"Test::Alien::Build":{"version":2.41,"file":"lib/Test/Alien/Build.pm"},"Alien::Build::Plugin::Probe::CBuilder":{"version":2.41,"file":"lib/Alien/Build/Plugin/Probe/CBuilder.pm"},"Alien::Build::Interpolate::Default":{"version":2.41,"file":"lib/Alien/Build/Interpolate/Default.pm"},"Alien::Build::Plugin::Fetch::LocalDir":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/LocalDir.pm"},"Alien::Build::Plugin::Probe::CommandLine":{"version":2.41,"file":"lib/Alien/Build/Plugin/Probe/CommandLine.pm"},"Alien::Build::Plugin::PkgConfig::PP":{"version":2.41,"file":"lib/Alien/Build/Plugin/PkgConfig/PP.pm"},"Alien::Build::Plugin::PkgConfig::Negotiate":{"version":2.41,"file":"lib/Alien/Build/Plugin/PkgConfig/Negotiate.pm"},"Alien::Build::MM":{"version":2.41,"file":"lib/Alien/Build/MM.pm"},"Alien::Build::Plugin::Core::Download":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/Download.pm"},"Alien::Build::TempDir":{"version":2.41,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin::PkgConfig::CommandLine":{"version":2.41,"file":"lib/Alien/Build/Plugin/PkgConfig/CommandLine.pm"},"Alien::Base::Wrapper":{"version":2.41,"file":"lib/Alien/Base/Wrapper.pm"},"Test::Alien::Synthetic":{"version":2.41,"file":"lib/Test/Alien/Synthetic.pm"},"Alien::Build::Helper":{"version":2.41,"file":"lib/Alien/Build/Interpolate.pm"},"Alien::Build::Interpolate::Helper":{"version":2.41,"file":"lib/Alien/Build/Interpolate.pm"},"Alien::Build":{"version":2.41,"file":"lib/Alien/Build.pm"},"Alien::Build::PluginMeta":{"version":2.41,"file":"lib/Alien/Build/Plugin.pm"},"Alien::Build::Plugin::Prefer::GoodVersion":{"version":2.41,"file":"lib/Alien/Build/Plugin/Prefer/GoodVersion.pm"},"Alien::Build::Plugin::Extract::CommandLine":{"version":2.41,"file":"lib/Alien/Build/Plugin/Extract/CommandLine.pm"},"Alien::Build::Plugin::Core::CleanInstall":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/CleanInstall.pm"},"Alien::Build::rc":{"version":2.41,"file":"lib/Alien/Build.pm"},"Alien::Build::Plugin":{"version":2.41,"file":"lib/Alien/Build/Plugin.pm"},"alienfile":{"version":2.41,"file":"lib/alienfile.pm"},"Alien::Build::Plugin::Fetch::LWP":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/LWP.pm"},"Alien::Base::PkgConfig":{"version":2.41,"file":"lib/Alien/Base/PkgConfig.pm"},"Alien::Base":{"version":2.41,"file":"lib/Alien/Base.pm"},"Alien::Build::Temp":{"version":2.41,"file":"lib/Alien/Build/Temp.pm"},"Test::Alien::CanPlatypus":{"version":2.41,"file":"lib/Test/Alien/CanPlatypus.pm"},"Alien::Build::Plugin::Decode::DirListingFtpcopy":{"version":2.41,"file":"lib/Alien/Build/Plugin/Decode/DirListingFtpcopy.pm"},"Alien::Build::Plugin::Test::Mock":{"version":2.41,"file":"lib/Alien/Build/Plugin/Test/Mock.pm"},"Alien::Build::Plugin::Decode::HTML":{"version":2.41,"file":"lib/Alien/Build/Plugin/Decode/HTML.pm"},"Alien::Build::Version::Basic":{"version":2.41,"file":"lib/Alien/Build/Version/Basic.pm"},"Alien::Build::Plugin::Decode::Mojo":{"version":2.41,"file":"lib/Alien/Build/Plugin/Decode/Mojo.pm"},"Alien::Build::Plugin::Fetch::NetFTP":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/NetFTP.pm"},"Alien::Build::Plugin::Core::Gather":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/Gather.pm"},"Alien::Build::Plugin::Build::CMake":{"version":2.41,"file":"lib/Alien/Build/Plugin/Build/CMake.pm"},"Alien::Build::Plugin::Prefer::SortVersions":{"version":2.41,"file":"lib/Alien/Build/Plugin/Prefer/SortVersions.pm"},"Alien::Build::Plugin::Core::Override":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/Override.pm"},"Alien::Build::Plugin::Build::SearchDep":{"version":2.41,"file":"lib/Alien/Build/Plugin/Build/SearchDep.pm"},"Alien::Role":{"version":2.41,"file":"lib/Alien/Role.pm"},"Alien::Build::Log::Abbreviate":{"version":2.41,"file":"lib/Alien/Build/Log/Abbreviate.pm"},"Alien::Build::Plugin::Core::FFI":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/FFI.pm"},"Test::Alien::CanCompile":{"version":2.41,"file":"lib/Test/Alien/CanCompile.pm"},"Alien::Build::Log":{"version":2.41,"file":"lib/Alien/Build/Log.pm"},"Alien::Build::Plugin::Prefer::BadVersion":{"version":2.41,"file":"lib/Alien/Build/Plugin/Prefer/BadVersion.pm"},"Alien::Build::Plugin::Core::Legacy":{"version":2.41,"file":"lib/Alien/Build/Plugin/Core/Legacy.pm"},"Alien::Build::Log::Default":{"version":2.41,"file":"lib/Alien/Build/Log/Default.pm"},"Test::Alien::Diag":{"version":2.41,"file":"lib/Test/Alien/Diag.pm"},"Alien::Build::Plugin::Probe::Vcpkg":{"version":2.41,"file":"lib/Alien/Build/Plugin/Probe/Vcpkg.pm"},"Alien::Build::CommandSequence":{"version":2.41,"file":"lib/Alien/Build/CommandSequence.pm"},"Alien::Build::Plugin::Build::Make":{"version":2.41,"file":"lib/Alien/Build/Plugin/Build/Make.pm"},"Alien::Build::Plugin::Fetch::Wget":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/Wget.pm"},"Alien::Build::Plugin::PkgConfig::MakeStatic":{"version":2.41,"file":"lib/Alien/Build/Plugin/PkgConfig/MakeStatic.pm"},"Alien::Build::Plugin::Build::Autoconf":{"version":2.41,"file":"lib/Alien/Build/Plugin/Build/Autoconf.pm"},"Test::Alien::Run":{"version":2.41,"file":"lib/Test/Alien/Run.pm"},"Alien::Build::Util":{"version":2.41,"file":"lib/Alien/Build/Util.pm"},"Alien::Build::Plugin::Build::Copy":{"version":2.41,"file":"lib/Alien/Build/Plugin/Build/Copy.pm"},"Alien::Build::Plugin::Fetch::Local":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/Local.pm"},"Alien::Build::Plugin::Extract::Directory":{"version":2.41,"file":"lib/Alien/Build/Plugin/Extract/Directory.pm"},"Alien::Build::Plugin::Download::Negotiate":{"version":2.41,"file":"lib/Alien/Build/Plugin/Download/Negotiate.pm"},"Alien::Build::Plugin::Fetch::HTTPTiny":{"version":2.41,"file":"lib/Alien/Build/Plugin/Fetch/HTTPTiny.pm"},"Alien::Build::Plugin::Extract::ArchiveTar":{"version":2.41,"file":"lib/Alien/Build/Plugin/Extract/ArchiveTar.pm"}},"target":"Alien::Base::Wrapper","version":2.41,"name":"Alien::Build","dist":"Alien-Build-2.41","pathname":"P/PL/PLICEASE/Alien-Build-2.41.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Alien-Build-2.41/MYMETA.json 0000444 00000007775 14711220210 0017631 0 ustar 00 { "abstract" : "Build external dependencies for use in CPAN", "author" : [ "Graham Ollis <plicease@cpan.org>", "Joel Berger <joel.a.berger@gmail.com>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.020, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Alien-Build", "no_index" : { "directory" : [ "corpus", "example", "maint" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.64" } }, "configure" : { "requires" : { "ExtUtils::CBuilder" : "0", "ExtUtils::MakeMaker" : "6.64", "ExtUtils::ParseXS" : "3.30", "File::Which" : "0" } }, "develop" : { "requires" : { "FindBin" : "0", "Perl::Critic" : "0", "Test2::Require::Module" : "0.000121", "Test2::Tools::PerlCritic" : "0", "Test2::V0" : "0.000121", "Test::CPAN::Changes" : "0", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.98", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Spelling" : "0" } }, "runtime" : { "requires" : { "Capture::Tiny" : "0.17", "Digest::SHA" : "0", "ExtUtils::CBuilder" : "0", "ExtUtils::MakeMaker" : "6.64", "ExtUtils::ParseXS" : "3.30", "FFI::CheckLib" : "0.11", "File::Which" : "1.10", "File::chdir" : "0", "JSON::PP" : "0", "List::Util" : "1.33", "Path::Tiny" : "0.077", "Test2::API" : "1.302096", "Text::ParseWords" : "3.26", "parent" : "0", "perl" : "5.008004" }, "suggests" : { "Archive::Tar" : "0" } }, "test" : { "requires" : { "Test2::API" : "1.302096", "Test2::V0" : "0.000121" }, "suggests" : { "Devel::Hide" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PerlAlien/Alien-Build/issues" }, "homepage" : "https://metacpan.org/pod/Alien::Build", "repository" : { "type" : "git", "url" : "git://github.com/PerlAlien/Alien-Build.git", "web" : "https://github.com/PerlAlien/Alien-Build" }, "x_IRC" : "irc://irc.perl.org/#native" }, "version" : "2.41", "x_contributors" : [ "Graham Ollis <plicease@cpan.org>", "Diab Jerius (DJERIUS)", "Roy Storey (KIWIROY)", "Ilya Pavlov", "David Mertens (run4flat)", "Mark Nunberg (mordy, mnunberg)", "Christian Walde (Mithaldu)", "Brian Wightman (MidLifeXis)", "Zaki Mughal (zmughal)", "mohawk (mohawk2, ETJ)", "Vikas N Kumar (vikasnkumar)", "Flavio Poletti (polettix)", "Salvador Fandiño (salva)", "Gianni Ceccarelli (dakkar)", "Pavel Shaydo (zwon, trinitum)", "Kang-min Liu (劉康民, gugod)", "Nicholas Shipp (nshp)", "Juan Julián Merelo Guervós (JJ)", "Joel Berger (JBERGER)", "Petr Pisar (ppisar)", "Lance Wicks (LANCEW)", "Ahmad Fatoum (a3f, ATHREEF)", "José Joaquín Atria (JJATRIA)", "Duke Leto (LETO)", "Shoichi Kaji (SKAJI)", "Shawn Laffan (SLAFFAN)", "Paul Evans (leonerd, PEVANS)", "Håkon Hægland (hakonhagland, HAKONH)", "nick nauwelaerts (INPHOBIA)" ], "x_generated_by_perl" : "v5.34.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.26", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_use_unsafe_inc" : 0 } perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Base-1.09/install.json 0000444 00000000556 14711220210 0020150 0 ustar 00 {"provides":{"XML::SAX::Base::NoHandler":{"version":1.09,"file":"lib/XML/SAX/Base.pm"},"XML::SAX::Base":{"version":1.09,"file":"lib/XML/SAX/Base.pm"},"XML::SAX::Exception":{"version":1.09,"file":"lib/XML/SAX/Exception.pm"}},"target":"XML::SAX::Base","version":1.09,"name":"XML::SAX::Base","dist":"XML-SAX-Base-1.09","pathname":"G/GR/GRANTM/XML-SAX-Base-1.09.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Base-1.09/MYMETA.json 0000444 00000002310 14711220210 0017464 0 ustar 00 { "abstract" : "Base class for SAX Drivers and Filters", "author" : [ "Grant McLean <grantm@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.022, CPAN::Meta::Converter version 2.142690, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-SAX-Base", "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "requires" : { "perl" : "5.008" } }, "test" : { "requires" : { "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/grantm/XML-SAX-Base.git", "web" : "https://github.com/grantm/XML-SAX-Base" } }, "version" : "1.09" } perl5/x86_64-linux-thread-multi/.meta/Scalar-List-Utils-1.56/install.json 0000444 00000000607 14711220211 0021423 0 ustar 00 {"provides":{"Scalar::Util":{"version":1.56,"file":"lib/Scalar/Util.pm"},"List::Util::XS":{"version":1.56,"file":"lib/List/Util/XS.pm"},"List::Util":{"version":1.56,"file":"lib/List/Util.pm"},"Sub::Util":{"version":1.56,"file":"lib/Sub/Util.pm"}},"target":"List::Util","version":1.56,"name":"List::Util","dist":"Scalar-List-Utils-1.56","pathname":"P/PE/PEVANS/Scalar-List-Utils-1.56.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Scalar-List-Utils-1.56/MYMETA.json 0000444 00000002717 14711220211 0020755 0 ustar 00 { "abstract" : "Common Scalar and List utility subroutines", "author" : [ "Graham Barr <gbarr@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Scalar-List-Utils", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.006" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Scalar-List-Utils@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Scalar-List-Utils" }, "repository" : { "type" : "git", "url" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils.git", "web" : "https://github.com/Scalar-List-Utils/Scalar-List-Utils" } }, "version" : "1.56", "x_serialization_backend" : "JSON::PP version 4.04" } perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.009/install.json 0000444 00000007772 14711220211 0021477 0 ustar 00 {"provides":{"Template::Base":{"version":3.009,"file":"lib/Template/Base.pm"},"Template::Stash::Context":{"version":3.009,"file":"lib/Template/Stash/Context.pm"},"Template::Config":{"version":3.009,"file":"lib/Template/Config.pm"},"Template::Plugin::Date::Calc":{"version":3.009,"file":"lib/Template/Plugin/Date.pm"},"Template::View":{"version":3.009,"file":"lib/Template/View.pm"},"Template::Perl":{"version":3.009,"file":"lib/Template/Filters.pm"},"Template::Plugin::Procedural":{"version":3.009,"file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"version":3.009,"file":"lib/Template/Plugin/Table.pm"},"Template::Plugin::Filter":{"version":3.009,"file":"lib/Template/Plugin/Filter.pm"},"Template::Iterator":{"version":3.009,"file":"lib/Template/Iterator.pm"},"Template::Plugin::Pod":{"version":3.009,"file":"lib/Template/Plugin/Pod.pm"},"Template::Constants":{"version":3.009,"file":"lib/Template/Constants.pm"},"Template::VMethods":{"version":3.009,"file":"lib/Template/VMethods.pm"},"Template::Monad::Scalar":{"version":3.009,"file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Datafile":{"version":3.009,"file":"lib/Template/Plugin/Datafile.pm"},"Template::Plugin::URL":{"version":3.009,"file":"lib/Template/Plugin/URL.pm"},"Template::Filters":{"version":3.009,"file":"lib/Template/Filters.pm"},"Template::Namespace::Constants":{"version":3.009,"file":"lib/Template/Namespace/Constants.pm"},"Template::Toolkit":{"version":3.009,"file":"lib/Template/Toolkit.pm"},"Template::Context":{"version":3.009,"file":"lib/Template/Context.pm"},"Template::Directive":{"version":3.009,"file":"lib/Template/Directive.pm"},"Template::Plugin":{"version":3.009,"file":"lib/Template/Plugin.pm"},"Template::TieString":{"version":3.009,"file":"lib/Template/Config.pm"},"Template::Plugin::Wrap":{"version":3.009,"file":"lib/Template/Plugin/Wrap.pm"},"Template::Parser":{"version":3.009,"file":"lib/Template/Parser.pm"},"Template::Grammar":{"version":3.009,"file":"lib/Template/Grammar.pm"},"Template::Plugin::HTML":{"version":3.009,"file":"lib/Template/Plugin/HTML.pm"},"Template::Plugin::Format":{"version":3.009,"file":"lib/Template/Plugin/Format.pm"},"Template::Plugin::Scalar":{"version":3.009,"file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Directory":{"version":3.009,"file":"lib/Template/Plugin/Directory.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Dumper":{"version":3.009,"file":"lib/Template/Plugin/Dumper.pm"},"Template::Plugins":{"version":3.009,"file":"lib/Template/Plugins.pm"},"Template::Plugin::Assert":{"version":3.009,"file":"lib/Template/Plugin/Assert.pm"},"Template::Provider":{"version":3.009,"file":"lib/Template/Provider.pm"},"Template::Stash":{"version":3.009,"file":"lib/Template/Stash.pm"},"Template::Plugin::Image":{"version":3.009,"file":"lib/Template/Plugin/Image.pm"},"Template::Plugin::Date::Manip":{"version":3.009,"file":"lib/Template/Plugin/Date.pm"},"Template::Exception":{"version":3.009,"file":"lib/Template/Exception.pm"},"Template::Plugin::String":{"version":3.009,"file":"lib/Template/Plugin/String.pm"},"Template::Document":{"version":3.009,"file":"lib/Template/Document.pm"},"Template::Plugin::Math":{"version":3.009,"file":"lib/Template/Plugin/Math.pm"},"Template::Service":{"version":3.009,"file":"lib/Template/Service.pm"},"Template::Test":{"version":3.009,"file":"lib/Template/Test.pm"},"Template::Monad::Assert":{"version":3.009,"file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::Iterator":{"version":3.009,"file":"lib/Template/Plugin/Iterator.pm"},"Template":{"version":3.009,"file":"lib/Template.pm"},"Template::Plugin::CGI":{"version":3.009,"file":"lib/Template/Plugin/CGI.pm"},"Template::Plugin::Date":{"version":3.009,"file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::File":{"version":3.009,"file":"lib/Template/Plugin/File.pm"},"Template::Plugin::View":{"version":3.009,"file":"lib/Template/Plugin/View.pm"}},"target":"Template::Constants","version":3.009,"name":"Template","dist":"Template-Toolkit-3.009","pathname":"A/AT/ATOOMIC/Template-Toolkit-3.009.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.009/MYMETA.json 0000444 00000002660 14711220211 0021014 0 ustar 00 { "abstract" : "comprehensive template processing system", "author" : [ "Andy Wardley <abw@wardley.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Template-Toolkit", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "AppConfig" : "1.56", "File::Spec" : "0.8", "File::Temp" : "0.12", "Scalar::Util" : "0" } }, "test" : { "requires" : { "CGI" : "4.11", "Test::LeakTrace" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/abw/Template2/issues" }, "homepage" : "http://www.template-toolkit.org", "repository" : { "type" : "git", "url" : "https://github.com/abw/Template2.git", "web" : "https://github.com/abw/Template2" } }, "version" : "3.009" } perl5/x86_64-linux-thread-multi/.meta/AppConfig-1.71/install.json 0000444 00000001121 14711220211 0020042 0 ustar 00 {"provides":{"AppConfig::CGI":{"version":1.71,"file":"lib/AppConfig/CGI.pm"},"AppConfig::Args":{"version":1.71,"file":"lib/AppConfig/Args.pm"},"AppConfig::Sys":{"version":1.71,"file":"lib/AppConfig/Sys.pm"},"AppConfig::State":{"version":1.71,"file":"lib/AppConfig/Getopt.pm"},"AppConfig":{"version":1.71,"file":"lib/AppConfig.pm"},"AppConfig::File":{"version":1.71,"file":"lib/AppConfig/File.pm"},"AppConfig::Getopt":{"version":1.71,"file":"lib/AppConfig/Getopt.pm"}},"target":"AppConfig","version":1.71,"name":"AppConfig","dist":"AppConfig-1.71","pathname":"N/NE/NEILB/AppConfig-1.71.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/AppConfig-1.71/MYMETA.json 0000444 00000002375 14711220211 0017404 0 ustar 00 { "abstract" : "AppConfig is a bundle of Perl5 modules for reading configuration files and parsing command line arguments.", "author" : [ "Andy Wardley <abw@wardley.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.02, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "AppConfig", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Test::More" : "0", "perl" : "5.008008" } }, "test" : { "requires" : { "Test::Pod" : "1.0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/neilbowers/AppConfig.git", "web" : "https://github.com/neilbowers/AppConfig" } }, "version" : "1.71" } perl5/x86_64-linux-thread-multi/.meta/CPAN-2.28/install.json 0000444 00000006750 14711220211 0016735 0 ustar 00 {"provides":{"CPAN::Index":{"version":2.12,"file":"lib/CPAN/Index.pm"},"CPAN::Plugin":{"version":0.97,"file":"lib/CPAN/Plugin.pm"},"CPAN::Mirrored::By":{"version":2.27,"file":"lib/CPAN/Mirrors.pm"},"CPAN::HTTP::Client":{"version":1.9601,"file":"lib/CPAN/HTTP/Client.pm"},"CPAN::FTP::netrc":{"version":1.01,"file":"lib/CPAN/FTP/netrc.pm"},"CPAN::Version":{"version":5.5003,"file":"lib/CPAN/Version.pm"},"CPAN::Admin":{"version":5.501,"file":"lib/CPAN/Admin.pm"},"CPAN::Plugin::Specfile":{"version":0.02,"file":"lib/CPAN/Plugin/Specfile.pm"},"CPAN::Distroprefs::Result::Error":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::InfoObj":{"version":5.5,"file":"lib/CPAN/InfoObj.pm"},"CPAN::Exception::RecursiveDependency::na":{"version":5.5001,"file":"lib/CPAN/Exception/RecursiveDependency.pm"},"CPAN::HandleConfig":{"version":5.5011,"file":"lib/CPAN/HandleConfig.pm"},"CPAN::Exception::yaml_process_error":{"version":5.5,"file":"lib/CPAN/Exception/yaml_process_error.pm"},"CPAN::Nox":{"version":5.5001,"file":"lib/CPAN/Nox.pm"},"CPAN::Exception::RecursiveDependency":{"version":5.5001,"file":"lib/CPAN/Exception/RecursiveDependency.pm"},"CPAN::Distroprefs::Result::Warning":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distroprefs::Pref":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Debug":{"version":5.5001,"file":"lib/CPAN/Debug.pm"},"CPAN::Distroprefs::Result::Success":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Shell":{"version":5.5009,"file":"lib/CPAN/Shell.pm"},"CPAN::Queue::Item":{"version":5.5003,"file":"lib/CPAN/Queue.pm"},"CPAN::CacheMgr":{"version":5.5002,"file":"lib/CPAN/CacheMgr.pm"},"CPAN::Eval":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distroprefs":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distribution":{"version":2.27,"file":"lib/CPAN/Distribution.pm"},"CPAN::Complete":{"version":5.5001,"file":"lib/CPAN/Complete.pm"},"CPAN::FirstTime":{"version":5.5315,"file":"lib/CPAN/FirstTime.pm"},"App::Cpan":{"version":1.676,"file":"lib/App/Cpan.pm"},"CPAN::Author":{"version":5.5002,"file":"lib/CPAN/Author.pm"},"CPAN::URL":{"version":5.5,"file":"lib/CPAN/URL.pm"},"CPAN::Kwalify":{"version":"5.50","file":"lib/CPAN/Kwalify.pm"},"CPAN::LWP::UserAgent":{"version":1.9601,"file":"lib/CPAN/LWP/UserAgent.pm"},"CPAN::Bundle":{"version":5.5005,"file":"lib/CPAN/Bundle.pm"},"CPAN::FTP":{"version":5.5013,"file":"lib/CPAN/FTP.pm"},"CPAN::HTTP::Credentials":{"version":1.9601,"file":"lib/CPAN/HTTP/Credentials.pm"},"CPAN::Distroprefs::Result::Fatal":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Distrostatus":{"version":5.5,"file":"lib/CPAN/Distrostatus.pm"},"CPAN::Module":{"version":5.5003,"file":"lib/CPAN/Module.pm"},"CPAN::Distroprefs::Result":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::Exception::blocked_urllist":{"version":1.001,"file":"lib/CPAN/Exception/blocked_urllist.pm"},"CPAN::Tarzip":{"version":5.5013,"file":"lib/CPAN/Tarzip.pm"},"CPAN::Mirrors":{"version":2.27,"file":"lib/CPAN/Mirrors.pm"},"CPAN::Distroprefs::Iterator":{"version":6.0001,"file":"lib/CPAN/Distroprefs.pm"},"CPAN::DeferredCode":{"version":"5.50","file":"lib/CPAN/DeferredCode.pm"},"CPAN::Prompt":{"version":5.5,"file":"lib/CPAN/Prompt.pm"},"CPAN::Exception::yaml_not_installed":{"version":5.5,"file":"lib/CPAN/Exception/yaml_not_installed.pm"},"CPAN::Queue":{"version":5.5003,"file":"lib/CPAN/Queue.pm"},"CPAN":{"version":2.28,"file":"lib/CPAN.pm"}},"target":"CPAN","version":2.28,"name":"CPAN","dist":"CPAN-2.28","pathname":"A/AN/ANDK/CPAN-2.28.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/CPAN-2.28/MYMETA.json 0000444 00000004506 14711220211 0016260 0 ustar 00 { "abstract" : "query, download and build perl modules from CPAN sites", "author" : [ "Andreas Koenig <andreas.koenig.gmwojprw@franz.ak.mind.de>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.120921", "keywords" : [ "CPAN", "module", "module installation" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CPAN", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Archive::Tar" : "0", "CPAN::Meta" : "0", "CPAN::Meta::Requirements" : "2.121", "CPAN::Meta::YAML" : "0", "Compress::Zlib" : "0", "Data::Dumper" : "0", "Digest::MD5" : "0", "Digest::SHA" : "0", "Exporter" : "0", "Exporter::Heavy" : "0", "ExtUtils::CBuilder" : "0", "File::Copy" : "0", "File::Spec" : "0", "File::Temp" : "0", "HTTP::Tiny" : "0", "IO::Compress::Base" : "0", "IO::Zlib" : "0", "JSON::PP" : "0", "LWP::UserAgent" : "0", "MIME::Base64" : "0", "Module::Build" : "0", "Net::FTP" : "0", "Net::Ping" : "0", "Parse::CPAN::Meta" : "0", "Pod::Perldoc" : "0", "Pod::Perldoc::ToMan" : "0", "Scalar::Util" : "0", "Socket" : "0", "Term::ReadKey" : "0", "Test::Harness" : "2.62", "Test::More" : "0", "Text::ParseWords" : "0", "Text::Wrap" : "0", "perl" : "5.006002" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/andk/cpanpm" } }, "version" : "2.28", "x_serialization_backend" : "JSON::PP version 2.97001" } perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0210/install.json 0000444 00000005255 14711220211 0020071 0 ustar 00 {"provides":{"XML::LibXML::PI":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::SAX":{"version":"2.0210","file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":"2.0210","file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":"2.0210","file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":"2.0210","file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":"2.0210","file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":"2.0210","file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Devel":{"version":"2.0210","file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":"2.0210","file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":"2.0210","file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Literal":{"version":"2.0210","file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":"2.0210","file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":"2.0210","file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Element":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Attr":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Node":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Number":{"version":"2.0210","file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":"2.0210","file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":"2.0210","file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Common":{"version":"2.0210","file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Document":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":"2.0210","file":"LibXML.pm"},"XML::LibXML::Text":{"version":"2.0210","file":"LibXML.pm"}},"target":"XML::LibXML","version":"2.0210","name":"XML::LibXML","dist":"XML-LibXML-2.0210","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0210.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0210/MYMETA.json 0000444 00000004733 14711220211 0017417 0 ustar 00 { "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library", "author" : [ "Petr Pajas <PAJAS@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "keywords" : [ "dom", "html", "libxml", "object oriented", "oop", "parse", "parser", "parsing", "pullparser", "sax", "sgml", "xml", "xpath", "XPath", "xs" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-LibXML", "no_index" : { "directory" : [ "t", "inc", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Alien::Base::Wrapper" : "0", "Alien::Libxml2" : "0.14", "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "DynaLoader" : "0", "Encode" : "0", "Exporter" : "5.57", "IO::Handle" : "0", "Scalar::Util" : "0", "Tie::Hash" : "0", "XML::NamespaceSupport" : "1.07", "XML::SAX" : "0.11", "XML::SAX::Base" : "0", "XML::SAX::DocumentLocator" : "0", "XML::SAX::Exception" : "0", "base" : "0", "constant" : "0", "overload" : "0", "parent" : "0", "perl" : "5.008001", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Config" : "0", "Errno" : "0", "IO::File" : "0", "IO::Handle" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Test::More" : "0", "locale" : "0", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/shlomif/perl-XML-LibXML.git", "web" : "https://github.com/shlomif/perl-XML-LibXML" } }, "version" : "2.0210", "x_serialization_backend" : "JSON::PP version 4.16" } perl5/x86_64-linux-thread-multi/.meta/FFI-CheckLib-0.28/install.json 0000444 00000000332 14711220212 0020247 0 ustar 00 {"provides":{"FFI::CheckLib":{"version":0.28,"file":"lib/FFI/CheckLib.pm"}},"target":"FFI::CheckLib","version":0.28,"name":"FFI::CheckLib","dist":"FFI-CheckLib-0.28","pathname":"P/PL/PLICEASE/FFI-CheckLib-0.28.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/FFI-CheckLib-0.28/MYMETA.json 0000444 00000005201 14711220212 0017575 0 ustar 00 { "abstract" : "Check that a library is available for FFI", "author" : [ "Graham Ollis <plicease@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.017, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "FFI-CheckLib", "no_index" : { "directory" : [ "corpus" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "FindBin" : "0", "Perl::Critic" : "0", "Test2::Require::Module" : "0.000060", "Test2::Tools::PerlCritic" : "0", "Test2::V0" : "0.000060", "Test::CPAN::Changes" : "0", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.98", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::Strict" : "0", "YAML" : "0" } }, "runtime" : { "requires" : { "List::Util" : "1.33", "perl" : "5.006" } }, "test" : { "requires" : { "Test2::API" : "1.302015", "Test2::Require::EnvVar" : "0.000060", "Test2::Require::Module" : "0.000060", "Test2::V0" : "0.000060" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PerlFFI/FFI-CheckLib/issues" }, "homepage" : "https://metacpan.org/pod/FFI::CheckLib", "repository" : { "type" : "git", "url" : "git://github.com/PerlFFI/FFI-CheckLib.git", "web" : "https://github.com/PerlFFI/FFI-CheckLib" }, "x_IRC" : "irc://irc.perl.org/#native" }, "version" : "0.28", "x_contributors" : [ "Graham Ollis <plicease@cpan.org>", "Bakkiaraj Murugesan (bakkiaraj)", "Dan Book (grinnz, DBOOK)", "Ilya Pavlov (Ilya, ILUX)", "Shawn Laffan (SLAFFAN)", "Petr Pisar (ppisar)" ], "x_generated_by_perl" : "v5.33.9", "x_serialization_backend" : "Cpanel::JSON::XS version 4.26", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_use_unsafe_inc" : 0 } perl5/x86_64-linux-thread-multi/.meta/IO-Stringy-2.113/install.json 0000444 00000001207 14711220212 0020224 0 ustar 00 {"provides":{"IO::WrapTie":{"version":"2.113","file":"lib/IO/WrapTie.pm"},"IO::Stringy":{"version":"2.113","file":"lib/IO/Stringy.pm"},"IO::Scalar":{"version":"2.113","file":"lib/IO/Scalar.pm"},"IO::ScalarArray":{"version":"2.113","file":"lib/IO/ScalarArray.pm"},"IO::InnerFile":{"version":"2.113","file":"lib/IO/InnerFile.pm"},"IO::Wrap":{"version":"2.113","file":"lib/IO/Wrap.pm"},"IO::Lines":{"version":"2.113","file":"lib/IO/Lines.pm"},"IO::AtomicFile":{"version":"2.113","file":"lib/IO/AtomicFile.pm"}},"target":"IO::Scalar","version":"2.113","name":"IO::Stringy","dist":"IO-Stringy-2.113","pathname":"C/CA/CAPOEIRAB/IO-Stringy-2.113.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/IO-Stringy-2.113/MYMETA.json 0000444 00000046357 14711220212 0017571 0 ustar 00 { "abstract" : "I/O on in-core objects like strings and arrays", "author" : [ "Erik Dorfman <eryq@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "IO-Stringy", "no_index" : { "directory" : [ "eg", "examples", "inc", "share", "t", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Dist::Zilla" : "0", "File::Spec" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Changes" : "0.4", "Test::CheckManifest" : "1.29", "Test::Kwalitee" : "1.22", "Test::More" : "0.88", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Pod::Spelling::CommonMistakes" : "1.000", "Test::Spelling" : "0.12", "Test::TrailingSpace" : "0", "Test::Version" : "1" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "5.57", "File::Spec" : "0", "FileHandle" : "0", "IO::File" : "0", "IO::Handle" : "0", "Symbol" : "0", "overload" : "0", "parent" : "0", "strict" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Basename" : "0", "File::Spec" : "0", "File::Temp" : "0", "FileHandle" : "0", "IO::File" : "0", "IO::Handle" : "0", "Symbol" : "0", "Test::More" : "0.88", "Test::Tester" : "0", "strict" : "0", "warnings" : "0" } } }, "provides" : { "IO::AtomicFile" : { "file" : "lib/IO/AtomicFile.pm", "version" : "2.113" }, "IO::InnerFile" : { "file" : "lib/IO/InnerFile.pm", "version" : "2.113" }, "IO::Lines" : { "file" : "lib/IO/Lines.pm", "version" : "2.113" }, "IO::Scalar" : { "file" : "lib/IO/Scalar.pm", "version" : "2.113" }, "IO::ScalarArray" : { "file" : "lib/IO/ScalarArray.pm", "version" : "2.113" }, "IO::Stringy" : { "file" : "lib/IO/Stringy.pm", "version" : "2.113" }, "IO::Wrap" : { "file" : "lib/IO/Wrap.pm", "version" : "2.113" }, "IO::WrapTie" : { "file" : "lib/IO/WrapTie.pm", "version" : "2.113" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/genio/IO-Stringy/issues" }, "homepage" : "https://github.com/genio/IO-Stringy", "repository" : { "type" : "git", "url" : "https://github.com/genio/IO-Stringy.git", "web" : "https://github.com/genio/IO-Stringy" } }, "version" : "2.113", "x_Dist_Zilla" : { "perl" : { "version" : "5.030000" }, "plugins" : [ { "class" : "Dist::Zilla::Plugin::Git::GatherDir", "config" : { "Dist::Zilla::Plugin::GatherDir" : { "exclude_filename" : [ "LICENSE", "META.json", "Makefile.PL", "README.md", "t/00-report-prereqs.t" ], "exclude_match" : [], "follow_symlinks" : 0, "include_dotfiles" : 0, "prefix" : "", "prune_directory" : [], "root" : "." }, "Dist::Zilla::Plugin::Git::GatherDir" : { "include_untracked" : 0 } }, "name" : "Git::GatherDir", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "@Starter/MetaYAML", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "@Starter/MetaJSON", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "@Starter/License", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::Pod2Readme", "name" : "@Starter/Pod2Readme", "version" : "0.004" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "@Starter/PodSyntaxTests", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", "name" : "@Starter/Test::ReportPrereqs", "version" : "0.027" }, { "class" : "Dist::Zilla::Plugin::Test::Compile", "config" : { "Dist::Zilla::Plugin::Test::Compile" : { "bail_out_on_fail" : 0, "fail_on_warning" : "author", "fake_home" : 0, "filename" : "xt/author/00-compile.t", "module_finder" : [ ":InstallModules" ], "needs_display" : 0, "phase" : "develop", "script_finder" : [ ":PerlExecFiles" ], "skips" : [], "switch" : [] } }, "name" : "@Starter/Test::Compile", "version" : "2.058" }, { "class" : "Dist::Zilla::Plugin::MakeMaker::Awesome", "config" : { "Dist::Zilla::Plugin::MakeMaker" : { "make_path" : "gmake", "version" : "6.012" }, "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 1, "version" : "6.012" } }, "name" : "@Starter/MakeMaker::Awesome", "version" : "0.48" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "@Starter/Manifest", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::PruneCruft", "name" : "@Starter/PruneCruft", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::ManifestSkip", "name" : "@Starter/ManifestSkip", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::RunExtraTests", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 1 } }, "name" : "@Starter/RunExtraTests", "version" : "0.029" }, { "class" : "Dist::Zilla::Plugin::RewriteVersion", "config" : { "Dist::Zilla::Plugin::RewriteVersion" : { "add_tarball_name" : 0, "finders" : [ ":ExecFiles", ":InstallModules" ], "global" : 1, "skip_version_provider" : 0 } }, "name" : "@Starter/RewriteVersion", "version" : "0.018" }, { "class" : "Dist::Zilla::Plugin::NextRelease", "name" : "@Starter/NextRelease", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease", "config" : { "Dist::Zilla::Plugin::BumpVersionAfterRelease" : { "finders" : [ ":ExecFiles", ":InstallModules" ], "global" : 0, "munge_makefile_pl" : 1 } }, "name" : "@Starter/BumpVersionAfterRelease", "version" : "0.018" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "@Starter/TestRelease", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "@Starter/ConfirmRelease", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "@Starter/UploadToCPAN", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "@Starter/MetaConfig", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::MetaNoIndex", "name" : "@Starter/MetaNoIndex", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Package", "config" : { "Dist::Zilla::Plugin::MetaProvides::Package" : { "finder_objects" : [ { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "@Starter/MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.012" } ], "include_underscores" : 0 }, "Dist::Zilla::Role::MetaProvider::Provider" : { "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004", "inherit_missing" : 1, "inherit_version" : 1, "meta_noindex" : 1 }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000036", "version" : "0.006" } }, "name" : "@Starter/MetaProvides::Package", "version" : "2.004003" }, { "class" : "Dist::Zilla::Plugin::ShareDir", "name" : "@Starter/ShareDir", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "@Starter/ExecDir", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", "config" : { "Dist::Zilla::Role::FileWatcher" : { "version" : "0.006" } }, "name" : "Markdown_Readme", "version" : "0.163250" }, { "class" : "Dist::Zilla::Plugin::Prereqs::FromCPANfile", "name" : "Prereqs::FromCPANfile", "version" : "0.08" }, { "class" : "Dist::Zilla::Plugin::Git::Contributors", "config" : { "Dist::Zilla::Plugin::Git::Contributors" : { "git_version" : "2.16.1.windows.1", "include_authors" : 0, "include_releaser" : 1, "order_by" : "name", "paths" : [] } }, "name" : "Git::Contributors", "version" : "0.035" }, { "class" : "Dist::Zilla::Plugin::GithubMeta", "name" : "GithubMeta", "version" : "0.58" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "config" : { "Dist::Zilla::Plugin::Git::Check" : { "untracked_files" : "die" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "Changes", "dist.ini" ], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.16.1.windows.1", "repo_root" : "." } }, "name" : "@Git/Check", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [], "commit_msg" : "v%V%n%n%c" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "Changes", "dist.ini" ], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.16.1.windows.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Git/Commit", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "config" : { "Dist::Zilla::Plugin::Git::Tag" : { "branch" : null, "changelog" : "Changes", "signed" : 0, "tag" : "v2.113", "tag_format" : "v%V", "tag_message" : "v%V" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.16.1.windows.1", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Git/Tag", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::Git::Push", "config" : { "Dist::Zilla::Plugin::Git::Push" : { "push_to" : [ "origin" ], "remotes_must_exist" : 1 }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.16.1.windows.1", "repo_root" : "." } }, "name" : "@Git/Push", "version" : "2.046" }, { "class" : "Dist::Zilla::Plugin::CheckChangeLog", "name" : "CheckChangeLog", "version" : "0.05" }, { "class" : "Dist::Zilla::Plugin::CheckChangesHasContent", "name" : "CheckChangesHasContent", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent", "name" : "Test::ChangesHasContent", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::Test::Kwalitee", "config" : { "Dist::Zilla::Plugin::Test::Kwalitee" : { "filename" : "xt/release/kwalitee.t", "skiptest" : [ "no_symlinks" ] } }, "name" : "Test::Kwalitee", "version" : "2.12" }, { "class" : "Dist::Zilla::Plugin::Test::Version", "name" : "Test::Version", "version" : "1.09" }, { "class" : "Dist::Zilla::Plugin::Test::Pod::Coverage::Configurable", "name" : "Test::Pod::Coverage::Configurable", "version" : "0.07" }, { "class" : "Dist::Zilla::Plugin::Test::PodSpelling", "config" : { "Dist::Zilla::Plugin::Test::PodSpelling" : { "directories" : [ "bin", "lib" ], "spell_cmd" : "", "stopwords" : [ "BUF", "Doru", "FOO", "Foo", "NBYTES", "POS", "SCALARREF", "SLAVECLASS", "ZeeGee", "aref", "dfs", "getline", "getlines", "getpos", "ing", "reblessed", "setpos", "sref", "tieable", "wraphandle" ], "wordlist" : "Pod::Wordlist" } }, "name" : "Test::PodSpelling", "version" : "2.007005" }, { "class" : "Dist::Zilla::Plugin::CopyFilesFromBuild", "name" : "CopyFilesFromBuild", "version" : "0.170880" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExtraTestFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":PerlExecFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":AllFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":NoFiles", "version" : "6.012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : "@Starter/MetaProvides::Package/AUTOVIV/:InstallModulesPM", "version" : "6.012" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : 0 }, "version" : "6.012" } }, "x_contributors" : [ "Chase Whitener <capoeirab@cpan.org>", "Dianne Skoll <dskoll@cpan.org>" ], "x_generated_by_perl" : "v5.30.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.11" } perl5/x86_64-linux-thread-multi/.meta/Expect-1.35/install.json 0000444 00000000261 14711220212 0017431 0 ustar 00 {"provides":{"Expect":{"version":1.35,"file":"lib/Expect.pm"}},"target":"Expect","version":1.35,"name":"Expect","dist":"Expect-1.35","pathname":"J/JA/JACOBY/Expect-1.35.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Expect-1.35/MYMETA.json 0000444 00000003140 14711220212 0016756 0 ustar 00 { "abstract" : "automate interactions with command line programs that expose a text terminal interface.", "author" : [ "Austin Schutz <ASchutz@users.sourceforge.net>", "Roland Giersig <RGiersig@cpan.org>", "Dave Jacoby <jacoby@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Expect", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64" } }, "runtime" : { "requires" : { "Carp" : "0", "Errno" : "0", "Exporter" : "0", "Fcntl" : "0", "IO::Handle" : "0", "IO::Pty" : "1.11", "IO::Tty" : "1.11", "POSIX" : "0", "perl" : "5.006000" } }, "test" : { "requires" : { "File::Temp" : "0", "Test::More" : "1.00" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "http://github.com/jacoby/expect.pm.git", "web" : "http://github.com/jacoby/expect.pm" } }, "version" : "1.35", "x_serialization_backend" : "JSON::PP version 2.27400" } perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.17/install.json 0000444 00000000340 14711220212 0020535 0 ustar 00 {"provides":{"Alien::Libxml2":{"version":0.17,"file":"lib/Alien/Libxml2.pm"}},"target":"Alien::Libxml2","version":0.17,"name":"Alien::Libxml2","dist":"Alien-Libxml2-0.17","pathname":"P/PL/PLICEASE/Alien-Libxml2-0.17.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Alien-Libxml2-0.17/MYMETA.json 0000444 00000006320 14711220212 0020067 0 ustar 00 { "abstract" : "Install the C libxml2 library on your system", "author" : [ "Graham Ollis <plicease@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Alien-Libxml2", "prereqs" : { "build" : { "requires" : { "Alien::Build" : "2.37", "Alien::Build::MM" : "0.32", "ExtUtils::MakeMaker" : "6.52" } }, "configure" : { "requires" : { "Alien::Build" : "2.37", "Alien::Build::MM" : "2.37", "Alien::Build::Plugin::Build::SearchDep" : "0.35", "Alien::Build::Plugin::Prefer::BadVersion" : "1.05", "Alien::Build::Plugin::Probe::Vcpkg" : "0", "ExtUtils::CBuilder" : "0", "ExtUtils::MakeMaker" : "6.52" } }, "develop" : { "requires" : { "File::Spec" : "0", "FindBin" : "0", "Perl::Critic" : "0", "Test2::Require::Module" : "0.000060", "Test2::Tools::PerlCritic" : "0", "Test2::V0" : "0.000060", "Test::CPAN::Changes" : "0", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.98", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::Strict" : "0", "YAML" : "0" } }, "runtime" : { "requires" : { "Alien::Base" : "2.37", "Alien::Build" : "0.25", "perl" : "5.006" } }, "test" : { "requires" : { "Test2::V0" : "0.000060", "Test::Alien" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/PerlAlien/Alien-Libxml2/issues" }, "homepage" : "https://metacpan.org/pod/Alien::Libxml2", "repository" : { "type" : "git", "url" : "git://github.com/PerlAlien/Alien-Libxml2.git", "web" : "https://github.com/PerlAlien/Alien-Libxml2" }, "x_IRC" : "irc://irc.perl.org/#native" }, "version" : "0.17", "x_alienfile" : { "generated_by" : "Dist::Zilla::Plugin::AlienBuild version 0.31", "requires" : { "share" : { "Archive::Tar" : "0", "Config" : "0", "HTTP::Tiny" : "0.044", "IO::Zlib" : "0", "Mojo::DOM58" : "1.00", "Sort::Versions" : "0", "URI" : "0", "URI::Escape" : "0" }, "system" : {} } }, "x_contributors" : [ "Graham Ollis <plicease@cpan.org>", "Shlomi Fish (shlomif)" ], "x_generated_by_perl" : "v5.33.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.19", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_use_unsafe_inc" : 0 } perl5/x86_64-linux-thread-multi/.meta/File-chdir-0.1010/install.json 0000444 00000000545 14711220212 0020305 0 ustar 00 {"provides":{"File::chdir::ARRAY":{"version":"0.1010","file":"lib/File/chdir.pm"},"File::chdir::SCALAR":{"version":"0.1010","file":"lib/File/chdir.pm"},"File::chdir":{"version":"0.1010","file":"lib/File/chdir.pm"}},"target":"File::chdir","version":"0.1010","name":"File::chdir","dist":"File-chdir-0.1010","pathname":"D/DA/DAGOLDEN/File-chdir-0.1010.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/File-chdir-0.1010/MYMETA.json 0000444 00000005424 14711220212 0017634 0 ustar 00 { "abstract" : "a more sensible way to change directories", "author" : [ "David Golden <dagolden@cpan.org>", "Michael G. Schwern <schwern@pobox.com>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.031, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "File-chdir", "no_index" : { "directory" : [ "t", "xt", "examples", "corpus" ], "package" : [ "DB" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Test::CPAN::Meta" : "0", "Test::More" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Spelling" : "0.12", "Test::Version" : "1" } }, "runtime" : { "requires" : { "Carp" : "0", "Cwd" : "3.16", "Exporter" : "0", "File::Spec::Functions" : "3.27", "perl" : "5.006", "strict" : "0", "vars" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "Test::More" : "0", "warnings" : "0" } } }, "provides" : { "File::chdir" : { "file" : "lib/File/chdir.pm", "version" : "0.1010" }, "File::chdir::ARRAY" : { "file" : "lib/File/chdir.pm", "version" : "0.1010" }, "File::chdir::SCALAR" : { "file" : "lib/File/chdir.pm", "version" : "0.1010" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/File-chdir/issues" }, "homepage" : "https://github.com/dagolden/File-chdir", "repository" : { "type" : "git", "url" : "https://github.com/dagolden/File-chdir.git", "web" : "https://github.com/dagolden/File-chdir" } }, "version" : "0.1010", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Joel Berger <joel.a.berger@gmail.com>" ] } perl5/x86_64-linux-thread-multi/.meta/Test-Simple-1.302186/install.json 0000444 00000013476 14711220213 0020700 0 ustar 00 {"provides":{"Test2::API::Breakage":{"version":1.302186,"file":"lib/Test2/API/Breakage.pm"},"Test2::Event::Pass":{"version":1.302186,"file":"lib/Test2/Event/Pass.pm"},"Test::Tester::Capture":{"version":1.302186,"file":"lib/Test/Tester/Capture.pm"},"Test2::API":{"version":1.302186,"file":"lib/Test2/API.pm"},"Test2::Event::TAP::Version":{"version":1.302186,"file":"lib/Test2/Event/TAP/Version.pm"},"Test2::API::InterceptResult::Hub":{"version":1.302186,"file":"lib/Test2/API/InterceptResult/Hub.pm"},"Test::Tester::CaptureRunner":{"version":1.302186,"file":"lib/Test/Tester/CaptureRunner.pm"},"Test::Builder::TodoDiag":{"version":1.302186,"file":"lib/Test/Builder/TodoDiag.pm"},"Test2::API::InterceptResult":{"version":1.302186,"file":"lib/Test2/API/InterceptResult.pm"},"Test2::IPC":{"version":1.302186,"file":"lib/Test2/IPC.pm"},"Test2::EventFacet::Error":{"version":1.302186,"file":"lib/Test2/EventFacet/Error.pm"},"Test2::Hub::Subtest":{"version":1.302186,"file":"lib/Test2/Hub/Subtest.pm"},"Test2::EventFacet::Trace":{"version":1.302186,"file":"lib/Test2/EventFacet/Trace.pm"},"Test2::Util":{"version":1.302186,"file":"lib/Test2/Util.pm"},"Test2::API::Stack":{"version":1.302186,"file":"lib/Test2/API/Stack.pm"},"Test2::API::InterceptResult::Squasher":{"version":1.302186,"file":"lib/Test2/API/InterceptResult/Squasher.pm"},"Test::Builder::Tester::Tie":{"version":1.302186,"file":"lib/Test/Builder/Tester.pm"},"Test2::Formatter::TAP":{"version":1.302186,"file":"lib/Test2/Formatter/TAP.pm"},"ok":{"version":1.302186,"file":"lib/ok.pm"},"Test2::Event::Diag":{"version":1.302186,"file":"lib/Test2/Event/Diag.pm"},"Test2::EventFacet::Parent":{"version":1.302186,"file":"lib/Test2/EventFacet/Parent.pm"},"Test2":{"version":1.302186,"file":"lib/Test2.pm"},"Test::Tester":{"version":1.302186,"file":"lib/Test/Tester.pm"},"Test2::Event::Waiting":{"version":1.302186,"file":"lib/Test2/Event/Waiting.pm"},"Test2::Event::Skip":{"version":1.302186,"file":"lib/Test2/Event/Skip.pm"},"Test2::EventFacet::Render":{"version":1.302186,"file":"lib/Test2/EventFacet/Render.pm"},"Test2::EventFacet::Info::Table":{"version":1.302186,"file":"lib/Test2/EventFacet/Info/Table.pm"},"Test2::EventFacet::About":{"version":1.302186,"file":"lib/Test2/EventFacet/About.pm"},"Test2::Formatter":{"version":1.302186,"file":"lib/Test2/Formatter.pm"},"Test2::Tools::Tiny":{"version":1.302186,"file":"lib/Test2/Tools/Tiny.pm"},"Test2::Util::ExternalMeta":{"version":1.302186,"file":"lib/Test2/Util/ExternalMeta.pm"},"Test2::Event::Plan":{"version":1.302186,"file":"lib/Test2/Event/Plan.pm"},"Test2::Hub::Interceptor":{"version":1.302186,"file":"lib/Test2/Hub/Interceptor.pm"},"Test2::EventFacet::Plan":{"version":1.302186,"file":"lib/Test2/EventFacet/Plan.pm"},"Test2::API::InterceptResult::Event":{"version":1.302186,"file":"lib/Test2/API/InterceptResult/Event.pm"},"Test::Builder::Tester::Color":{"version":1.302186,"file":"lib/Test/Builder/Tester/Color.pm"},"Test2::Util::Facets2Legacy":{"version":1.302186,"file":"lib/Test2/Util/Facets2Legacy.pm"},"Test2::Event::Generic":{"version":1.302186,"file":"lib/Test2/Event/Generic.pm"},"Test2::EventFacet::Amnesty":{"version":1.302186,"file":"lib/Test2/EventFacet/Amnesty.pm"},"Test2::IPC::Driver":{"version":1.302186,"file":"lib/Test2/IPC/Driver.pm"},"Test::Builder":{"version":1.302186,"file":"lib/Test/Builder.pm"},"Test::Builder::Formatter":{"version":1.302186,"file":"lib/Test/Builder/Formatter.pm"},"Test2::API::Context":{"version":1.302186,"file":"lib/Test2/API/Context.pm"},"Test2::Event":{"version":1.302186,"file":"lib/Test2/Event.pm"},"Test2::Event::Fail":{"version":1.302186,"file":"lib/Test2/Event/Fail.pm"},"Test2::EventFacet::Assert":{"version":1.302186,"file":"lib/Test2/EventFacet/Assert.pm"},"Test2::Hub":{"version":1.302186,"file":"lib/Test2/Hub.pm"},"Test2::EventFacet::Meta":{"version":1.302186,"file":"lib/Test2/EventFacet/Meta.pm"},"Test2::Event::Exception":{"version":1.302186,"file":"lib/Test2/Event/Exception.pm"},"Test2::EventFacet::Hub":{"version":1.302186,"file":"lib/Test2/EventFacet/Hub.pm"},"Test::More":{"version":1.302186,"file":"lib/Test/More.pm"},"Test2::API::Instance":{"version":1.302186,"file":"lib/Test2/API/Instance.pm"},"Test2::Hub::Interceptor::Terminator":{"version":1.302186,"file":"lib/Test2/Hub/Interceptor/Terminator.pm"},"Test2::API::InterceptResult::Facet":{"version":1.302186,"file":"lib/Test2/API/InterceptResult/Facet.pm"},"Test::use::ok":{"version":1.302186,"file":"lib/Test/use/ok.pm"},"Test::Simple":{"version":1.302186,"file":"lib/Test/Simple.pm"},"Test::Builder::Tester":{"version":1.302186,"file":"lib/Test/Builder/Tester.pm"},"Test2::Event::V2":{"version":1.302186,"file":"lib/Test2/Event/V2.pm"},"Test2::EventFacet::Control":{"version":1.302186,"file":"lib/Test2/EventFacet/Control.pm"},"Test::Builder::Module":{"version":1.302186,"file":"lib/Test/Builder/Module.pm"},"Test2::Util::HashBase":{"version":1.302186,"file":"lib/Test2/Util/HashBase.pm"},"Test::Builder::IO::Scalar":{"version":2.114,"file":"lib/Test/Builder/IO/Scalar.pm"},"Test2::IPC::Driver::Files":{"version":1.302186,"file":"lib/Test2/IPC/Driver/Files.pm"},"Test2::Event::Ok":{"version":1.302186,"file":"lib/Test2/Event/Ok.pm"},"Test2::EventFacet":{"version":1.302186,"file":"lib/Test2/EventFacet.pm"},"Test2::Util::Trace":{"version":1.302186,"file":"lib/Test2/Util/Trace.pm"},"Test2::EventFacet::Info":{"version":1.302186,"file":"lib/Test2/EventFacet/Info.pm"},"Test2::Event::Bail":{"version":1.302186,"file":"lib/Test2/Event/Bail.pm"},"Test2::Event::Encoding":{"version":1.302186,"file":"lib/Test2/Event/Encoding.pm"},"Test::Tester::Delegate":{"version":1.302186,"file":"lib/Test/Tester/Delegate.pm"},"Test2::Event::Note":{"version":1.302186,"file":"lib/Test2/Event/Note.pm"},"Test2::Event::Subtest":{"version":1.302186,"file":"lib/Test2/Event/Subtest.pm"}},"target":"Test2::API","version":1.302186,"name":"Test::Simple","dist":"Test-Simple-1.302186","pathname":"E/EX/EXODIST/Test-Simple-1.302186.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Test-Simple-1.302186/MYMETA.json 0000444 00000004752 14711220213 0020223 0 ustar 00 { "abstract" : "Basic utilities for writing tests.", "author" : [ "Chad Granum <exodist@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.015, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Simple", "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "IPC::Open3" : "0", "Term::Table" : "0.013", "Test::Pod" : "1.41", "Test::Spelling" : "0.12" } }, "runtime" : { "requires" : { "File::Spec" : "0", "File::Temp" : "0", "Scalar::Util" : "1.13", "Storable" : "0", "perl" : "5.006002", "utf8" : "0" }, "suggests" : { "Module::Pluggable" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/Test-More/test-more/issues" }, "repository" : { "type" : "git", "url" : "http://github.com/Test-More/test-more/" } }, "version" : "1.302186", "x_breaks" : { "Log::Dispatch::Config::TestLog" : "<= 0.02", "Net::BitTorrent" : "<= 0.052", "Test2::Harness" : "<= 0.000013", "Test2::Tools::EventDumper" : "<= 0.000007", "Test::Able" : "<= 0.11", "Test::Aggregate" : "<= 0.373", "Test::Alien" : "<= 0.04", "Test::Builder::Clutch" : "<= 0.07", "Test::Clustericious::Cluster" : "<= 0.30", "Test::Dist::VersionSync" : "<= v1.1.4", "Test::Exception" : "<= 0.42", "Test::Flatten" : "<= 0.11", "Test::Group" : "<= 0.20", "Test::Modern" : "<= 0.012", "Test::Moose" : "<= 2.1209", "Test::More::Prefix" : "<= 0.005", "Test::ParallelSubtest" : "<= 0.05", "Test::Pretty" : "<= 0.32", "Test::SharedFork" : "<= 0.34", "Test::UseAllModules" : ">= 0.12, <= 0.14", "Test::Wrapper" : "<= v0.3.0" }, "x_generated_by_perl" : "v5.32.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.25", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.010/install.json 0000444 00000010140 14711220213 0021450 0 ustar 00 {"provides":{"Template::Base":{"version":"3.010","file":"lib/Template/Base.pm"},"Template::Stash::Context":{"version":"3.010","file":"lib/Template/Stash/Context.pm"},"Template::Config":{"version":"3.010","file":"lib/Template/Config.pm"},"Template::Plugin::Date::Calc":{"version":"3.010","file":"lib/Template/Plugin/Date.pm"},"Template::View":{"version":"3.010","file":"lib/Template/View.pm"},"Template::Perl":{"version":"3.010","file":"lib/Template/Filters.pm"},"Template::Plugin::Procedural":{"version":"3.010","file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"version":"3.010","file":"lib/Template/Plugin/Table.pm"},"Template::Plugin::Filter":{"version":"3.010","file":"lib/Template/Plugin/Filter.pm"},"Template::Iterator":{"version":"3.010","file":"lib/Template/Iterator.pm"},"Template::Plugin::Pod":{"version":"3.010","file":"lib/Template/Plugin/Pod.pm"},"Template::Constants":{"version":"3.010","file":"lib/Template/Constants.pm"},"Template::VMethods":{"version":"3.010","file":"lib/Template/VMethods.pm"},"Template::Monad::Scalar":{"version":"3.010","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Datafile":{"version":"3.010","file":"lib/Template/Plugin/Datafile.pm"},"Template::Plugin::URL":{"version":"3.010","file":"lib/Template/Plugin/URL.pm"},"Template::Filters":{"version":"3.010","file":"lib/Template/Filters.pm"},"Template::Namespace::Constants":{"version":"3.010","file":"lib/Template/Namespace/Constants.pm"},"Template::Toolkit":{"version":"3.010","file":"lib/Template/Toolkit.pm"},"Template::Context":{"version":"3.010","file":"lib/Template/Context.pm"},"Template::Directive":{"version":"3.010","file":"lib/Template/Directive.pm"},"Template::Plugin":{"version":"3.010","file":"lib/Template/Plugin.pm"},"Template::TieString":{"version":"3.010","file":"lib/Template/Config.pm"},"Template::Plugin::Wrap":{"version":"3.010","file":"lib/Template/Plugin/Wrap.pm"},"Template::Parser":{"version":"3.010","file":"lib/Template/Parser.pm"},"Template::Grammar":{"version":"3.010","file":"lib/Template/Grammar.pm"},"Template::Plugin::HTML":{"version":"3.010","file":"lib/Template/Plugin/HTML.pm"},"Template::Plugin::Format":{"version":"3.010","file":"lib/Template/Plugin/Format.pm"},"Template::Plugin::Scalar":{"version":"3.010","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Directory":{"version":"3.010","file":"lib/Template/Plugin/Directory.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Dumper":{"version":"3.010","file":"lib/Template/Plugin/Dumper.pm"},"Template::Plugins":{"version":"3.010","file":"lib/Template/Plugins.pm"},"Template::Plugin::Assert":{"version":"3.010","file":"lib/Template/Plugin/Assert.pm"},"Template::Provider":{"version":"3.010","file":"lib/Template/Provider.pm"},"Template::Stash":{"version":"3.010","file":"lib/Template/Stash.pm"},"Template::Plugin::Image":{"version":"3.010","file":"lib/Template/Plugin/Image.pm"},"Template::Plugin::Date::Manip":{"version":"3.010","file":"lib/Template/Plugin/Date.pm"},"Template::Exception":{"version":"3.010","file":"lib/Template/Exception.pm"},"Template::Plugin::String":{"version":"3.010","file":"lib/Template/Plugin/String.pm"},"Template::Document":{"version":"3.010","file":"lib/Template/Document.pm"},"Template::Plugin::Math":{"version":"3.010","file":"lib/Template/Plugin/Math.pm"},"Template::Service":{"version":"3.010","file":"lib/Template/Service.pm"},"Template::Test":{"version":"3.010","file":"lib/Template/Test.pm"},"Template::Monad::Assert":{"version":"3.010","file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::Iterator":{"version":"3.010","file":"lib/Template/Plugin/Iterator.pm"},"Template":{"version":"3.010","file":"lib/Template.pm"},"Template::Plugin::CGI":{"version":"3.010","file":"lib/Template/Plugin/CGI.pm"},"Template::Plugin::Date":{"version":"3.010","file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::File":{"version":"3.010","file":"lib/Template/Plugin/File.pm"},"Template::Plugin::View":{"version":"3.010","file":"lib/Template/Plugin/View.pm"}},"target":"Template::Constants","version":"3.010","name":"Template","dist":"Template-Toolkit-3.010","pathname":"A/AT/ATOOMIC/Template-Toolkit-3.010.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.010/MYMETA.json 0000444 00000002660 14711220213 0021006 0 ustar 00 { "abstract" : "comprehensive template processing system", "author" : [ "Andy Wardley <abw@wardley.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Template-Toolkit", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "AppConfig" : "1.56", "File::Spec" : "0.8", "File::Temp" : "0.12", "Scalar::Util" : "0" } }, "test" : { "requires" : { "CGI" : "4.11", "Test::LeakTrace" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/abw/Template2/issues" }, "homepage" : "http://www.template-toolkit.org", "repository" : { "type" : "git", "url" : "https://github.com/abw/Template2.git", "web" : "https://github.com/abw/Template2" } }, "version" : "3.010" } perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.30/install.json 0000444 00000000303 14711220213 0017670 0 ustar 00 {"provides":{"Try::Tiny":{"version":"0.30","file":"lib/Try/Tiny.pm"}},"target":"Try::Tiny","version":"0.30","name":"Try::Tiny","dist":"Try-Tiny-0.30","pathname":"E/ET/ETHER/Try-Tiny-0.30.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Try-Tiny-0.30/MYMETA.json 0000444 00000134224 14711220213 0017230 0 ustar 00 { "abstract" : "Minimal try/catch with proper preservation of $@", "author" : [ "יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>", "Jesse Luehrs <doy@tozt.net>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "mit" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Try-Tiny", "no_index" : { "directory" : [ "t", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" }, "suggests" : { "JSON::PP" : "2.27300" } }, "develop" : { "recommends" : { "Dist::Zilla::PluginBundle::Author::ETHER" : "0.132" }, "requires" : { "Capture::Tiny" : "0.12", "Encode" : "0", "File::Spec" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Sub::Name" : "0.08", "Sub::Util" : "0", "Test::CPAN::Changes" : "0.19", "Test::CPAN::Meta" : "0", "Test::EOL" : "0", "Test::Kwalitee" : "1.21", "Test::MinimumVersion" : "0", "Test::Mojibake" : "0", "Test::More" : "0.96", "Test::NoTabs" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Pod::No404s" : "0", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12" }, "suggests" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::Authority" : "1.009", "Dist::Zilla::Plugin::AutoMetaResources" : "0", "Dist::Zilla::Plugin::AutoPrereqs" : "5.038", "Dist::Zilla::Plugin::Breaks" : "0", "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : "0.004", "Dist::Zilla::Plugin::CheckIssues" : "0", "Dist::Zilla::Plugin::CheckMetaResources" : "0", "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0.019", "Dist::Zilla::Plugin::CheckSelfDependency" : "0", "Dist::Zilla::Plugin::CheckStrictVersion" : "0", "Dist::Zilla::Plugin::ConfirmRelease" : "0", "Dist::Zilla::Plugin::CopyFilesFromRelease" : "0", "Dist::Zilla::Plugin::EnsureLatestPerl" : "0", "Dist::Zilla::Plugin::FileFinder::ByName" : "0", "Dist::Zilla::Plugin::FileFinder::Filter" : "0", "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : "0", "Dist::Zilla::Plugin::Git::Check" : "0", "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0.004", "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts" : "0", "Dist::Zilla::Plugin::Git::Commit" : "2.020", "Dist::Zilla::Plugin::Git::Contributors" : "0.029", "Dist::Zilla::Plugin::Git::Describe" : "0.004", "Dist::Zilla::Plugin::Git::GatherDir" : "2.016", "Dist::Zilla::Plugin::Git::Push" : "0", "Dist::Zilla::Plugin::Git::Remote::Check" : "0", "Dist::Zilla::Plugin::Git::Tag" : "0", "Dist::Zilla::Plugin::GitHub::Update" : "0.40", "Dist::Zilla::Plugin::GithubMeta" : "0.54", "Dist::Zilla::Plugin::InstallGuide" : "1.200005", "Dist::Zilla::Plugin::Keywords" : "0.004", "Dist::Zilla::Plugin::License" : "5.038", "Dist::Zilla::Plugin::MakeMaker" : "0", "Dist::Zilla::Plugin::Manifest" : "0", "Dist::Zilla::Plugin::MetaConfig" : "0", "Dist::Zilla::Plugin::MetaJSON" : "0", "Dist::Zilla::Plugin::MetaNoIndex" : "0", "Dist::Zilla::Plugin::MetaProvides::Package" : "1.15000002", "Dist::Zilla::Plugin::MetaTests" : "0", "Dist::Zilla::Plugin::MetaYAML" : "0", "Dist::Zilla::Plugin::MinimumPerl" : "1.006", "Dist::Zilla::Plugin::MojibakeTests" : "0.8", "Dist::Zilla::Plugin::NextRelease" : "5.033", "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0", "Dist::Zilla::Plugin::PodCoverageTests" : "5.040", "Dist::Zilla::Plugin::PodSyntaxTests" : "5.040", "Dist::Zilla::Plugin::PodWeaver" : "4.005", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0.006", "Dist::Zilla::Plugin::Prereqs::Soften" : "0", "Dist::Zilla::Plugin::PromptIfStale" : "0", "Dist::Zilla::Plugin::Readme" : "0", "Dist::Zilla::Plugin::ReadmeAnyFromPod" : "0.142180", "Dist::Zilla::Plugin::RewriteVersion::Transitional" : "0.004", "Dist::Zilla::Plugin::Run::AfterBuild" : "0.041", "Dist::Zilla::Plugin::Run::AfterRelease" : "0.038", "Dist::Zilla::Plugin::RunExtraTests" : "0.024", "Dist::Zilla::Plugin::StaticInstall" : "0.005", "Dist::Zilla::Plugin::Substitute" : "0", "Dist::Zilla::Plugin::Test::CPAN::Changes" : "0.012", "Dist::Zilla::Plugin::Test::ChangesHasContent" : "0", "Dist::Zilla::Plugin::Test::CheckBreaks" : "0.018", "Dist::Zilla::Plugin::Test::Compile" : "2.039", "Dist::Zilla::Plugin::Test::EOL" : "0.17", "Dist::Zilla::Plugin::Test::Kwalitee" : "2.10", "Dist::Zilla::Plugin::Test::MinimumVersion" : "2.000003", "Dist::Zilla::Plugin::Test::NoTabs" : "0.08", "Dist::Zilla::Plugin::Test::Pod::No404s" : "1.003", "Dist::Zilla::Plugin::Test::PodSpelling" : "2.006003", "Dist::Zilla::Plugin::Test::Portability" : "2.000007", "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0.022", "Dist::Zilla::Plugin::TestRelease" : "0", "Dist::Zilla::Plugin::UploadToCPAN" : "0", "Dist::Zilla::Plugin::UseUnsafeInc" : "0", "Dist::Zilla::PluginBundle::Author::ETHER" : "0.119", "Dist::Zilla::PluginBundle::Git::VersionManager" : "0", "Software::License::MIT" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "5.57", "constant" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" }, "suggests" : { "Sub::Name" : "0.08", "Sub::Util" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "Test::More" : "0", "if" : "0" }, "suggests" : { "CPAN::Meta::Check" : "0.011", "CPAN::Meta::Requirements" : "0", "Capture::Tiny" : "0.12" } } }, "provides" : { "Try::Tiny" : { "file" : "lib/Try/Tiny.pm", "version" : "0.30" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Try-Tiny@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Try-Tiny" }, "homepage" : "https://github.com/p5sagit/Try-Tiny", "repository" : { "type" : "git", "url" : "https://github.com/p5sagit/Try-Tiny.git", "web" : "https://github.com/p5sagit/Try-Tiny" } }, "version" : "0.30", "x_Dist_Zilla" : { "perl" : { "version" : "5.027006" }, "plugins" : [ { "class" : "Dist::Zilla::Plugin::FileFinder::Filter", "name" : "all_files_but_using_5.10_features", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::PromptIfStale", "config" : { "Dist::Zilla::Plugin::PromptIfStale" : { "check_all_plugins" : 0, "check_all_prereqs" : 0, "modules" : [ "Dist::Zilla::PluginBundle::Author::ETHER" ], "phase" : "build", "run_under_travis" : 0, "skip" : [] } }, "name" : "@Author::ETHER/stale modules, build", "version" : "0.054" }, { "class" : "Dist::Zilla::Plugin::PromptIfStale", "config" : { "Dist::Zilla::Plugin::PromptIfStale" : { "check_all_plugins" : 1, "check_all_prereqs" : 1, "modules" : [], "phase" : "release", "run_under_travis" : 0, "skip" : [] } }, "name" : "@Author::ETHER/stale modules, release", "version" : "0.054" }, { "class" : "Dist::Zilla::Plugin::FileFinder::ByName", "name" : "@Author::ETHER/Examples", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Git::GatherDir", "config" : { "Dist::Zilla::Plugin::GatherDir" : { "exclude_filename" : [ "CONTRIBUTING", "INSTALL", "LICENCE", "README.pod" ], "exclude_match" : [], "follow_symlinks" : 0, "include_dotfiles" : 0, "prefix" : "", "prune_directory" : [], "root" : "." }, "Dist::Zilla::Plugin::Git::GatherDir" : { "include_untracked" : 0 } }, "name" : "@Author::ETHER/Git::GatherDir", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "@Author::ETHER/MetaYAML", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "@Author::ETHER/MetaJSON", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Readme", "name" : "@Author::ETHER/Readme", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "@Author::ETHER/Manifest", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "@Author::ETHER/License", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::GenerateFile::FromShareDir", "config" : { "Dist::Zilla::Plugin::GenerateFile::FromShareDir" : { "destination_filename" : "CONTRIBUTING", "dist" : "Dist-Zilla-PluginBundle-Author-ETHER", "encoding" : "UTF-8", "has_xs" : 0, "location" : "build", "source_filename" : "CONTRIBUTING" }, "Dist::Zilla::Role::RepoFileInjector" : { "allow_overwrite" : 1, "repo_root" : ".", "version" : "0.007" } }, "name" : "@Author::ETHER/generate CONTRIBUTING", "version" : "0.013" }, { "class" : "Dist::Zilla::Plugin::InstallGuide", "name" : "@Author::ETHER/InstallGuide", "version" : "1.200007" }, { "class" : "Dist::Zilla::Plugin::Test::Compile", "config" : { "Dist::Zilla::Plugin::Test::Compile" : { "bail_out_on_fail" : 1, "fail_on_warning" : "author", "fake_home" : 0, "filename" : "xt/author/00-compile.t", "module_finder" : [ ":InstallModules" ], "needs_display" : 0, "phase" : "develop", "script_finder" : [ ":PerlExecFiles", "@Author::ETHER/Examples" ], "skips" : [], "switch" : [] } }, "name" : "@Author::ETHER/Test::Compile", "version" : "2.058" }, { "class" : "Dist::Zilla::Plugin::Test::NoTabs", "config" : { "Dist::Zilla::Plugin::Test::NoTabs" : { "filename" : "xt/author/no-tabs.t", "finder" : [ ":InstallModules", ":ExecFiles", "@Author::ETHER/Examples", ":TestFiles", ":ExtraTestFiles" ] } }, "name" : "@Author::ETHER/Test::NoTabs", "version" : "0.15" }, { "class" : "Dist::Zilla::Plugin::Test::EOL", "config" : { "Dist::Zilla::Plugin::Test::EOL" : { "filename" : "xt/author/eol.t", "finder" : [ ":ExecFiles", ":ExtraTestFiles", ":InstallModules", ":TestFiles", "@Author::ETHER/Examples" ], "trailing_whitespace" : 1 } }, "name" : "@Author::ETHER/Test::EOL", "version" : "0.19" }, { "class" : "Dist::Zilla::Plugin::MetaTests", "name" : "@Author::ETHER/MetaTests", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Test::CPAN::Changes", "config" : { "Dist::Zilla::Plugin::Test::CPAN::Changes" : { "changelog" : "Changes" } }, "name" : "@Author::ETHER/Test::CPAN::Changes", "version" : "0.012" }, { "class" : "Dist::Zilla::Plugin::Test::ChangesHasContent", "name" : "@Author::ETHER/Test::ChangesHasContent", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::Test::MinimumVersion", "name" : "@Author::ETHER/Test::MinimumVersion", "version" : "2.000007" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "@Author::ETHER/PodSyntaxTests", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::PodCoverageTests", "name" : "@Author::ETHER/PodCoverageTests", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Test::PodSpelling", "config" : { "Dist::Zilla::Plugin::Test::PodSpelling" : { "directories" : [ "examples", "lib", "script", "t", "xt" ], "spell_cmd" : "", "stopwords" : [ "irc" ], "wordlist" : "Pod::Wordlist" } }, "name" : "@Author::ETHER/Test::PodSpelling", "version" : "2.007005" }, { "class" : "Dist::Zilla::Plugin::Test::Pod::No404s", "name" : "@Author::ETHER/Test::Pod::No404s", "version" : "1.004" }, { "class" : "Dist::Zilla::Plugin::Test::Kwalitee", "config" : { "Dist::Zilla::Plugin::Test::Kwalitee" : { "filename" : "xt/author/kwalitee.t", "skiptest" : [] } }, "name" : "@Author::ETHER/Test::Kwalitee", "version" : "2.12" }, { "class" : "Dist::Zilla::Plugin::MojibakeTests", "name" : "@Author::ETHER/MojibakeTests", "version" : "0.8" }, { "class" : "Dist::Zilla::Plugin::Test::ReportPrereqs", "name" : "@Author::ETHER/Test::ReportPrereqs", "version" : "0.027" }, { "class" : "Dist::Zilla::Plugin::Test::Portability", "config" : { "Dist::Zilla::Plugin::Test::Portability" : { "options" : "" } }, "name" : "@Author::ETHER/Test::Portability", "version" : "2.001000" }, { "class" : "Dist::Zilla::Plugin::Git::Describe", "name" : "@Author::ETHER/Git::Describe", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::PodWeaver", "config" : { "Dist::Zilla::Plugin::PodWeaver" : { "config_plugins" : [ "@Author::ETHER" ], "finder" : [ ":InstallModules", ":ExecFiles" ], "plugins" : [ { "class" : "Pod::Weaver::Plugin::EnsurePod5", "name" : "@Author::ETHER/EnsurePod5", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::H1Nester", "name" : "@Author::ETHER/H1Nester", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::SingleEncoding", "name" : "@Author::ETHER/SingleEncoding", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::Transformer", "name" : "@Author::ETHER/List", "version" : "4.015" }, { "class" : "Pod::Weaver::Plugin::Transformer", "name" : "@Author::ETHER/Verbatim", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@Author::ETHER/header", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Name", "name" : "@Author::ETHER/Name", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Version", "name" : "@Author::ETHER/Version", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@Author::ETHER/prelude", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Generic", "name" : "SYNOPSIS", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Generic", "name" : "DESCRIPTION", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Generic", "name" : "OVERVIEW", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "ATTRIBUTES", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "METHODS", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "FUNCTIONS", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Collect", "name" : "TYPES", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Leftovers", "name" : "@Author::ETHER/Leftovers", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@Author::ETHER/postlude", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::GenerateSection", "name" : "@Author::ETHER/generate SUPPORT", "version" : "1.06" }, { "class" : "Pod::Weaver::Section::AllowOverride", "name" : "@Author::ETHER/allow override SUPPORT", "version" : "0.05" }, { "class" : "Pod::Weaver::Section::Authors", "name" : "@Author::ETHER/Authors", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Contributors", "name" : "@Author::ETHER/Contributors", "version" : "0.009" }, { "class" : "Pod::Weaver::Section::Legal", "name" : "@Author::ETHER/Legal", "version" : "4.015" }, { "class" : "Pod::Weaver::Section::Region", "name" : "@Author::ETHER/footer", "version" : "4.015" } ] } }, "name" : "@Author::ETHER/PodWeaver", "version" : "4.008" }, { "class" : "Dist::Zilla::Plugin::GithubMeta", "name" : "@Author::ETHER/GithubMeta", "version" : "0.54" }, { "class" : "Dist::Zilla::Plugin::AutoMetaResources", "name" : "@Author::ETHER/AutoMetaResources", "version" : "1.21" }, { "class" : "Dist::Zilla::Plugin::Authority", "name" : "@Author::ETHER/Authority", "version" : "1.009" }, { "class" : "Dist::Zilla::Plugin::MetaNoIndex", "name" : "@Author::ETHER/MetaNoIndex", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Package", "config" : { "Dist::Zilla::Plugin::MetaProvides::Package" : { "finder" : [ ":InstallModules" ], "finder_objects" : [ { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.010" } ], "include_underscores" : 0 }, "Dist::Zilla::Role::MetaProvider::Provider" : { "$Dist::Zilla::Role::MetaProvider::Provider::VERSION" : "2.002004", "inherit_missing" : 0, "inherit_version" : 0, "meta_noindex" : 1 }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000033", "version" : "0.004" } }, "name" : "@Author::ETHER/MetaProvides::Package", "version" : "2.004003" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "@Author::ETHER/MetaConfig", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Keywords", "config" : { "Dist::Zilla::Plugin::Keywords" : { "keywords" : [] } }, "name" : "@Author::ETHER/Keywords", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::UseUnsafeInc", "config" : { "Dist::Zilla::Plugin::UseUnsafeInc" : { "dot_in_INC" : 0 } }, "name" : "@Author::ETHER/UseUnsafeInc", "version" : "0.001" }, { "class" : "Dist::Zilla::Plugin::AutoPrereqs", "name" : "@Author::ETHER/AutoPrereqs", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Prereqs::AuthorDeps", "name" : "@Author::ETHER/Prereqs::AuthorDeps", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::MinimumPerl", "name" : "@Author::ETHER/MinimumPerl", "version" : "1.006" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "recommends" } }, "name" : "@Author::ETHER/pluginbundle_version", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::MakeMaker", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 9 } }, "name" : "@Author::ETHER/MakeMaker", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Git::Contributors", "config" : { "Dist::Zilla::Plugin::Git::Contributors" : { "git_version" : "2.14.2", "include_authors" : 0, "include_releaser" : 1, "order_by" : "commits", "paths" : [] } }, "name" : "@Author::ETHER/Git::Contributors", "version" : "0.032" }, { "class" : "Dist::Zilla::Plugin::StaticInstall", "config" : { "Dist::Zilla::Plugin::StaticInstall" : { "dry_run" : 1, "mode" : "auto" } }, "name" : "@Author::ETHER/StaticInstall", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::RunExtraTests", "config" : { "Dist::Zilla::Role::TestRunner" : { "default_jobs" : 9 } }, "name" : "@Author::ETHER/RunExtraTests", "version" : "0.029" }, { "class" : "Dist::Zilla::Plugin::CheckSelfDependency", "config" : { "Dist::Zilla::Plugin::CheckSelfDependency" : { "finder" : [ ":InstallModules" ] }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000033", "version" : "0.004" } }, "name" : "@Author::ETHER/CheckSelfDependency", "version" : "0.011" }, { "class" : "Dist::Zilla::Plugin::Run::AfterBuild", "config" : { "Dist::Zilla::Plugin::Run::Role::Runner" : { "fatal_errors" : 1, "quiet" : 1, "run" : [ "bash -c \"test -e .ackrc && grep -q -- '--ignore-dir=.latest' .ackrc || echo '--ignore-dir=.latest' >> .ackrc; if [[ `dirname '%d'` != .build ]]; then test -e .ackrc && grep -q -- '--ignore-dir=%d' .ackrc || echo '--ignore-dir=%d' >> .ackrc; fi\"" ], "version" : "0.046" } }, "name" : "@Author::ETHER/.ackrc", "version" : "0.046" }, { "class" : "Dist::Zilla::Plugin::Run::AfterBuild", "config" : { "Dist::Zilla::Plugin::Run::Role::Runner" : { "eval" : [ "if ('%d' =~ /^%n-[.[:xdigit:]]+$/) { unlink '.latest'; symlink '%d', '.latest'; }" ], "fatal_errors" : 0, "quiet" : 1, "version" : "0.046" } }, "name" : "@Author::ETHER/.latest", "version" : "0.046" }, { "class" : "Dist::Zilla::Plugin::CheckStrictVersion", "name" : "@Author::ETHER/CheckStrictVersion", "version" : "0.001" }, { "class" : "Dist::Zilla::Plugin::CheckMetaResources", "name" : "@Author::ETHER/CheckMetaResources", "version" : "0.001" }, { "class" : "Dist::Zilla::Plugin::EnsureLatestPerl", "config" : { "Dist::Zilla::Plugin::EnsureLatestPerl" : { "Module::CoreList" : "5.20171120" } }, "name" : "@Author::ETHER/EnsureLatestPerl", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "config" : { "Dist::Zilla::Plugin::Git::Check" : { "untracked_files" : "die" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." } }, "name" : "@Author::ETHER/initial check", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::Git::CheckFor::MergeConflicts", "config" : { "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." } }, "name" : "@Author::ETHER/Git::CheckFor::MergeConflicts", "version" : "0.014" }, { "class" : "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch", "config" : { "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." } }, "name" : "@Author::ETHER/Git::CheckFor::CorrectBranch", "version" : "0.014" }, { "class" : "Dist::Zilla::Plugin::Git::Remote::Check", "name" : "@Author::ETHER/Git::Remote::Check", "version" : "0.1.2" }, { "class" : "Dist::Zilla::Plugin::CheckPrereqsIndexed", "name" : "@Author::ETHER/CheckPrereqsIndexed", "version" : "0.020" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "@Author::ETHER/TestRelease", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Git::Check", "config" : { "Dist::Zilla::Plugin::Git::Check" : { "untracked_files" : "die" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." } }, "name" : "@Author::ETHER/after tests", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::CheckIssues", "name" : "@Author::ETHER/CheckIssues", "version" : "0.010" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "@Author::ETHER/UploadToCPAN", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease", "config" : { "Dist::Zilla::Plugin::CopyFilesFromRelease" : { "filename" : [ "CONTRIBUTING", "INSTALL", "LICENCE", "LICENSE", "ppport.h" ], "match" : [] } }, "name" : "@Author::ETHER/copy generated files", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::ReadmeAnyFromPod", "config" : { "Dist::Zilla::Role::FileWatcher" : { "version" : "0.006" } }, "name" : "@Author::ETHER/ReadmeAnyFromPod", "version" : "0.163250" }, { "class" : "Dist::Zilla::Plugin::RewriteVersion::Transitional", "config" : { "Dist::Zilla::Plugin::RewriteVersion" : { "add_tarball_name" : 0, "finders" : [ ":ExecFiles", ":InstallModules" ], "global" : 1, "skip_version_provider" : 0 }, "Dist::Zilla::Plugin::RewriteVersion::Transitional" : {} }, "name" : "@Author::ETHER/@Git::VersionManager/RewriteVersion::Transitional", "version" : "0.008" }, { "class" : "Dist::Zilla::Plugin::MetaProvides::Update", "name" : "@Author::ETHER/@Git::VersionManager/MetaProvides::Update", "version" : "0.003" }, { "class" : "Dist::Zilla::Plugin::CopyFilesFromRelease", "config" : { "Dist::Zilla::Plugin::CopyFilesFromRelease" : { "filename" : [ "Changes" ], "match" : [] } }, "name" : "@Author::ETHER/@Git::VersionManager/CopyFilesFromRelease", "version" : "0.007" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [ "." ], "commit_msg" : "%N-%v%t%n%n%c" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "CONTRIBUTING", "Changes", "INSTALL", "LICENCE", "README.pod" ], "allow_dirty_match" : [], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Author::ETHER/@Git::VersionManager/release snapshot", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::Git::Tag", "config" : { "Dist::Zilla::Plugin::Git::Tag" : { "branch" : null, "changelog" : "Changes", "signed" : 0, "tag" : "v0.30", "tag_format" : "v%v", "tag_message" : "v%v%t" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Author::ETHER/@Git::VersionManager/Git::Tag", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional", "config" : { "Dist::Zilla::Plugin::BumpVersionAfterRelease" : { "finders" : [ ":ExecFiles", ":InstallModules" ], "global" : 1, "munge_makefile_pl" : 1 }, "Dist::Zilla::Plugin::BumpVersionAfterRelease::Transitional" : {} }, "name" : "@Author::ETHER/@Git::VersionManager/BumpVersionAfterRelease::Transitional", "version" : "0.008" }, { "class" : "Dist::Zilla::Plugin::NextRelease", "name" : "@Author::ETHER/@Git::VersionManager/NextRelease", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Git::Commit", "config" : { "Dist::Zilla::Plugin::Git::Commit" : { "add_files_in" : [], "commit_msg" : "increment $VERSION after %v release" }, "Dist::Zilla::Role::Git::DirtyFiles" : { "allow_dirty" : [ "Build.PL", "Changes", "Makefile.PL" ], "allow_dirty_match" : [ "(?^:^lib/.*\\.pm$)" ], "changelog" : "Changes" }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." }, "Dist::Zilla::Role::Git::StringFormatter" : { "time_zone" : "local" } }, "name" : "@Author::ETHER/@Git::VersionManager/post-release commit", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "suggests" } }, "name" : "@Author::ETHER/@Git::VersionManager/prereqs for @Git::VersionManager", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Git::Push", "config" : { "Dist::Zilla::Plugin::Git::Push" : { "push_to" : [ "origin" ], "remotes_must_exist" : 1 }, "Dist::Zilla::Role::Git::Repo" : { "git_version" : "2.14.2", "repo_root" : "." } }, "name" : "@Author::ETHER/Git::Push", "version" : "2.043" }, { "class" : "Dist::Zilla::Plugin::GitHub::Update", "config" : { "Dist::Zilla::Plugin::GitHub::Update" : { "metacpan" : 1 } }, "name" : "@Author::ETHER/GitHub::Update", "version" : "0.44" }, { "class" : "Dist::Zilla::Plugin::Run::AfterRelease", "config" : { "Dist::Zilla::Plugin::Run::Role::Runner" : { "fatal_errors" : 0, "quiet" : 0, "run" : [ "REDACTED" ], "version" : "0.046" } }, "name" : "@Author::ETHER/install release", "version" : "0.046" }, { "class" : "Dist::Zilla::Plugin::Run::AfterRelease", "config" : { "Dist::Zilla::Plugin::Run::Role::Runner" : { "eval" : [ "print \"release complete!\\xa\"" ], "fatal_errors" : 1, "quiet" : 1, "version" : "0.046" } }, "name" : "@Author::ETHER/release complete", "version" : "0.046" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "@Author::ETHER/ConfirmRelease", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "develop", "type" : "suggests" } }, "name" : "@Author::ETHER/prereqs for @Author::ETHER", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::Substitute", "name" : "Substitute", "version" : "0.006" }, { "class" : "Dist::Zilla::Plugin::Prereqs::Soften", "config" : { "Dist::Zilla::Plugin::Prereqs::Soften" : { "copy_to" : [ "develop.requires" ], "modules" : [ "Capture::Tiny", "Sub::Name", "Sub::Util" ], "modules_from_features" : null, "to_relationship" : "suggests" } }, "name" : "Prereqs::Soften", "version" : "0.006003" }, { "class" : "Dist::Zilla::Plugin::OnlyCorePrereqs", "config" : { "Dist::Zilla::Plugin::OnlyCorePrereqs" : { "also_disallow" : [], "check_dual_life_versions" : "0", "deprecated_ok" : 0, "phases" : [ "configure", "build", "runtime", "test" ], "skips" : [], "starting_version" : "to be determined from perl prereq" } }, "name" : "OnlyCorePrereqs", "version" : "0.024" }, { "class" : "Dist::Zilla::Plugin::Breaks", "name" : "Breaks", "version" : "0.004" }, { "class" : "Dist::Zilla::Plugin::Test::CheckBreaks", "config" : { "Dist::Zilla::Plugin::Test::CheckBreaks" : { "conflicts_module" : [], "no_forced_deps" : 1 }, "Dist::Zilla::Role::ModuleMetadata" : { "Module::Metadata" : "1.000033", "version" : "0.004" } }, "name" : "Test::CheckBreaks", "version" : "0.019" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExtraTestFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":PerlExecFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":AllFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":NoFiles", "version" : "6.010" }, { "class" : "Dist::Zilla::Plugin::VerifyPhases", "name" : "@Author::ETHER/PHASE VERIFICATION", "version" : "0.016" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : 0 }, "version" : "6.010" } }, "x_authority" : "cpan:NUFFIN", "x_breaks" : { "Try::Tiny::Except" : "<= 0.01" }, "x_contributors" : [ "Karen Etheridge <ether@cpan.org>", "Peter Rabbitson <ribasushi@cpan.org>", "Ricardo Signes <rjbs@cpan.org>", "Mark Fowler <mark@twoshortplanks.com>", "Graham Knop <haarg@haarg.org>", "Lukas Mai <l.mai@web.de>", "Aristotle Pagaltzis <pagaltzis@gmx.de>", "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>", "Paul Howarth <paul@city-fan.org>", "Rudolf Leermakers <rudolf@hatsuseno.org>", "anaxagoras <walkeraj@gmail.com>", "awalker <awalker@sourcefire.com>", "chromatic <chromatic@wgz.org>", "Alex <alex@koban.(none)>", "cm-perl <cm-perl@users.noreply.github.com>", "Andrew Yates <ayates@haddock.local>", "David Lowe <davidl@lokku.com>", "Glenn Fowler <cebjyre@cpan.org>", "Hans Dieter Pearcey <hdp@weftsoar.net>", "Jens Berthold <jens@jebecs.de>", "Jonathan Yu <JAWNSY@cpan.org>", "Marc Mims <marc@questright.com>", "Mark Stosberg <mark@stosberg.com>", "Pali <pali@cpan.org>" ], "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239", "x_use_unsafe_inc" : 0 } perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Expat-0.51/install.json 0000444 00000000325 14711220215 0020352 0 ustar 00 {"provides":{"XML::SAX::Expat":{"version":0.51,"file":"Expat.pm"}},"target":"XML::SAX::Expat","version":0.51,"name":"XML::SAX::Expat","dist":"XML-SAX-Expat-0.51","pathname":"B/BJ/BJOERN/XML-SAX-Expat-0.51.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-SAX-Expat-0.51/MYMETA.json 0000444 00000002153 14711220216 0017702 0 ustar 00 { "abstract" : "SAX Driver for Expat", "author" : [ "Robin Berjon" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.132830, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-SAX-Expat", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "XML::NamespaceSupport" : "0.03", "XML::Parser" : "2.27", "XML::SAX" : "0.03", "XML::SAX::Base" : "1.00" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "https://github.com/hoehrmann/XML-SAX-Expat" } }, "version" : "0.51" } perl5/x86_64-linux-thread-multi/.meta/Canary-Stability-2013/install.json 0000444 00000000347 14711220216 0021370 0 ustar 00 {"provides":{"Canary::Stability":{"version":2013,"file":"Stability.pm"}},"target":"Canary::Stability","version":2013,"name":"Canary::Stability","dist":"Canary-Stability-2013","pathname":"M/ML/MLEHMANN/Canary-Stability-2013.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Canary-Stability-2013/MYMETA.json 0000444 00000001575 14711220217 0020723 0 ustar 00 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Canary-Stability", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : "2013", "x_serialization_backend" : "JSON::PP version 2.27300" } perl5/x86_64-linux-thread-multi/.meta/Capture-Tiny-0.48/install.json 0000444 00000000336 14711220217 0020540 0 ustar 00 {"provides":{"Capture::Tiny":{"version":"0.48","file":"lib/Capture/Tiny.pm"}},"target":"Capture::Tiny","version":"0.48","name":"Capture::Tiny","dist":"Capture-Tiny-0.48","pathname":"D/DA/DAGOLDEN/Capture-Tiny-0.48.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Capture-Tiny-0.48/MYMETA.json 0000444 00000006606 14711220217 0020074 0 ustar 00 { "abstract" : "Capture STDOUT and STDERR from Perl, XS or external programs", "author" : [ "David Golden <dagolden@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Capture-Tiny", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::OSPrereqs" : "0", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Apache_2_0" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1" } }, "runtime" : { "requires" : { "Carp" : "0", "Exporter" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "Scalar::Util" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "IO::File" : "0", "Test::More" : "0.62", "lib" : "0" } } }, "provides" : { "Capture::Tiny" : { "file" : "lib/Capture/Tiny.pm", "version" : "0.48" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/Capture-Tiny/issues" }, "homepage" : "https://github.com/dagolden/Capture-Tiny", "repository" : { "type" : "git", "url" : "https://github.com/dagolden/Capture-Tiny.git", "web" : "https://github.com/dagolden/Capture-Tiny" } }, "version" : "0.48", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>", "David E. Wheeler <david@justatheory.com>", "fecundf <not.com+github@gmail.com>", "Graham Knop <haarg@haarg.org>", "Peter Rabbitson <ribasushi@cpan.org>" ], "x_generated_by_perl" : "v5.26.1", "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239" } perl5/x86_64-linux-thread-multi/.meta/Devel-CheckLib-1.14/install.json 0000444 00000000343 14711220220 0020677 0 ustar 00 {"provides":{"Devel::CheckLib":{"version":1.14,"file":"lib/Devel/CheckLib.pm"}},"target":"Devel::CheckLib","version":1.14,"name":"Devel::CheckLib","dist":"Devel-CheckLib-1.14","pathname":"M/MA/MATTN/Devel-CheckLib-1.14.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Devel-CheckLib-1.14/MYMETA.json 0000444 00000002567 14711220220 0020237 0 ustar 00 { "abstract" : "check that a library is available", "author" : [ "David Cantrell", "David Golden", "Yasuhiro Matsumoto" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-CheckLib", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Exporter" : "0", "File::Spec" : "0", "File::Temp" : "0.16", "perl" : "5.004050" } }, "test" : { "requires" : { "Capture::Tiny" : "0", "Mock::Config" : "0.02", "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "repository" : { "url" : "http://github.com/mattn/p5-Devel-CheckLib" } }, "version" : "1.14", "x_serialization_backend" : "JSON::PP version 2.27400_02" } perl5/x86_64-linux-thread-multi/.meta/version-0.9929/install.json 0000444 00000000574 14711220220 0020060 0 ustar 00 {"provides":{"version::regex":{"version":0.9929,"file":"lib/version/regex.pm"},"version::vxs":{"version":0.9929,"file":"vutil/lib/version/vxs.pm"},"version":{"version":0.9929,"file":"lib/version.pm"},"version::vpp":{"version":0.9929,"file":"vperl/vpp.pm"}},"target":"version","version":0.9929,"name":"version","dist":"version-0.9929","pathname":"L/LE/LEONT/version-0.9929.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/version-0.9929/MYMETA.json 0000444 00000002761 14711220220 0017406 0 ustar 00 { "abstract" : "Structured version objects", "author" : [ "John Peacock <jpeacock@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "version", "no_index" : { "directory" : [ "t", "inc" ], "package" : [ "charstar" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.006002" } }, "test" : { "requires" : { "File::Temp" : "0.13", "Test::More" : "0.45", "base" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-version@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=version" }, "repository" : { "type" : "git", "url" : "git://github.com/Perl/version.pm.git", "web" : "https://github.com/Perl/version.pm" } }, "version" : "0.9929", "x_serialization_backend" : "JSON::PP version 4.04" } perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.140/install.json 0000444 00000000441 14711220221 0022345 0 ustar 00 {"provides":{"CPAN::Meta::Requirements":{"version":"2.140","file":"lib/CPAN/Meta/Requirements.pm"}},"target":"CPAN::Meta::Requirements","version":"2.140","name":"CPAN::Meta::Requirements","dist":"CPAN-Meta-Requirements-2.140","pathname":"D/DA/DAGOLDEN/CPAN-Meta-Requirements-2.140.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-Requirements-2.140/MYMETA.json 0000444 00000013457 14711220221 0021706 0 ustar 00 { "abstract" : "a set of version requirements for a CPAN dist", "author" : [ "David Golden <dagolden@cpan.org>", "Ricardo Signes <rjbs@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.042, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CPAN-Meta-Requirements", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17", "perl" : "5.006" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::Authority" : "0", "Dist::Zilla::Plugin::AutoPrereqs" : "0", "Dist::Zilla::Plugin::BumpVersionAfterRelease" : "0", "Dist::Zilla::Plugin::CPANFile" : "0", "Dist::Zilla::Plugin::CheckChangesHasContent" : "0", "Dist::Zilla::Plugin::CheckMetaResources" : "0", "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0", "Dist::Zilla::Plugin::ConfirmRelease" : "0", "Dist::Zilla::Plugin::CopyFilesFromBuild::Filtered" : "0", "Dist::Zilla::Plugin::ExecDir" : "0", "Dist::Zilla::Plugin::Git::Check" : "0", "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0", "Dist::Zilla::Plugin::Git::Commit" : "0", "Dist::Zilla::Plugin::Git::Contributors" : "0", "Dist::Zilla::Plugin::Git::GatherDir" : "0", "Dist::Zilla::Plugin::Git::Push" : "0", "Dist::Zilla::Plugin::Git::Tag" : "0", "Dist::Zilla::Plugin::GithubMeta" : "0", "Dist::Zilla::Plugin::InsertCopyright" : "0", "Dist::Zilla::Plugin::License" : "0", "Dist::Zilla::Plugin::MakeMaker" : "0", "Dist::Zilla::Plugin::MakeMaker::Highlander" : "0.003", "Dist::Zilla::Plugin::Manifest" : "0", "Dist::Zilla::Plugin::ManifestSkip" : "0", "Dist::Zilla::Plugin::MetaJSON" : "0", "Dist::Zilla::Plugin::MetaNoIndex" : "0", "Dist::Zilla::Plugin::MetaProvides::Package" : "0", "Dist::Zilla::Plugin::MetaTests" : "0", "Dist::Zilla::Plugin::MetaYAML" : "0", "Dist::Zilla::Plugin::MinimumPerl" : "0", "Dist::Zilla::Plugin::NextRelease" : "0", "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0.014", "Dist::Zilla::Plugin::Pod2Readme" : "0", "Dist::Zilla::Plugin::PodCoverageTests" : "0", "Dist::Zilla::Plugin::PodSyntaxTests" : "0", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0", "Dist::Zilla::Plugin::PromptIfStale" : "0", "Dist::Zilla::Plugin::PruneCruft" : "0", "Dist::Zilla::Plugin::RewriteVersion" : "0", "Dist::Zilla::Plugin::RunExtraTests" : "0", "Dist::Zilla::Plugin::ShareDir" : "0", "Dist::Zilla::Plugin::SurgicalPodWeaver" : "0", "Dist::Zilla::Plugin::Test::Compile" : "0", "Dist::Zilla::Plugin::Test::MinimumVersion" : "0", "Dist::Zilla::Plugin::Test::Perl::Critic" : "0", "Dist::Zilla::Plugin::Test::PodSpelling" : "0", "Dist::Zilla::Plugin::Test::Portability" : "0", "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0", "Dist::Zilla::Plugin::Test::Version" : "0", "Dist::Zilla::Plugin::TestRelease" : "0", "Dist::Zilla::Plugin::UploadToCPAN" : "0", "English" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Perl_5" : "0", "Test::CPAN::Meta" : "0", "Test::More" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Spelling" : "0.12", "Test::Version" : "1", "blib" : "1.01" } }, "runtime" : { "requires" : { "B" : "0", "Carp" : "0", "perl" : "5.006", "strict" : "0", "version" : "0.88", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "Test::More" : "0.88", "version" : "0.88" } } }, "provides" : { "CPAN::Meta::Requirements" : { "file" : "lib/CPAN/Meta/Requirements.pm", "version" : "2.140" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements/issues" }, "homepage" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements", "repository" : { "type" : "git", "url" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements.git", "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-Requirements" } }, "version" : "2.140", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Ed J <mohawk2@users.noreply.github.com>", "Karen Etheridge <ether@cpan.org>", "Leon Timmermans <fawaka@gmail.com>", "robario <webmaster@robario.com>" ] } perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.34/install.json 0000444 00000000555 14711220221 0017657 0 ustar 00 {"provides":{"YAML::Syck":{"version":1.34,"file":"lib/YAML/Syck.pm"},"YAML::Loader::Syck":{"file":"lib/YAML/Loader/Syck.pm"},"YAML::Dumper::Syck":{"file":"lib/YAML/Dumper/Syck.pm"},"JSON::Syck":{"version":1.34,"file":"lib/JSON/Syck.pm"}},"target":"YAML::Syck","version":1.34,"name":"YAML::Syck","dist":"YAML-Syck-1.34","pathname":"T/TO/TODDR/YAML-Syck-1.34.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/YAML-Syck-1.34/MYMETA.json 0000444 00000002414 14711220221 0017201 0 ustar 00 { "abstract" : "Fast, lightweight YAML loader and dumper", "author" : [ "Todd Rinaldo <toddr@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.44, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "mit" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "YAML-Syck", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "perl" : "5.006" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/toddr/YAML-Syck/issues" }, "homepage" : "http://github.com/toddr/YAML-Syck", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://github.com/toddr/YAML-Syck" } }, "version" : "1.34", "x_serialization_backend" : "JSON::PP version 4.04" } perl5/x86_64-linux-thread-multi/.meta/DBD-mysql-4.050/install.json 0000444 00000001020 14711220221 0020007 0 ustar 00 {"provides":{"DBD::mysql::db":{"version":"4.050","file":"lib/DBD/mysql.pm"},"DBD::mysql":{"version":"4.050","file":"lib/DBD/mysql.pm"},"DBD::mysql::GetInfo":{"file":"lib/DBD/mysql/GetInfo.pm"},"DBD::mysql::dr":{"version":"4.050","file":"lib/DBD/mysql.pm"},"DBD::mysql::st":{"version":"4.050","file":"lib/DBD/mysql.pm"},"Bundle::DBD::mysql":{"version":"4.050","file":"lib/Bundle/DBD/mysql.pm"}},"target":"DBD::mysql","version":"4.050","name":"DBD::mysql","dist":"DBD-mysql-4.050","pathname":"D/DV/DVEEDEN/DBD-mysql-4.050.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/DBD-mysql-4.050/MYMETA.json 0000444 00000011232 14711220221 0017343 0 ustar 00 { "abstract" : "A MySQL driver for the Perl5 Database Interface (DBI)", "author" : [ "Patrick Galbraith <patg@patg.net>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBD-mysql", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "DBI" : "1.609", "Data::Dumper" : "0", "Devel::CheckLib" : "1.09", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "DBI" : "1.609", "perl" : "5.008001" } }, "test" : { "recommends" : { "Proc::ProcessTable" : "0" }, "requires" : { "Test::Deep" : "0", "Test::Simple" : "0.90", "Time::HiRes" : "0", "bigint" : "0" }, "suggests" : { "Test::DistManifest" : "0", "Test::Pod" : "1.00" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/perl5-dbi/DBD-mysql/issues" }, "homepage" : "http://dbi.perl.org/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/perl5-dbi/DBD-mysql.git", "web" : "https://github.com/perl5-dbi/DBD-mysql" }, "x_IRC" : "irc://irc.perl.org/#dbi", "x_MailingList" : "mailto:dbi-dev@perl.org" }, "version" : "4.050", "x_contributors" : [ "Alceu Rodrigues de Freitas Junior <arfreitas@cpan.org>", "Alexandr Ciornii <alexchorny@gmail.com>", "Alexey Molchanov <alexey.molchanov@portaone.com>", "Amiri Barksdale at Home <amiri@roosterpirates.com>", "Andrew Miller <ikari7789@yahoo.com>", "Aran Deltac <bluefeet@gmail.com>", "Bernt M. Johnsen <bernt.johnsen@oracle.com>", "Chase Whitener <chase.whitener@infotechfl.com>", "Chip Salzenberg <chip@topsy.com>", "Chris Hammond <chrishammond@ymail.com>", "Chris Weyl <cweyl@alumni.drew.edu>", "Christian Walde <walde.christian@googlemail.com>", "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>", "Daisuke Murase <typester@cpan.org>", "Damyan Ivanov <dmn@debian.org>", "Dan Book <grinnz@gmail.com>", "Daniël van Eeden <daniel.vaneeden@booking.com>", "Dave Lambley <davel@isosceles.(none)>", "David Farrell <davidnmfarrell@gmail.com>", "David Steinbrunner <dsteinbrunner@pobox.com>", "Giovanni Bechis <giovanni@bigio.snb.it>", "Graham Ollis <plicease@cpan.org>", "H.Merijn Brand - Tux <h.m.brand@xs4all.nl>", "Hanno <hanno@gentoo.org>", "James McCoy <jamessan@jamessan.com>", "Jim Winstead <jimw@trainedmonkey.com>", "Juergen Weigert <jw@suse.com>", "Kenny Gryp <kenny.gryp@percona.com>", "Lu Shengliang <lushl9301@gmail.com>", "Masahiro Chiba <chiba@everqueue.com>", "Matthew Horsfall (alh) <WolfSage@gmail.com>", "Michiel Beijen <michiel.beijen@gmail.com>", "Mike Pomraning <mjp@pilcrow.madison.wi.us>", "Mohammad S Anwar <mohammad.anwar@yahoo.com>", "Pali <pali@cpan.org>", "Patrick Galbraith <patg@patg.net>", "Perlover <perlover@perlover.com>", "Peter Botha <peterb@striata.com>", "Petr Písař <ppisar@redhat.com>", "Reini Urban <rurban@cpanel.net>", "Rob Hoelz <rhoelz@inoc.com>", "Rob Van Dam <rvandam00@gmail.com>", "Rudy Lippan <rlippan@remotelinux.com>", "Scimon <simon.proctor@gmail.com>", "Sergey Zhuravlev <zhurs@ya.ru>", "Sergiy Borodych <Sergiy.Borodych@gmail.com>", "Sharif Nassar <mrwacky42+github@gmail.com>", "Steffen Mueller <smueller@cpan.org>", "Steven Hartland <steven.hartland@multiplay.co.uk>", "Taro Kobayashi <9re.3000@gmail.com>", "Tatsuhiko Miyagawa <miyagawa@bulknews.net>", "Tim Mullin <tim@cpanel.net>", "Ville Skyttä <ville.skytta@iki.fi>", "Vladimir Marek <vlmarek@volny.cz>", "katyavoid <katyavoid@gmail.com>", "kmx <kmx@cpan.org>", "tokuhirom <tokuhirom@gmail.com>", "zefram <zefram@fysh.org>", "zentooo <ankerasoy@gmail.com>" ], "x_serialization_backend" : "JSON::PP version 2.97001" } perl5/x86_64-linux-thread-multi/.meta/Path-Tiny-0.118/install.json 0000444 00000000422 14711220221 0020076 0 ustar 00 {"provides":{"Path::Tiny::Error":{"version":"0.118","file":"lib/Path/Tiny.pm"},"Path::Tiny":{"version":"0.118","file":"lib/Path/Tiny.pm"}},"target":"Path::Tiny","version":"0.118","name":"Path::Tiny","dist":"Path-Tiny-0.118","pathname":"D/DA/DAGOLDEN/Path-Tiny-0.118.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Path-Tiny-0.118/MYMETA.json 0000444 00000012654 14711220222 0017437 0 ustar 00 { "abstract" : "File path utility", "author" : [ "David Golden <dagolden@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.017, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "apache_2_0" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Path-Tiny", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB", "flock" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17" }, "suggests" : { "JSON::PP" : "2.27300" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::MinimumPerl" : "0", "Dist::Zilla::Plugin::OnlyCorePrereqs" : "0", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Apache_2_0" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1" } }, "runtime" : { "recommends" : { "Unicode::UTF8" : "0.58" }, "requires" : { "Carp" : "0", "Cwd" : "0", "Digest" : "1.03", "Digest::SHA" : "5.45", "Encode" : "0", "Exporter" : "5.57", "Fcntl" : "0", "File::Copy" : "0", "File::Glob" : "0", "File::Path" : "2.07", "File::Spec" : "0.86", "File::Temp" : "0.19", "File::stat" : "0", "constant" : "0", "overload" : "0", "perl" : "5.008001", "strict" : "0", "warnings" : "0", "warnings::register" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900", "Test::FailWarnings" : "0", "Test::MockRandom" : "0" }, "requires" : { "Digest::MD5" : "0", "ExtUtils::MakeMaker" : "0", "File::Basename" : "0", "File::Spec" : "0.86", "File::Spec::Functions" : "0", "File::Spec::Unix" : "0", "File::Temp" : "0.19", "Test::More" : "0.96", "lib" : "0", "open" : "0" } } }, "provides" : { "Path::Tiny" : { "file" : "lib/Path/Tiny.pm", "version" : "0.118" }, "Path::Tiny::Error" : { "file" : "lib/Path/Tiny.pm", "version" : "0.118" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dagolden/Path-Tiny/issues" }, "homepage" : "https://github.com/dagolden/Path-Tiny", "repository" : { "type" : "git", "url" : "https://github.com/dagolden/Path-Tiny.git", "web" : "https://github.com/dagolden/Path-Tiny" } }, "version" : "0.118", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Alex Efros <powerman@powerman.name>", "Aristotle Pagaltzis <pagaltzis@gmx.de>", "Chris Williams <bingos@cpan.org>", "Dan Book <grinnz@grinnz.com>", "Dave Rolsky <autarch@urth.org>", "David Steinbrunner <dsteinbrunner@pobox.com>", "Doug Bell <madcityzen@gmail.com>", "Gabor Szabo <szabgab@cpan.org>", "Gabriel Andrade <gabiruh@gmail.com>", "George Hartzell <hartzell@cpan.org>", "Geraud Continsouzas <geraud@scsi.nc>", "Goro Fuji <gfuji@cpan.org>", "Graham Knop <haarg@haarg.org>", "Graham Ollis <plicease@cpan.org>", "Ian Sillitoe <ian@sillit.com>", "James Hunt <james@niftylogic.com>", "John Karr <brainbuz@brainbuz.org>", "Karen Etheridge <ether@cpan.org>", "Mark Ellis <mark.ellis@cartridgesave.co.uk>", "Martin H. Sluka <fany@cpan.org>", "Martin Kjeldsen <mk@bluepipe.dk>", "Michael G. Schwern <mschwern@cpan.org>", "Nigel Gregoire <nigelgregoire@gmail.com>", "Philippe Bruhat (BooK) <book@cpan.org>", "regina-verbae <regina-verbae@users.noreply.github.com>", "Roy Ivy III <rivy@cpan.org>", "Shlomi Fish <shlomif@shlomifish.org>", "Smylers <Smylers@stripey.com>", "Tatsuhiko Miyagawa <miyagawa@bulknews.net>", "Toby Inkster <tobyink@cpan.org>", "Yanick Champoux <yanick@babyl.dyndns.org>", "김도형 - Keedi Kim <keedi@cpan.org>" ], "x_generated_by_perl" : "v5.32.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.24", "x_spdx_expression" : "Apache-2.0" } perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0207/install.json 0000444 00000005143 14711220222 0020075 0 ustar 00 {"provides":{"XML::LibXML::PI":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0207,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0207,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0207,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0207,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0207,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0207,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0207,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0207,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0207,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0207,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0207,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0207,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0207,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0207,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0207,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0207,"name":"XML::LibXML","dist":"XML-LibXML-2.0207","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0207.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0207/MYMETA.json 0000444 00000004733 14711220223 0017430 0 ustar 00 { "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library", "author" : [ "Petr Pajas <PAJAS@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.60, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "keywords" : [ "dom", "html", "libxml", "object oriented", "oop", "parse", "parser", "parsing", "pullparser", "sax", "sgml", "xml", "xpath", "XPath", "xs" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-LibXML", "no_index" : { "directory" : [ "t", "inc", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Alien::Base::Wrapper" : "0", "Alien::Libxml2" : "0.14", "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "DynaLoader" : "0", "Encode" : "0", "Exporter" : "5.57", "IO::Handle" : "0", "Scalar::Util" : "0", "Tie::Hash" : "0", "XML::NamespaceSupport" : "1.07", "XML::SAX" : "0.11", "XML::SAX::Base" : "0", "XML::SAX::DocumentLocator" : "0", "XML::SAX::Exception" : "0", "base" : "0", "constant" : "0", "overload" : "0", "parent" : "0", "perl" : "5.008001", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Config" : "0", "Errno" : "0", "IO::File" : "0", "IO::Handle" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Test::More" : "0", "locale" : "0", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/shlomif/perl-XML-LibXML.git", "web" : "https://github.com/shlomif/perl-XML-LibXML" } }, "version" : "2.0207", "x_serialization_backend" : "JSON::PP version 4.06" } perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.100/install.json 0000444 00000010016 14711220224 0021454 0 ustar 00 {"provides":{"Template::Base":{"version":"3.100","file":"lib/Template/Base.pm"},"Template::Stash::Context":{"version":"3.100","file":"lib/Template/Stash/Context.pm"},"Template::Config":{"version":"3.100","file":"lib/Template/Config.pm"},"Template::Plugin::Date::Calc":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::View":{"version":"3.100","file":"lib/Template/View.pm"},"Template::Perl":{"version":"3.100","file":"lib/Template/Filters.pm"},"Template::Plugin::Procedural":{"version":"3.100","file":"lib/Template/Plugin/Procedural.pm"},"Template::Plugin::Table":{"version":"3.100","file":"lib/Template/Plugin/Table.pm"},"Template::Plugin::Filter":{"version":"3.100","file":"lib/Template/Plugin/Filter.pm"},"Template::Iterator":{"version":"3.100","file":"lib/Template/Iterator.pm"},"Template::Plugin::Pod":{"version":"3.100","file":"lib/Template/Plugin/Pod.pm"},"Template::Constants":{"version":"3.100","file":"lib/Template/Constants.pm"},"Template::VMethods":{"version":"3.100","file":"lib/Template/VMethods.pm"},"Template::Monad::Scalar":{"version":"3.100","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Datafile":{"version":"3.100","file":"lib/Template/Plugin/Datafile.pm"},"Template::Plugin::URL":{"version":"3.100","file":"lib/Template/Plugin/URL.pm"},"Template::Filters":{"version":"3.100","file":"lib/Template/Filters.pm"},"Template::Namespace::Constants":{"version":"3.100","file":"lib/Template/Namespace/Constants.pm"},"Template::Toolkit":{"version":"3.100","file":"lib/Template/Toolkit.pm"},"Template::Context":{"version":"3.100","file":"lib/Template/Context.pm"},"Template::Directive":{"version":"3.100","file":"lib/Template/Directive.pm"},"Template::Plugin":{"version":"3.100","file":"lib/Template/Plugin.pm"},"Template::TieString":{"version":"3.100","file":"lib/Template/Config.pm"},"Template::Plugin::Wrap":{"version":"3.100","file":"lib/Template/Plugin/Wrap.pm"},"Template::Parser":{"version":"3.100","file":"lib/Template/Parser.pm"},"Template::Grammar":{"version":"3.100","file":"lib/Template/Grammar.pm"},"Template::Plugin::HTML":{"version":"3.100","file":"lib/Template/Plugin/HTML.pm"},"Template::Plugin::Format":{"version":"3.100","file":"lib/Template/Plugin/Format.pm"},"Template::Plugin::Scalar":{"version":"3.100","file":"lib/Template/Plugin/Scalar.pm"},"Template::Plugin::Directory":{"version":"3.100","file":"lib/Template/Plugin/Directory.pm"},"Template::Stash::XS":{"file":"lib/Template/Stash/XS.pm"},"Template::Plugin::Dumper":{"version":"3.100","file":"lib/Template/Plugin/Dumper.pm"},"Template::Plugins":{"version":"3.100","file":"lib/Template/Plugins.pm"},"Template::Plugin::Assert":{"version":"3.100","file":"lib/Template/Plugin/Assert.pm"},"Template::Provider":{"version":"3.100","file":"lib/Template/Provider.pm"},"Template::Stash":{"version":"3.100","file":"lib/Template/Stash.pm"},"Template::Plugin::Image":{"version":"3.100","file":"lib/Template/Plugin/Image.pm"},"Template::Plugin::Date::Manip":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::Exception":{"version":"3.100","file":"lib/Template/Exception.pm"},"Template::Plugin::String":{"version":"3.100","file":"lib/Template/Plugin/String.pm"},"Template::Document":{"version":"3.100","file":"lib/Template/Document.pm"},"Template::Plugin::Math":{"version":"3.100","file":"lib/Template/Plugin/Math.pm"},"Template::Service":{"version":"3.100","file":"lib/Template/Service.pm"},"Template::Test":{"version":"3.100","file":"lib/Template/Test.pm"},"Template::Monad::Assert":{"version":"3.100","file":"lib/Template/Plugin/Assert.pm"},"Template::Plugin::Iterator":{"version":"3.100","file":"lib/Template/Plugin/Iterator.pm"},"Template":{"version":"3.100","file":"lib/Template.pm"},"Template::Plugin::Date":{"version":"3.100","file":"lib/Template/Plugin/Date.pm"},"Template::Plugin::File":{"version":"3.100","file":"lib/Template/Plugin/File.pm"},"Template::Plugin::View":{"version":"3.100","file":"lib/Template/Plugin/View.pm"}},"target":"Template::Constants","version":"3.100","name":"Template","dist":"Template-Toolkit-3.100","pathname":"T/TO/TODDR/Template-Toolkit-3.100.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/Template-Toolkit-3.100/MYMETA.json 0000444 00000002624 14711220224 0021010 0 ustar 00 { "abstract" : "comprehensive template processing system", "author" : [ "Andy Wardley <abw@wardley.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Template-Toolkit", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "AppConfig" : "1.56", "File::Spec" : "0.8", "File::Temp" : "0.12", "Scalar::Util" : "0" } }, "test" : { "requires" : { "Test::LeakTrace" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/abw/Template2/issues" }, "homepage" : "http://www.template-toolkit.org", "repository" : { "type" : "git", "url" : "https://github.com/abw/Template2.git", "web" : "https://github.com/abw/Template2" } }, "version" : "3.100" } perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000024/install.json 0000444 00000000407 14711220224 0020343 0 ustar 00 {"provides":{"lib::core::only":{"file":"lib/lib/core/only.pm"},"local::lib":{"version":2.000024,"file":"lib/local/lib.pm"}},"target":"local::lib","version":2.000024,"name":"local::lib","dist":"local-lib-2.000024","pathname":"H/HA/HAARG/local-lib-2.000024.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/local-lib-2.000024/MYMETA.json 0000444 00000003512 14711220225 0017672 0 ustar 00 { "abstract" : "create and use a local lib/ for perl modules with PERL5LIB", "author" : [ "mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "local-lib", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : {} }, "develop" : { "requires" : { "Capture::Tiny" : "0", "Module::Build" : "0.36", "Test::CPAN::Changes" : "0", "Test::EOL" : "0", "Test::More" : "0.8101", "Test::NoTabs" : "0", "Test::Pod" : "0" } }, "runtime" : { "requires" : { "ExtUtils::MakeMaker" : "7.00", "perl" : "5.006" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-local-lib@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=local-lib" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/Perl-Toolchain-Gang/local-lib", "web" : "https://github.com/Perl-Toolchain-Gang/local-lib" }, "x_IRC" : "irc://irc.perl.org/#local-lib" }, "version" : "2.000024", "x_serialization_backend" : "JSON::PP version 2.94" } perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0208/install.json 0000444 00000005143 14711220225 0020101 0 ustar 00 {"provides":{"XML::LibXML::PI":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Pattern":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::SAX":{"version":2.0208,"file":"lib/XML/LibXML/SAX.pm"},"XML::LibXML::XPathContext":{"version":2.0208,"file":"lib/XML/LibXML/XPathContext.pm"},"XML::LibXML::SAX::AttributeNode":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::SAX::Generator":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Generator.pm"},"XML::LibXML::XPathExpression":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::NodeList":{"version":2.0208,"file":"lib/XML/LibXML/NodeList.pm"},"XML::LibXML::Error":{"version":2.0208,"file":"lib/XML/LibXML/Error.pm"},"XML::LibXML::RegExp":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::_SAXParser":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::InputCallback":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Devel":{"version":2.0208,"file":"lib/XML/LibXML/Devel.pm"},"XML::LibXML::Boolean":{"version":2.0208,"file":"lib/XML/LibXML/Boolean.pm"},"XML::LibXML::AttributeHash":{"version":2.0208,"file":"lib/XML/LibXML/AttributeHash.pm"},"XML::LibXML":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Literal":{"version":2.0208,"file":"lib/XML/LibXML/Literal.pm"},"XML::LibXML::Reader":{"version":2.0208,"file":"lib/XML/LibXML/Reader.pm"},"XML::LibXML::SAX::Builder":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Builder.pm"},"XML::LibXML::Schema":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Element":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Attr":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Node":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::CDATASection":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Number":{"version":2.0208,"file":"lib/XML/LibXML/Number.pm"},"XML::LibXML::Namespace":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::ErrNo":{"version":2.0208,"file":"lib/XML/LibXML/ErrNo.pm"},"XML::LibXML::SAX::Parser":{"version":2.0208,"file":"lib/XML/LibXML/SAX/Parser.pm"},"XML::LibXML::Dtd":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::NamedNodeMap":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Common":{"version":2.0208,"file":"lib/XML/LibXML/Common.pm"},"XML::LibXML::Comment":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Document":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::DocumentFragment":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::RelaxNG":{"version":2.0208,"file":"LibXML.pm"},"XML::LibXML::Text":{"version":2.0208,"file":"LibXML.pm"}},"target":"XML::LibXML","version":2.0208,"name":"XML::LibXML","dist":"XML-LibXML-2.0208","pathname":"S/SH/SHLOMIF/XML-LibXML-2.0208.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-LibXML-2.0208/MYMETA.json 0000444 00000004733 14711220225 0017433 0 ustar 00 { "abstract" : "Interface to Gnome libxml2 xml parsing and DOM library", "author" : [ "Petr Pajas <PAJAS@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "keywords" : [ "dom", "html", "libxml", "object oriented", "oop", "parse", "parser", "parsing", "pullparser", "sax", "sgml", "xml", "xpath", "XPath", "xs" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-LibXML", "no_index" : { "directory" : [ "t", "inc", "xt" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Alien::Base::Wrapper" : "0", "Alien::Libxml2" : "0.14", "Config" : "0", "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "0", "DynaLoader" : "0", "Encode" : "0", "Exporter" : "5.57", "IO::Handle" : "0", "Scalar::Util" : "0", "Tie::Hash" : "0", "XML::NamespaceSupport" : "1.07", "XML::SAX" : "0.11", "XML::SAX::Base" : "0", "XML::SAX::DocumentLocator" : "0", "XML::SAX::Exception" : "0", "base" : "0", "constant" : "0", "overload" : "0", "parent" : "0", "perl" : "5.008001", "strict" : "0", "vars" : "0", "warnings" : "0" } }, "test" : { "requires" : { "Config" : "0", "Errno" : "0", "IO::File" : "0", "IO::Handle" : "0", "POSIX" : "0", "Scalar::Util" : "0", "Test::More" : "0", "locale" : "0", "utf8" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "https://github.com/shlomif/perl-XML-LibXML.git", "web" : "https://github.com/shlomif/perl-XML-LibXML" } }, "version" : "2.0208", "x_serialization_backend" : "JSON::PP version 4.06" } perl5/x86_64-linux-thread-multi/.meta/JSON-XS-4.03/install.json 0000444 00000000263 14711220225 0017306 0 ustar 00 {"provides":{"JSON::XS":{"version":4.03,"file":"XS.pm"}},"target":"JSON::XS","version":4.03,"name":"JSON::XS","dist":"JSON-XS-4.03","pathname":"M/ML/MLEHMANN/JSON-XS-4.03.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/JSON-XS-4.03/MYMETA.json 0000444 00000001666 14711220225 0016644 0 ustar 00 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.120921", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "JSON-XS", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "Canary::Stability" : "0", "ExtUtils::MakeMaker" : "6.52" } }, "runtime" : { "requires" : { "Types::Serialiser" : "0", "common::sense" : "0" } } }, "release_status" : "stable", "version" : "4.03" } perl5/x86_64-linux-thread-multi/.meta/ExtUtils-ParseXS-3.35/install.json 0000444 00000001772 14711220225 0021323 0 ustar 00 {"provides":{"ExtUtils::ParseXS::CountLines":{"version":3.35,"file":"lib/ExtUtils/ParseXS/CountLines.pm"},"ExtUtils::Typemaps":{"version":3.35,"file":"lib/ExtUtils/Typemaps.pm"},"ExtUtils::ParseXS":{"version":3.35,"file":"lib/ExtUtils/ParseXS.pm"},"ExtUtils::Typemaps::InputMap":{"version":3.35,"file":"lib/ExtUtils/Typemaps/InputMap.pm"},"ExtUtils::Typemaps::Cmd":{"version":3.35,"file":"lib/ExtUtils/Typemaps/Cmd.pm"},"ExtUtils::Typemaps::Type":{"version":3.35,"file":"lib/ExtUtils/Typemaps/Type.pm"},"ExtUtils::Typemaps::OutputMap":{"version":3.35,"file":"lib/ExtUtils/Typemaps/OutputMap.pm"},"ExtUtils::ParseXS::Constants":{"version":3.35,"file":"lib/ExtUtils/ParseXS/Constants.pm"},"ExtUtils::ParseXS::Eval":{"version":3.35,"file":"lib/ExtUtils/ParseXS/Eval.pm"},"ExtUtils::ParseXS::Utilities":{"version":3.35,"file":"lib/ExtUtils/ParseXS/Utilities.pm"}},"target":"ExtUtils::ParseXS","version":3.35,"name":"ExtUtils::ParseXS","dist":"ExtUtils-ParseXS-3.35","pathname":"S/SM/SMUELLER/ExtUtils-ParseXS-3.35.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/ExtUtils-ParseXS-3.35/MYMETA.json 0000444 00000002742 14711220225 0020647 0 ustar 00 { "abstract" : "converts Perl XS code into C code", "author" : [ "Ken Williams <ken@mathforum.org>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "ExtUtils-ParseXS", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.46" } }, "runtime" : { "requires" : { "Carp" : "0", "Cwd" : "0", "DynaLoader" : "0", "Exporter" : "5.57", "ExtUtils::CBuilder" : "0", "ExtUtils::MakeMaker" : "6.46", "File::Basename" : "0", "File::Spec" : "0", "Symbol" : "0", "Test::More" : "0.47" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.perl.org/rt3/" }, "repository" : { "type" : "git", "url" : "git://perl5.git.perl.org/gitroot/perl.git" } }, "version" : "3.35", "x_serialization_backend" : "JSON::PP version 2.27300" } perl5/x86_64-linux-thread-multi/.meta/XML-SAX-1.02/install.json 0000444 00000001714 14711220225 0017274 0 ustar 00 {"provides":{"XML::SAX::ParserFactory":{"version":1.02,"file":"lib/XML/SAX/ParserFactory.pm"},"XML::SAX":{"version":1.02,"file":"lib/XML/SAX.pm"},"XML::SAX::PurePerl::Reader::String":{"file":"lib/XML/SAX/PurePerl/Reader/String.pm"},"XML::SAX::PurePerl::Reader":{"file":"lib/XML/SAX/PurePerl/Reader.pm"},"XML::SAX::PurePerl::Reader::URI":{"file":"lib/XML/SAX/PurePerl/Reader/URI.pm"},"XML::SAX::PurePerl::DebugHandler":{"file":"lib/XML/SAX/PurePerl/DebugHandler.pm"},"XML::SAX::PurePerl::Productions":{"file":"lib/XML/SAX/PurePerl/Productions.pm"},"XML::SAX::PurePerl::Reader::Stream":{"file":"lib/XML/SAX/PurePerl/Reader/Stream.pm"},"XML::SAX::DocumentLocator":{"file":"lib/XML/SAX/DocumentLocator.pm"},"XML::SAX::PurePerl":{"version":1.02,"file":"lib/XML/SAX/PurePerl.pm"},"XML::SAX::PurePerl::Exception":{"file":"lib/XML/SAX/PurePerl/Exception.pm"}},"target":"XML::SAX","version":1.02,"name":"XML::SAX","dist":"XML-SAX-1.02","pathname":"G/GR/GRANTM/XML-SAX-1.02.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-SAX-1.02/MYMETA.json 0000444 00000002172 14711220225 0016621 0 ustar 00 { "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-SAX", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "File::Temp" : "0", "XML::NamespaceSupport" : "0.03", "XML::SAX::Base" : "1.05" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "web" : "https://github.com/grantm/xml-sax" } }, "version" : "1.02", "x_serialization_backend" : "JSON::PP version 2.27300" } perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-YAML-0.018/install.json 0000444 00000000361 14711220225 0020433 0 ustar 00 {"provides":{"CPAN::Meta::YAML":{"version":"0.018","file":"lib/CPAN/Meta/YAML.pm"}},"target":"CPAN::Meta::YAML","version":"0.018","name":"CPAN::Meta::YAML","dist":"CPAN-Meta-YAML-0.018","pathname":"D/DA/DAGOLDEN/CPAN-Meta-YAML-0.018.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/CPAN-Meta-YAML-0.018/MYMETA.json 0000444 00000012652 14711220225 0017767 0 ustar 00 { "abstract" : "Read and write a subset of YAML for CPAN Meta files", "author" : [ "Adam Kennedy <adamk@cpan.org>", "David Golden <dagolden@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.042, CPAN::Meta::Converter version 2.150001, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "CPAN-Meta-YAML", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17", "perl" : "5.008001" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::AppendExternalData" : "0", "Dist::Zilla::Plugin::Authority" : "0", "Dist::Zilla::Plugin::AutoPrereqs" : "0", "Dist::Zilla::Plugin::CheckChangesHasContent" : "0", "Dist::Zilla::Plugin::CheckMetaResources" : "0", "Dist::Zilla::Plugin::CheckPrereqsIndexed" : "0", "Dist::Zilla::Plugin::ConfirmRelease" : "0", "Dist::Zilla::Plugin::Doppelgaenger" : "0.007", "Dist::Zilla::Plugin::Encoding" : "0", "Dist::Zilla::Plugin::ExecDir" : "0", "Dist::Zilla::Plugin::Git::Check" : "0", "Dist::Zilla::Plugin::Git::CheckFor::CorrectBranch" : "0", "Dist::Zilla::Plugin::Git::Commit" : "0", "Dist::Zilla::Plugin::Git::Contributors" : "0", "Dist::Zilla::Plugin::Git::GatherDir" : "0", "Dist::Zilla::Plugin::Git::NextVersion" : "0", "Dist::Zilla::Plugin::Git::Push" : "0", "Dist::Zilla::Plugin::Git::Tag" : "0", "Dist::Zilla::Plugin::GithubMeta" : "0", "Dist::Zilla::Plugin::License" : "0", "Dist::Zilla::Plugin::MakeMaker" : "0", "Dist::Zilla::Plugin::MakeMaker::Highlander" : "0.003", "Dist::Zilla::Plugin::Manifest" : "0", "Dist::Zilla::Plugin::ManifestSkip" : "0", "Dist::Zilla::Plugin::MetaJSON" : "0", "Dist::Zilla::Plugin::MetaNoIndex" : "0", "Dist::Zilla::Plugin::MetaProvides::Package" : "0", "Dist::Zilla::Plugin::MetaResources" : "0", "Dist::Zilla::Plugin::MetaTests" : "0", "Dist::Zilla::Plugin::MetaYAML" : "0", "Dist::Zilla::Plugin::MinimumPerl" : "0", "Dist::Zilla::Plugin::NextRelease" : "0", "Dist::Zilla::Plugin::PkgVersion" : "0", "Dist::Zilla::Plugin::Pod2Readme" : "0", "Dist::Zilla::Plugin::PodSyntaxTests" : "0", "Dist::Zilla::Plugin::PodWeaver" : "0", "Dist::Zilla::Plugin::Prereqs::AuthorDeps" : "0", "Dist::Zilla::Plugin::PromptIfStale" : "0", "Dist::Zilla::Plugin::PruneCruft" : "0", "Dist::Zilla::Plugin::PruneFiles" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::Plugin::RunExtraTests" : "0", "Dist::Zilla::Plugin::ShareDir" : "0", "Dist::Zilla::Plugin::Test::Compile" : "0", "Dist::Zilla::Plugin::Test::ReportPrereqs" : "0", "Dist::Zilla::Plugin::Test::Version" : "0", "Dist::Zilla::Plugin::TestRelease" : "0", "Dist::Zilla::Plugin::UploadToCPAN" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Software::License::Perl_5" : "0", "Test::CPAN::Meta" : "0", "Test::More" : "0", "Test::Pod" : "1.41", "Test::Version" : "1", "blib" : "1.01" } }, "runtime" : { "requires" : { "B" : "0", "Carp" : "0", "Exporter" : "0", "Fcntl" : "0", "Scalar::Util" : "0", "perl" : "5.008001", "strict" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "ExtUtils::MakeMaker" : "0", "File::Basename" : "0", "File::Find" : "0", "File::Spec" : "0", "File::Spec::Functions" : "0", "File::Temp" : "0.19", "IO::Dir" : "0", "JSON::PP" : "0", "Test::More" : "0.88", "base" : "0", "lib" : "0", "utf8" : "0", "vars" : "0" } } }, "provides" : { "CPAN::Meta::YAML" : { "file" : "lib/CPAN/Meta/YAML.pm", "version" : "0.018" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues" }, "homepage" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-YAML", "repository" : { "type" : "git", "url" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-YAML.git", "web" : "https://github.com/Perl-Toolchain-Gang/CPAN-Meta-YAML" } }, "version" : "0.018", "x_authority" : "cpan:DAGOLDEN" } perl5/x86_64-linux-thread-multi/.meta/XML-Simple-2.25/install.json 0000444 00000000314 14711220226 0020074 0 ustar 00 {"provides":{"XML::Simple":{"version":2.25,"file":"lib/XML/Simple.pm"}},"target":"XML::Simple","version":2.25,"name":"XML::Simple","dist":"XML-Simple-2.25","pathname":"G/GR/GRANTM/XML-Simple-2.25.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/XML-Simple-2.25/MYMETA.json 0000444 00000002513 14711220226 0017425 0 ustar 00 { "abstract" : "An API for simple XML files", "author" : [ "Grant McLean <grantm@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.043, CPAN::Meta::Converter version 2.150005, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "XML-Simple", "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "requires" : { "XML::NamespaceSupport" : "1.04", "XML::SAX" : "0.15", "XML::SAX::Expat" : "0", "perl" : "5.008" } }, "test" : { "requires" : { "File::Temp" : "0", "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/grantm/xml-simple.git", "web" : "https://github.com/grantm/xml-simple" } }, "version" : "2.25" } perl5/x86_64-linux-thread-multi/.meta/File-Which-1.27/install.json 0000444 00000000316 14711220226 0020127 0 ustar 00 {"provides":{"File::Which":{"version":1.27,"file":"lib/File/Which.pm"}},"target":"File::Which","version":1.27,"name":"File::Which","dist":"File-Which-1.27","pathname":"P/PL/PLICEASE/File-Which-1.27.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/File-Which-1.27/MYMETA.json 0000444 00000004446 14711220227 0017466 0 ustar 00 { "abstract" : "Perl implementation of the which utility as an API", "author" : [ "Per Einar Ellefsen <pereinar@cpan.org>", "Adam Kennedy <adamk@cpan.org>", "Graham Ollis <plicease@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.017, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "File-Which", "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "File::Basename" : "0", "File::Find" : "0", "File::chdir" : "0", "FindBin" : "0", "Perl::Critic" : "0", "Test2::Require::Module" : "0.000060", "Test2::Tools::PerlCritic" : "0", "Test2::V0" : "0.000060", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.47", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::Strict" : "0", "YAML" : "0" } }, "runtime" : { "requires" : { "base" : "0", "perl" : "5.006" } }, "test" : { "requires" : { "Env" : "0", "Test::More" : "0.47" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/uperl/File-Which/issues" }, "homepage" : "https://metacpan.org/pod/File::Which", "repository" : { "type" : "git", "url" : "git://github.com/uperl/File-Which.git", "web" : "https://github.com/uperl/File-Which" } }, "version" : "1.27", "x_generated_by_perl" : "v5.33.9", "x_serialization_backend" : "Cpanel::JSON::XS version 4.26", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_use_unsafe_inc" : 0 } perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.076/install.json 0000444 00000000320 14711220227 0017767 0 ustar 00 {"provides":{"HTTP::Tiny":{"version":"0.076","file":"lib/HTTP/Tiny.pm"}},"target":"HTTP::Tiny","version":"0.076","name":"HTTP::Tiny","dist":"HTTP-Tiny-0.076","pathname":"D/DA/DAGOLDEN/HTTP-Tiny-0.076.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/HTTP-Tiny-0.076/MYMETA.json 0000444 00000013026 14711220227 0017324 0 ustar 00 { "abstract" : "A small, simple, correct HTTP/1.1 client", "author" : [ "Christian Hansen <chansen@cpan.org>", "David Golden <dagolden@cpan.org>" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "HTTP-Tiny", "no_index" : { "directory" : [ "corpus", "examples", "t", "xt" ], "package" : [ "DB" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17", "perl" : "5.006" }, "suggests" : { "JSON::PP" : "2.27300" } }, "develop" : { "requires" : { "Dist::Zilla" : "5", "Dist::Zilla::Plugin::Prereqs" : "0", "Dist::Zilla::Plugin::ReleaseStatus::FromVersion" : "0", "Dist::Zilla::Plugin::RemovePrereqs" : "0", "Dist::Zilla::PluginBundle::DAGOLDEN" : "0.072", "File::Spec" : "0", "File::Temp" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Perl::Critic::Policy::Lax::ProhibitStringyEval::ExceptForRequire" : "0", "Pod::Coverage::TrustPod" : "0", "Pod::Wordlist" : "0", "Software::License::Perl_5" : "0", "Test::CPAN::Meta" : "0", "Test::MinimumVersion" : "0", "Test::More" : "0", "Test::Perl::Critic" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08", "Test::Portability::Files" : "0", "Test::Spelling" : "0.12", "Test::Version" : "1", "perl" : "5.006" } }, "runtime" : { "recommends" : { "HTTP::CookieJar" : "0.001", "IO::Socket::IP" : "0.32", "IO::Socket::SSL" : "1.42", "Mozilla::CA" : "20160104", "Net::SSLeay" : "1.49" }, "requires" : { "Carp" : "0", "Fcntl" : "0", "IO::Socket" : "0", "MIME::Base64" : "0", "Socket" : "0", "Time::Local" : "0", "bytes" : "0", "perl" : "5.006", "strict" : "0", "warnings" : "0" }, "suggests" : { "IO::Socket::SSL" : "1.56" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "Data::Dumper" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", "File::Basename" : "0", "File::Spec" : "0", "File::Temp" : "0", "IO::Dir" : "0", "IO::File" : "0", "IO::Socket::INET" : "0", "IPC::Cmd" : "0", "Test::More" : "0.96", "lib" : "0", "open" : "0" } } }, "provides" : { "HTTP::Tiny" : { "file" : "lib/HTTP/Tiny.pm", "version" : "0.076" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/chansen/p5-http-tiny/issues" }, "homepage" : "https://github.com/chansen/p5-http-tiny", "repository" : { "type" : "git", "url" : "https://github.com/chansen/p5-http-tiny.git", "web" : "https://github.com/chansen/p5-http-tiny" } }, "version" : "0.076", "x_authority" : "cpan:DAGOLDEN", "x_contributors" : [ "Alan Gardner <gardner@pythian.com>", "Alessandro Ghedini <al3xbio@gmail.com>", "A. Sinan Unur <nanis@cpan.org>", "Brad Gilbert <bgills@cpan.org>", "brian m. carlson <sandals@crustytoothpaste.net>", "Chris Nehren <apeiron@cpan.org>", "Chris Weyl <cweyl@alumni.drew.edu>", "Claes Jakobsson <claes@surfar.nu>", "Clinton Gormley <clint@traveljury.com>", "Craig A. Berry <craigberry@mac.com>", "Craig Berry <cberry@cpan.org>", "David Golden <xdg@xdg.me>", "David Mitchell <davem@iabyn.com>", "Dean Pearce <pearce@pythian.com>", "Edward Zborowski <ed@rubensteintech.com>", "Felipe Gasper <felipe@felipegasper.com>", "James Raspass <jraspass@gmail.com>", "Jeremy Mates <jmates@cpan.org>", "Jess Robinson <castaway@desert-island.me.uk>", "Karen Etheridge <ether@cpan.org>", "Lukas Eklund <leklund@gmail.com>", "Martin J. Evans <mjegh@ntlworld.com>", "Martin-Louis Bright <mlbright@gmail.com>", "Mike Doherty <doherty@cpan.org>", "Nicolas Rochelemagne <rochelemagne@cpanel.net>", "Olaf Alders <olaf@wundersolutions.com>", "Olivier Mengué <dolmen@cpan.org>", "Petr Písař <ppisar@redhat.com>", "Serguei Trouchelle <stro@cpan.org>", "Shoichi Kaji <skaji@cpan.org>", "SkyMarshal <skymarshal1729@gmail.com>", "Sören Kornetzki <soeren.kornetzki@delti.com>", "Steve Grazzini <steve.grazzini@grantstreet.com>", "Syohei YOSHIDA <syohex@gmail.com>", "Tatsuhiko Miyagawa <miyagawa@bulknews.net>", "Tom Hukins <tom@eborcom.com>", "Tony Cook <tony@develop-help.com>" ], "x_generated_by_perl" : "v5.28.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.04" } perl5/x86_64-linux-thread-multi/.meta/ExtUtils-MakeMaker-7.62/install.json 0000444 00000005430 14711220227 0021634 0 ustar 00 {"provides":{"MY":{"version":7.62,"file":"lib/ExtUtils/MakeMaker.pm"},"ExtUtils::MM_MacOS":{"version":7.62,"file":"lib/ExtUtils/MM_MacOS.pm"},"ExtUtils::Command":{"version":7.62,"file":"lib/ExtUtils/Command.pm"},"ExtUtils::MM":{"version":7.62,"file":"lib/ExtUtils/MM.pm"},"MM":{"version":7.62,"file":"lib/ExtUtils/MM.pm"},"ExtUtils::MM_UWIN":{"version":7.62,"file":"lib/ExtUtils/MM_UWIN.pm"},"ExtUtils::MM_NW5":{"version":7.62,"file":"lib/ExtUtils/MM_NW5.pm"},"ExtUtils::Mksymlists":{"version":7.62,"file":"lib/ExtUtils/Mksymlists.pm"},"ExtUtils::MM_QNX":{"version":7.62,"file":"lib/ExtUtils/MM_QNX.pm"},"ExtUtils::MakeMaker::Config":{"version":7.62,"file":"lib/ExtUtils/MakeMaker/Config.pm"},"ExtUtils::MakeMaker::version::regex":{"version":7.62,"file":"lib/ExtUtils/MakeMaker/version/regex.pm"},"ExtUtils::MM_Unix":{"version":7.62,"file":"lib/ExtUtils/MM_Unix.pm"},"ExtUtils::MM_Darwin":{"version":7.62,"file":"lib/ExtUtils/MM_Darwin.pm"},"ExtUtils::MM_OS390":{"version":7.62,"file":"lib/ExtUtils/MM_OS390.pm"},"ExtUtils::MakeMaker":{"version":7.62,"file":"lib/ExtUtils/MakeMaker.pm"},"ExtUtils::MM_Win32":{"version":7.62,"file":"lib/ExtUtils/MM_Win32.pm"},"ExtUtils::MM_VOS":{"version":7.62,"file":"lib/ExtUtils/MM_VOS.pm"},"ExtUtils::testlib":{"version":7.62,"file":"lib/ExtUtils/testlib.pm"},"ExtUtils::MakeMaker::version":{"version":7.62,"file":"lib/ExtUtils/MakeMaker/version.pm"},"ExtUtils::Command::MM":{"version":7.62,"file":"lib/ExtUtils/Command/MM.pm"},"ExtUtils::MM_BeOS":{"version":7.62,"file":"lib/ExtUtils/MM_BeOS.pm"},"ExtUtils::MM_Any":{"version":7.62,"file":"lib/ExtUtils/MM_Any.pm"},"ExtUtils::MakeMaker::version::vpp":{"version":7.62,"file":"lib/ExtUtils/MakeMaker/version/vpp.pm"},"ExtUtils::MM_VMS":{"version":7.62,"file":"lib/ExtUtils/MM_VMS.pm"},"ExtUtils::MY":{"version":7.62,"file":"lib/ExtUtils/MY.pm"},"ExtUtils::MM_Cygwin":{"version":7.62,"file":"lib/ExtUtils/MM_Cygwin.pm"},"ExtUtils::MM_DOS":{"version":7.62,"file":"lib/ExtUtils/MM_DOS.pm"},"ExtUtils::MakeMaker::_version":{"version":7.62,"file":"lib/ExtUtils/MM_Unix.pm"},"ExtUtils::Liblist::Kid":{"version":7.62,"file":"lib/ExtUtils/Liblist/Kid.pm"},"ExtUtils::MM_OS2":{"version":7.62,"file":"lib/ExtUtils/MM_OS2.pm"},"ExtUtils::MakeMaker::Locale":{"version":7.62,"file":"lib/ExtUtils/MakeMaker/Locale.pm"},"ExtUtils::MM_Win95":{"version":7.62,"file":"lib/ExtUtils/MM_Win95.pm"},"ExtUtils::MakeMaker::charstar":{"version":7.62,"file":"lib/ExtUtils/MakeMaker/version/vpp.pm"},"ExtUtils::MM_AIX":{"version":7.62,"file":"lib/ExtUtils/MM_AIX.pm"},"ExtUtils::Liblist":{"version":7.62,"file":"lib/ExtUtils/Liblist.pm"},"ExtUtils::Mkbootstrap":{"version":7.62,"file":"lib/ExtUtils/Mkbootstrap.pm"}},"target":"ExtUtils::MakeMaker","version":7.62,"name":"ExtUtils::MakeMaker","dist":"ExtUtils-MakeMaker-7.62","pathname":"B/BI/BINGOS/ExtUtils-MakeMaker-7.62.tar.gz"} perl5/x86_64-linux-thread-multi/.meta/ExtUtils-MakeMaker-7.62/MYMETA.json 0000444 00000003013 14711220227 0021155 0 ustar 00 { "abstract" : "Create a module Makefile", "author" : [ "Michael G Schwern <schwern@pobox.com>" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "ExtUtils-MakeMaker", "no_index" : { "directory" : [ "t", "inc", "bundled", "my" ], "package" : [ "DynaLoader", "in", "version" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : {} }, "runtime" : { "requires" : { "Data::Dumper" : "0", "Encode" : "0", "File::Basename" : "0", "File::Spec" : "0.8", "Pod::Man" : "0", "perl" : "5.006" } }, "test" : { "requires" : {} } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://rt.cpan.org/NoAuth/Bugs.html?Dist=ExtUtils-MakeMaker" }, "homepage" : "https://metacpan.org/release/ExtUtils-MakeMaker", "license" : [ "https://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker" }, "x_MailingList" : "makemaker@perl.org" }, "version" : "7.62" } perl5/File/Which.pm 0000444 00000030077 14711220227 0010055 0 ustar 00 package File::Which; use strict; use warnings; use base qw( Exporter ); use File::Spec (); # ABSTRACT: Perl implementation of the which utility as an API our $VERSION = '1.27'; # VERSION our @EXPORT = 'which'; our @EXPORT_OK = 'where'; use constant IS_VMS => ($^O eq 'VMS'); use constant IS_MAC => ($^O eq 'MacOS'); use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2'); use constant IS_DOS => IS_WIN(); use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys'); our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC; # For Win32 systems, stores the extensions used for # executable files # For others, the empty string is used # because 'perl' . '' eq 'perl' => easier my @PATHEXT = (''); if ( IS_WIN ) { # WinNT. PATHEXT might be set on Cygwin, but not used. if ( $ENV{PATHEXT} ) { push @PATHEXT, split /;/, $ENV{PATHEXT}; } else { # Win9X or other: doesn't have PATHEXT, so needs hardcoded. push @PATHEXT, qw{.com .exe .bat}; } } elsif ( IS_VMS ) { push @PATHEXT, qw{.exe .com}; } elsif ( IS_CYG ) { # See this for more info # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe push @PATHEXT, qw{.exe .com}; } sub which { my ($exec) = @_; return undef unless defined $exec; return undef if $exec eq ''; my $all = wantarray; ## no critic (Freenode::Wantarray) my @results = (); # check for aliases first if ( IS_VMS ) { my $symbol = `SHOW SYMBOL $exec`; chomp($symbol); unless ( $? ) { return $symbol unless $all; push @results, $symbol; } } if ( IS_MAC ) { my @aliases = split /\,/, $ENV{Aliases}; foreach my $alias ( @aliases ) { # This has not been tested!! # PPT which says MPW-Perl cannot resolve `Alias $alias`, # let's just hope it's fixed if ( lc($alias) eq lc($exec) ) { chomp(my $file = `Alias $alias`); last unless $file; # if it failed, just go on the normal way return $file unless $all; push @results, $file; # we can stop this loop as if it finds more aliases matching, # it'll just be the same result anyway last; } } } return $exec ## no critic (ValuesAndExpressions::ProhibitMixedBooleanOperators) if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec; my @path; if($^O eq 'MSWin32') { # File::Spec (at least recent versions) # add the implicit . for you on MSWin32, # but we may or may not want to include # that. @path = split /;/, $ENV{PATH}; s/"//g for @path; @path = grep length, @path; } else { @path = File::Spec->path; } if ( $IMPLICIT_CURRENT_DIR ) { unshift @path, File::Spec->curdir; } foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) { for my $ext ( @PATHEXT ) { my $file = $base.$ext; # We don't want dirs (as they are -x) next if -d $file; if ( # Executable, normal case -x _ or ( # MacOS doesn't mark as executable so we check -e IS_MAC ## no critic (ValuesAndExpressions::ProhibitMixedBooleanOperators) || ( ( IS_WIN or IS_CYG ) and grep { ## no critic (BuiltinFunctions::ProhibitBooleanGrep) $file =~ /$_\z/i } @PATHEXT[1..$#PATHEXT] ) # DOSish systems don't pass -x on # non-exe/bat/com files. so we check -e. # However, we don't want to pass -e on files # that aren't in PATHEXT, like README. and -e _ ) ) { return $file unless $all; push @results, $file; } } } if ( $all ) { return @results; } else { return undef; } } sub where { # force wantarray my @res = which($_[0]); return @res; } 1; __END__ =pod =encoding UTF-8 =head1 NAME File::Which - Perl implementation of the which utility as an API =head1 VERSION version 1.27 =head1 SYNOPSIS use File::Which; # exports which() use File::Which qw(which where); # exports which() and where() my $exe_path = which 'perldoc'; my @paths = where 'perl'; # Or my @paths = which 'perl'; # an array forces search for all of them =head1 DESCRIPTION L<File::Which> finds the full or relative paths to executable programs on the system. This is normally the function of C<which> utility. C<which> is typically implemented as either a program or a built in shell command. On some platforms, such as Microsoft Windows it is not provided as part of the core operating system. This module provides a consistent API to this functionality regardless of the underlying platform. The focus of this module is correctness and portability. As a consequence platforms where the current directory is implicitly part of the search path such as Microsoft Windows will find executables in the current directory, whereas on platforms such as UNIX where this is not the case executables in the current directory will only be found if the current directory is explicitly added to the path. If you need a portable C<which> on the command line in an environment that does not provide it, install L<App::pwhich> which provides a command line interface to this API. =head2 Implementations L<File::Which> searches the directories of the user's C<PATH> (the current implementation uses L<File::Spec#path> to determine the correct C<PATH>), looking for executable files having the name specified as a parameter to L</which>. Under Win32 systems, which do not have a notion of directly executable files, but uses special extensions such as C<.exe> and C<.bat> to identify them, C<File::Which> takes extra steps to assure that you will find the correct file (so for example, you might be searching for C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.) =head3 Linux, *BSD and other UNIXes There should not be any surprises here. The current directory will not be searched unless it is explicitly added to the path. =head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc) Windows NT has a special environment variable called C<PATHEXT>, which is used by the shell to look for executable files. Usually, it will contain a list in the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an environment variable, it parses the list and uses it as the different extensions. =head3 Cygwin Cygwin provides a Unix-like environment for Microsoft Windows users. In most ways it works like other Unix and Unix-like environments, but in a few key aspects it works like Windows. As with other Unix environments, the current directory is not included in the search unless it is explicitly included in the search path. Like on Windows, files with C<.EXE> or <.BAT> extensions will be discovered even if they are not part of the query. C<.COM> or extensions specified using the C<PATHEXT> environment variable will NOT be discovered without the fully qualified name, however. =head3 Windows ME, 98, 95, MS-DOS, OS/2 This set of operating systems don't have the C<PATHEXT> variable, and usually you will find executable files there with the extensions C<.exe>, C<.bat> and (less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running under Win32 but does not find a C<PATHEXT> variable. As of 2015 none of these platforms are tested frequently (or perhaps ever), but the current maintainer is determined not to intentionally remove support for older operating systems. =head3 VMS Same case as Windows 9x: uses C<.exe> and C<.com> (in that order). As of 2015 the current maintainer does not test on VMS, and is in fact not certain it has ever been tested on VMS. If this platform is important to you and you can help me verify and or support it on that platform please contact me. =head1 FUNCTIONS =head2 which my $path = which $short_exe_name; my @paths = which $short_exe_name; Exported by default. C<$short_exe_name> is the name used in the shell to call the program (for example, C<perl>). If it finds an executable with the name you specified, C<which()> will return the absolute path leading to this executable (for example, F</usr/bin/perl> or F<C:\Perl\Bin\perl.exe>). If it does I<not> find the executable, it returns C<undef>. If C<which()> is called in list context, it will return I<all> the matches. =head2 where my @paths = where $short_exe_name; Not exported by default. Same as L</which> in array context. Similar to the C<where> csh built-in command or C<which -a> command for platforms that support the C<-a> option. Will return an array containing all the path names matching C<$short_exe_name>. =head1 GLOBALS =head2 $IMPLICIT_CURRENT_DIR True if the current directory is included in the search implicitly on whatever platform you are using. Normally the default is reasonable, but on Windows the current directory is included implicitly for older shells like C<cmd.exe> and C<command.com>, but not for newer shells like PowerShell. If you overrule this default, you should ALWAYS localize the variable to the tightest scope possible, since setting this variable from a module can affect other modules. Thus on Windows you can get the correct result if the user is running either C<cmd.exe> or PowerShell on Windows you can do this: use File::Which qw( which ); use Shell::Guess; my $path = do { my $is_power = Shell::Guess->running_shell->is_power; local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power; which 'foo'; }; For a variety of reasons it is difficult to accurately compute the shell that a user is using, but L<Shell::Guess> makes a reasonable effort. =head1 CAVEATS This module has no non-core requirements for Perl 5.6.2 and better. This module is fully supported back to Perl 5.8.1. It may work on 5.8.0. It should work on Perl 5.6.x and I may even test on 5.6.2. I will accept patches to maintain compatibility for such older Perls, but you may need to fix it on 5.6.x / 5.8.0 and send me a patch. Not tested on VMS although there is platform specific code for those. Anyone who haves a second would be very kind to send me a report of how it went. =head1 SUPPORT Bugs should be reported via the GitHub issue tracker L<https://github.com/uperl/File-Which/issues> For other issues, contact the maintainer. =head1 SEE ALSO =over 4 =item L<pwhich>, L<App::pwhich> Command line interface to this module. =item L<IPC::Cmd> Requires Perl 5.8.3. Included as part of the Perl core as of 5.9.5. This module provides (among other things) a C<can_run> function, which is similar to C<which>. It is a much heavier module since it does a lot more, and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>. This combination may be overkill for applications which do not need L<IPC::Cmd>'s complicated interface for running programs, or do not need the memory overhead required for installing Perl modules. At least some older versions will find executables in the current directory, even if the current directory is not in the search path (which is the default on modern Unix). C<can_run> converts directory path name to the 8.3 version on Windows using C<Win32::GetShortPathName> in some cases. This is frequently useful for tools that just need to run something using C<system> in scalar mode, but may be inconvenient for tools like L<App::pwhich> where user readability is a premium. Relying on C<Win32::GetShortPathName> to produce filenames without spaces is problematic, as 8.3 filenames can be turned off with tweaks to the registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>). =item L<Devel::CheckBin> Requires Perl 5.8.1. This module purports to "check that a command is available", but does not provide any documentation on how you might use it. This module also relies on L<ExtUtils::MakeMaker> so has the same overhead burdens as L<IPC::Cmd>. =back =head1 AUTHORS =over 4 =item * Per Einar Ellefsen <pereinar@cpan.org> =item * Adam Kennedy <adamk@cpan.org> =item * Graham Ollis <plicease@cpan.org> =back =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@cpan.org>. 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 perl5/File/chdir.pm 0000444 00000025134 14711220230 0010074 0 ustar 00 package File::chdir; use 5.004; use strict; use vars qw($VERSION @ISA @EXPORT $CWD @CWD); # ABSTRACT: a more sensible way to change directories our $VERSION = '0.1010'; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(*CWD); use Carp; use Cwd 3.16; use File::Spec::Functions 3.27 qw/canonpath splitpath catpath splitdir catdir/; tie $CWD, 'File::chdir::SCALAR' or die "Can't tie \$CWD"; tie @CWD, 'File::chdir::ARRAY' or die "Can't tie \@CWD"; sub _abs_path { # Otherwise we'll never work under taint mode. my($cwd) = Cwd::getcwd =~ /(.*)/s; # Run through File::Spec, since everything else uses it return canonpath($cwd); } # splitpath but also split directory sub _split_cwd { my ($vol, $dir) = splitpath(_abs_path, 1); my @dirs = splitdir( $dir ); shift @dirs; # get rid of leading empty "root" directory return ($vol, @dirs); } # catpath, but take list of directories # restore the empty root dir and provide an empty file to avoid warnings sub _catpath { my ($vol, @dirs) = @_; return catpath($vol, catdir(q{}, @dirs), q{}); } sub _chdir { # Untaint target directory my ($new_dir) = $_[0] =~ /(.*)/s; local $Carp::CarpLevel = $Carp::CarpLevel + 1; if ( ! CORE::chdir($new_dir) ) { croak "Failed to change directory to '$new_dir': $!"; }; return 1; } { package File::chdir::SCALAR; use Carp; BEGIN { *_abs_path = \&File::chdir::_abs_path; *_chdir = \&File::chdir::_chdir; *_split_cwd = \&File::chdir::_split_cwd; *_catpath = \&File::chdir::_catpath; } sub TIESCALAR { bless [], $_[0]; } # To be safe, in case someone chdir'd out from under us, we always # check the Cwd explicitly. sub FETCH { return _abs_path; } sub STORE { return unless defined $_[1]; _chdir($_[1]); } } { package File::chdir::ARRAY; use Carp; BEGIN { *_abs_path = \&File::chdir::_abs_path; *_chdir = \&File::chdir::_chdir; *_split_cwd = \&File::chdir::_split_cwd; *_catpath = \&File::chdir::_catpath; } sub TIEARRAY { bless {}, $_[0]; } sub FETCH { my($self, $idx) = @_; my ($vol, @cwd) = _split_cwd; return $cwd[$idx]; } sub STORE { my($self, $idx, $val) = @_; my ($vol, @cwd) = _split_cwd; if( $self->{Cleared} ) { @cwd = (); $self->{Cleared} = 0; } $cwd[$idx] = $val; my $dir = _catpath($vol,@cwd); _chdir($dir); return $cwd[$idx]; } sub FETCHSIZE { my ($vol, @cwd) = _split_cwd; return scalar @cwd; } sub STORESIZE {} sub PUSH { my($self) = shift; my $dir = _catpath(_split_cwd, @_); _chdir($dir); return $self->FETCHSIZE; } sub POP { my($self) = shift; my ($vol, @cwd) = _split_cwd; my $popped = pop @cwd; my $dir = _catpath($vol,@cwd); _chdir($dir); return $popped; } sub SHIFT { my($self) = shift; my ($vol, @cwd) = _split_cwd; my $shifted = shift @cwd; my $dir = _catpath($vol,@cwd); _chdir($dir); return $shifted; } sub UNSHIFT { my($self) = shift; my ($vol, @cwd) = _split_cwd; my $dir = _catpath($vol, @_, @cwd); _chdir($dir); return $self->FETCHSIZE; } sub CLEAR { my($self) = shift; $self->{Cleared} = 1; } sub SPLICE { my $self = shift; my $offset = shift || 0; my $len = shift || $self->FETCHSIZE - $offset; my @new_dirs = @_; my ($vol, @cwd) = _split_cwd; my @orig_dirs = splice @cwd, $offset, $len, @new_dirs; my $dir = _catpath($vol, @cwd); _chdir($dir); return @orig_dirs; } sub EXTEND { } sub EXISTS { my($self, $idx) = @_; return $self->FETCHSIZE >= $idx ? 1 : 0; } sub DELETE { my($self, $idx) = @_; croak "Can't delete except at the end of \@CWD" if $idx < $self->FETCHSIZE - 1; local $Carp::CarpLevel = $Carp::CarpLevel + 1; $self->POP; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME File::chdir - a more sensible way to change directories =head1 VERSION version 0.1010 =head1 SYNOPSIS use File::chdir; $CWD = "/foo/bar"; # now in /foo/bar { local $CWD = "/moo/baz"; # now in /moo/baz ... } # still in /foo/bar! =head1 DESCRIPTION Perl's C<chdir()> has the unfortunate problem of being very, very, very global. If any part of your program calls C<chdir()> or if any library you use calls C<chdir()>, it changes the current working directory for the *whole* program. This sucks. File::chdir gives you an alternative, C<$CWD> and C<@CWD>. These two variables combine all the power of C<chdir()>, L<File::Spec> and L<Cwd>. =head1 $CWD Use the C<$CWD> variable instead of C<chdir()> and Cwd. use File::chdir; $CWD = $dir; # just like chdir($dir)! print $CWD; # prints the current working directory It can be localized, and it does the right thing. $CWD = "/foo"; # it's /foo out here. { local $CWD = "/bar"; # /bar in here } # still /foo out here! C<$CWD> always returns the absolute path in the native form for the operating system. C<$CWD> and normal C<chdir()> work together just fine. =head1 @CWD C<@CWD> represents the current working directory as an array, each directory in the path is an element of the array. This can often make the directory easier to manipulate, and you don't have to fumble with C<File::Spec->splitpath> and C<File::Spec->catdir> to make portable code. # Similar to chdir("/usr/local/src/perl") @CWD = qw(usr local src perl); pop, push, shift, unshift and splice all work. pop and push are probably the most useful. pop @CWD; # same as chdir(File::Spec->updir) push @CWD, 'some_dir' # same as chdir('some_dir') C<@CWD> and C<$CWD> both work fine together. *NOTE* Due to a perl bug you can't localize C<@CWD>. See L</CAVEATS> for a work around. =head1 EXAMPLES (We omit the C<use File::chdir> from these examples for terseness) Here's C<$CWD> instead of C<chdir()>: $CWD = 'foo'; # chdir('foo') and now instead of Cwd. print $CWD; # use Cwd; print Cwd::abs_path you can even do zsh style C<cd foo bar> $CWD = '/usr/local/foo'; $CWD =~ s/usr/var/; if you want to localize that, make sure you get the parens right { (local $CWD) =~ s/usr/var/; ... } It's most useful for writing polite subroutines which don't leave the program in some strange directory: sub foo { local $CWD = 'some/other/dir'; ...do your work... } which is much simpler than the equivalent: sub foo { use Cwd; my $orig_dir = Cwd::getcwd; chdir('some/other/dir'); ...do your work... chdir($orig_dir); } C<@CWD> comes in handy when you want to start moving up and down the directory hierarchy in a cross-platform manner without having to use File::Spec. pop @CWD; # chdir(File::Spec->updir); push @CWD, 'some', 'dir' # chdir(File::Spec->catdir(qw(some dir))); You can easily change your parent directory: # chdir from /some/dir/bar/moo to /some/dir/foo/moo $CWD[-2] = 'foo'; =head1 CAVEATS =head2 C<local @CWD> does not work. C<local @CWD> will not localize C<@CWD>. This is a bug in Perl, you can't localize tied arrays. As a work around localizing $CWD will effectively localize @CWD. { local $CWD; pop @CWD; ... } =head2 Assigning to C<@CWD> calls C<chdir()> for each element @CWD = qw/a b c d/; Internally, Perl clears C<@CWD> and assigns each element in turn. Thus, this code above will do this: chdir 'a'; chdir 'a/b'; chdir 'a/b/c'; chdir 'a/b/c/d'; Generally, avoid assigning to C<@CWD> and just use push and pop instead. =head2 Volumes not handled There is currently no way to change the current volume via File::chdir. =head1 NOTES C<$CWD> returns the current directory using native path separators, i.e. \ on Win32. This ensures that C<$CWD> will compare correctly with directories created using File::Spec. For example: my $working_dir = File::Spec->catdir( $CWD, "foo" ); $CWD = $working_dir; doing_stuff_might_chdir(); is( $CWD, $working_dir, "back to original working_dir?" ); Deleting the last item of C<@CWD> will act like a pop. Deleting from the middle will throw an exception. delete @CWD[-1]; # OK delete @CWD[-2]; # Dies What should %CWD do? Something with volumes? # chdir to C:\Program Files\Sierra\Half Life ? $CWD{C} = '\\Program Files\\Sierra\\Half Life'; =head1 DIAGNOSTICS If an error is encountered when changing C<$CWD> or C<@CWD>, one of the following exceptions will be thrown: * ~Can't delete except at the end of @CWD~ * ~Failed to change directory to '$dir'~ =head1 HISTORY Michael wanted C<local chdir> to work. p5p didn't. But it wasn't over! Was it over when the Germans bombed Pearl Harbor? Hell, no! Abigail and/or Bryan Warnock suggested the C<$CWD> thing (Michael forgets which). They were right. The C<chdir()> override was eliminated in 0.04. David became co-maintainer with 0.06_01 to fix some chronic Win32 path bugs. As of 0.08, if changing C<$CWD> or C<@CWD> fails to change the directory, an error will be thrown. =head1 SEE ALSO L<File::pushd>, L<File::Spec>, L<Cwd>, L<perlfunc/chdir>, "Animal House" L<http://www.imdb.com/title/tt0077975/quotes> =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 SUPPORT =head2 Bugs / Feature Requests Please report any bugs or feature requests through the issue tracker at L<https://github.com/dagolden/File-chdir/issues>. You will be notified automatically of any progress on your issue. =head2 Source Code This is open source software. The code repository is available for public review and contribution under the terms of the license. L<https://github.com/dagolden/File-chdir> git clone https://github.com/dagolden/File-chdir.git =head1 AUTHORS =over 4 =item * David Golden <dagolden@cpan.org> =item * Michael G. Schwern <schwern@pobox.com> =back =head1 CONTRIBUTOR =for stopwords Joel Berger Joel Berger <joel.a.berger@gmail.com> =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Michael G. Schwern and David Golden. 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 perl5/ok.pm 0000444 00000001707 14711220230 0006535 0 ustar 00 package ok; our $VERSION = '1.302186'; use strict; use Test::More (); sub import { shift; if (@_) { goto &Test::More::pass if $_[0] eq 'ok'; goto &Test::More::use_ok; } # No argument list - croak as if we are prototyped like use_ok() my (undef, $file, $line) = caller(); ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; } __END__ =encoding UTF-8 =head1 NAME ok - Alternative to Test::More::use_ok =head1 SYNOPSIS use ok 'Some::Module'; =head1 DESCRIPTION With this module, simply change all C<use_ok> in test scripts to C<use ok>, and they will be executed at C<BEGIN> time. Please see L<Test::use::ok> for the full description. =head1 CC0 1.0 Universal To the extent possible under law, 唐鳳 has waived all copyright and related or neighboring rights to L<Test-use-ok>. This work is published from Taiwan. L<http://creativecommons.org/publicdomain/zero/1.0> =cut perl5/Alien/Build/rc.pm 0000444 00000004544 14711220230 0010621 0 ustar 00 package Alien::Build::rc; use strict; use warnings; use 5.008004; # ABSTRACT: Alien::Build local config our $VERSION = '2.41'; # VERSION sub logx ($) { unshift @_, 'Alien::Build'; goto &Alien::Build::log; } sub preload ($) { push @Alien::Build::rc::PRELOAD, $_[0]; } sub postload ($) { push @Alien::Build::rc::POSTLOAD, $_[0]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::rc - Alien::Build local config =head1 VERSION version 2.41 =head1 SYNOPSIS in your C<~/.alienbuild/rc.pl>: preload 'Foo::Bar'; postload 'Baz::Frooble'; =head1 DESCRIPTION L<Alien::Build> will load your C<~/.alienbuild/rc.pl> file, if it exists before running the L<alienfile> recipe. This allows you to alter the behavior of L<Alien::Build> based L<Alien>s if you have local configuration requirements. For example you can prompt before downloading remote content or fetch from a local mirror. =head1 FUNCTIONS =head2 logx log $message; Send a message to the L<Alien::Build> log. =head2 preload preload $plugin; Preload the given plugin. =head2 postload postload $plugin; Postload the given plugin. =head1 SEE ALSO =over 4 =item L<Alien::Build::Plugin::Fetch::Cache> =item L<Alien::Build::Plugin::Fetch::Prompt> =item L<Alien::Build::Plugin::Fetch::Rewrite> =item L<Alien::Build::Plugin::Probe::Override> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin.pm 0000444 00000015537 14711220231 0011460 0 ustar 00 package Alien::Build::Plugin; use strict; use warnings; use 5.008004; use Data::Dumper (); use Carp (); use Digest::SHA (); our @CARP_NOT = qw( alienfile Alien::Build Alien::Build::Meta ); # ABSTRACT: Plugin base class for Alien::Build our $VERSION = '2.41'; # VERSION sub new { my $class = shift; my %args = @_ == 1 ? ($class->meta->default => $_[0]) : @_; my $instance_id = Digest::SHA::sha1_hex(Data::Dumper->new([$class, \%args])->Sortkeys(1)->Dump); my $self = bless { instance_id => $instance_id }, $class; my $prop = $self->meta->prop; foreach my $name (keys %$prop) { $self->{$name} = defined $args{$name} ? delete $args{$name} : ref($prop->{$name}) eq 'CODE' ? $prop->{$name}->() : $prop->{$name}; } foreach my $name (keys %args) { Carp::carp "$class has no $name property"; } $self; } sub instance_id { shift->{instance_id} } sub init { my($self) = @_; $self; } sub import { my($class) = @_; return if $class ne __PACKAGE__; my $caller = caller; { no strict 'refs'; @{ "${caller}::ISA" } = __PACKAGE__ } my $meta = $caller->meta; my $has = sub { my($name, $default) = @_; $meta->add_property($name, $default); }; { no strict 'refs'; *{ "${caller}::has" } = $has } } sub subplugin { my(undef, $name, %args) = @_; Carp::carp("subplugin method is deprecated"); my $class = "Alien::Build::Plugin::$name"; my $pm = "$class.pm"; $pm =~ s/::/\//g; require $pm unless eval { $class->can('new') }; delete $args{$_} for grep { ! defined $args{$_} } keys %args; $class->new(%args); } my %meta; sub meta { my($class) = @_; $class = ref $class if ref $class; $meta{$class} ||= Alien::Build::PluginMeta->new( class => $class ); } package Alien::Build::PluginMeta; sub new { my($class, %args) = @_; my $self = bless { prop => {}, %args, }, $class; } sub default { my($self) = @_; $self->{default} || do { Carp::croak "No default for @{[ $self->{class} ]}"; }; } sub add_property { my($self, $name, $default) = @_; my $single = $name =~ s{^(\+)}{}; $self->{default} = $name if $single; $self->{prop}->{$name} = $default; my $accessor = sub { my($self, $new) = @_; $self->{$name} = $new if defined $new; $self->{$name}; }; # add the accessor { no strict 'refs'; *{ $self->{class} . '::' . $name} = $accessor } $self; } sub prop { shift->{prop}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin - Plugin base class for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS Create your plugin: package Alien::Build::Plugin::Type::MyPlugin; use Alien::Build::Plugin; use Carp (); has prop1 => 'default value'; has prop2 => sub { 'default value' }; has prop3 => sub { Carp::croak 'prop3 is a required property' }; sub init { my($self, $meta) = @_; my $prop1 = $self->prop1; my $prop2 = $self->prop2; my $prop3 = $self->prop3; $meta->register_hook(sub { build => [ '%{make}', '%{make} install' ], }); } From your L<alienfile> use alienfile; plugin 'Type::MyPlugin' => ( prop2 => 'different value', prop3 => 'need to provide since it is required', ); =head1 DESCRIPTION This document describes the L<Alien::Build> plugin base class. For details on how to write a plugin, see L<Alien::Build::Manual::PluginAuthor>. Listed are some common types of plugins: =over 4 =item L<Alien::Build::Plugin::Build> Tools for building. =item L<Alien::Build::Plugin::Core> Tools already included. =item L<Alien::Build::Plugin::Download> Methods for retrieving from the internet. =item L<Alien::Build::Plugin::Decode> Normally use Download plugins which will pick the correct Decode plugins. =item L<Alien::Build::Plugin::Extract> Extract from archives that have been downloaded. =item L<Alien::Build::Plugin::Fetch> Normally use Download plugins which will pick the correct Fetch plugins. =item L<Alien::Build::Plugin::Prefer> Normally use Download plugins which will pick the correct Prefer plugins. =item L<Alien::Build::Plugin::Probe> Look for packages already installed on the system. =back =head1 CONSTRUCTOR =head2 new my $plugin = Alien::Build::Plugin->new(%props); =head2 PROPERTIES =head2 instance_id my $id = $plugin->instance_id; Returns an instance id for the plugin. This is computed from the class and arguments that are passed into the plugin constructor, so technically two instances with the exact same arguments will have the same instance id, but in practice you should never have two instances with the exact same arguments. =head1 METHODS =head2 init $plugin->init($ab_class->meta); # $ab is an Alien::Build class name You provide the implementation for this. The intent is to register hooks and set meta properties on the L<Alien::Build> class. =head2 subplugin B<DEPRECATED>: Maybe removed, but not before 1 October 2018. my $plugin2 = $plugin1->subplugin($plugin_name, %args); Finds the given plugin and loads it (unless already loaded) and creats a new instance and returns it. Most useful from a Negotiate plugin, like this: sub init { my($self, $meta) = @_; $self->subplugin( 'Foo::Bar', # loads Alien::Build::Plugin::Foo::Bar, # or throw exception foo => 1, # these key/value pairs passsed into new bar => 2, # for the plugin instance. )->init($meta); } =head2 has has $prop_name; has $prop_name => $default; Specifies a property of the plugin. You may provide a default value as either a string scalar, or a code reference. The code reference will be called to compute the default value, and if you want the default to be a list or hash reference, this is how you want to do it: has foo => sub { [1,2,3] }; =head2 meta my $meta = $plugin->meta; Returns the plugin meta object. =head1 SEE ALSO L<Alien::Build>, L<alienfile>, L<Alien::Build::Manual::PluginAuthor> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Util.pm 0000444 00000011462 14711220232 0011131 0 ustar 00 package Alien::Build::Util; use strict; use warnings; use 5.008004; use Exporter qw( import ); use Path::Tiny qw( path ); use Config; # ABSTRACT: Private utility functions for Alien::Build our $VERSION = '2.41'; # VERSION our @EXPORT_OK = qw( _mirror _dump _destdir_prefix _perl_config _ssl_reqs _has_ssl ); # usage: _mirror $source_directory, $dest_direction, \%options # # options: # - filter -> regex for files that should match # - empty_directory -> if true, create all directories, including empty ones. # - verbose -> turn on verbosity sub _mirror { my($src_root, $dst_root, $opt) = @_; ($src_root, $dst_root) = map { path($_) } ($src_root, $dst_root); $opt ||= {}; require Alien::Build; require File::Find; require File::Copy; File::Find::find({ wanted => sub { next unless -e $File::Find::name; my $src = path($File::Find::name)->relative($src_root); return if $opt->{filter} && "$src" !~ $opt->{filter}; return if "$src" eq '.'; my $dst = $dst_root->child("$src"); $src = $src->absolute($src_root); if(-l "$src") { unless(-d $dst->parent) { Alien::Build->log("mkdir -p @{[ $dst->parent ]}") if $opt->{verbose}; $dst->parent->mkpath; } # TODO: rmtree if a directory? if(-e "$dst") { unlink "$dst" } my $target = readlink "$src"; Alien::Build->log("ln -s $target $dst") if $opt->{verbose}; symlink($target, $dst) || die "unable to symlink $target => $dst"; } elsif(-d "$src") { if($opt->{empty_directory}) { unless(-d $dst) { Alien::Build->log("mkdir $dst") if $opt->{verbose}; mkdir($dst) || die "unable to create directory $dst: $!"; } } } elsif(-f "$src") { unless(-d $dst->parent) { Alien::Build->log("mkdir -p @{[ $dst->parent ]}") if $opt->{verbose}; $dst->parent->mkpath; } # TODO: rmtree if a directory? if(-e "$dst") { unlink "$dst" } Alien::Build->log("cp $src $dst") if $opt->{verbose}; File::Copy::cp("$src", "$dst") || die "copy error $src => $dst: $!"; if($] < 5.012 && -x "$src" && $^O ne 'MSWin32') { # apparently Perl 5.8 and 5.10 do not preserver perms my $mode = [stat "$src"]->[2] & oct(777); eval { chmod $mode, "$dst" }; } } }, no_chdir => 1, }, "$src_root"); (); } sub _dump { if(eval { require YAML }) { return YAML::Dump(@_); } else { require Data::Dumper; return Data::Dumper::Dumper(@_); } } sub _destdir_prefix { my($destdir, $prefix) = @_; $prefix =~ s{^/?([a-z]):}{$1}i if $^O eq 'MSWin32'; path($destdir)->child($prefix)->stringify; } sub _perl_config { my($key) = @_; $Config{$key}; } sub _ssl_reqs { return { 'Net::SSLeay' => '1.49', 'IO::Socket::SSL' => '1.56', }; } sub _has_ssl { my %reqs = %{ _ssl_reqs() }; eval { require Net::SSLeay; die "need Net::SSLeay $reqs{'Net::SSLeay'}" unless Net::SSLeay->VERSION($reqs{'Net::SSLeay'}); require IO::Socket::SSL; die "need IO::Socket::SSL $reqs{'IO::Socket::SSL'}" unless IO::Socket::SSL->VERSION($reqs{'IO::Socket::SSL'}); }; $@ eq ''; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Util - Private utility functions for Alien::Build =head1 VERSION version 2.41 =head1 DESCRIPTION This module contains some private utility functions used internally by L<Alien::Build>. It shouldn't be used by any distribution other than C<Alien-Build>. That includes L<Alien::Build> plugins that are not part of the L<Alien::Build> core. You have been warned. The functionality within may be removed at any time! =head1 SEE ALSO L<Alien::Build> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Manual/AlienUser.pod 0000444 00000014071 14711220232 0013465 0 ustar 00 # PODNAME: Alien::Build::Manual::AlienUser # ABSTRACT: Alien user documentation # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Manual::AlienUser - Alien user documentation =head1 VERSION version 2.41 =head1 SYNOPSIS perldoc Alien::Build::Manual::AlienUser =head1 DESCRIPTION This document is intended for a user of an L<Alien::Base> based L<Alien> module's user. Although specifically geared for L<Alien::Base> subclasses, it may have some useful hints for L<Alien> in general. Full working examples of how to use an L<Alien> module are also bundled with L<Alien::Build> in the distribution's C<example/user> directory. Those examples use L<Alien::xz>, which uses L<alienfile> + L<Alien::Build> + L<Alien::Base>. The following documentation will assume you are trying to use an L<Alien> called C<Alien::Foo> which provides the library C<libfoo> and the command line tool C<foo>. Many L<Alien>s will only provide one or the other. The best interface to use for using L<Alien::Base> based aliens is L<Alien::Base::Wrapper>. This allows you to combine multiple aliens together and handles a number of corner obscure corner cases that using L<Alien>s directly does not. Also as of 0.64, L<Alien::Base::Wrapper> comes bundled with L<Alien::Build> and L<Alien::Base> anyway, so it is not an extra dependency. What follows are the main use cases. =head2 ExtUtils::MakeMaker use ExtUtils::MakeMaker; use Alien::Base::Wrapper (); WriteMakefile( Alien::Base::Wrapper->new('Alien::Foo')->mm_args2( NAME => 'FOO::XS', ... ), ); L<Alien::Base::Wrapper> will take a hash of C<WriteMakefile> arguments and insert the appropriate compiler and linker flags for you. This is recommended over doing this yourself as the exact incantation to get EUMM to work is tricky to get right. The C<mm_args2> method will also set your C<CONFIGURE_REQUIRES> for L<Alien::Base::Wrapper>, L<ExtUtils::MakeMaker> and any aliens that you specify. =head2 Module::Build use Module::Build; use Alien::Base::Wrapper qw( Alien::Foo !export ); use Alien::Foo; my $build = Module::Build->new( ... configure_requires => { 'Alien::Base::Wrapper' => '0', 'Alien::Foo' => '0', ... }, Alien::Base::Wrapper->mb_args, ... ); $build->create_build_script; For L<Module::Build> you can also use L<Alien::Base::Wrapper>, but you will have to specify the C<configure_requires> yourself. =head2 Inline::C / Inline::CPP use Inline 0.56 with => 'Alien::Foo'; L<Inline::C> and L<Inline::CPP> can be configured to use an L<Alien::Base> based L<Alien> with the C<with> keyword. =head2 ExtUtils::Depends use ExtUtils::MakeMaker; use ExtUtils::Depends; my $pkg = ExtUtils::Depends->new("Alien::Foo"); WriteMakefile( ... $pkg->get_makefile_vars, ... ); L<ExtUtils::Depends> works similar to L<Alien::Base::Wrapper>, but uses the L<Inline> interface under the covers. =head2 Dist::Zilla [@Filter] -bundle = @Basic -remove = MakeMaker [Prereqs / ConfigureRequires] Alien::Foo = 0 [MakeMaker::Awesome] header = use Alien::Base::Wrapper qw( Alien::Foo !export ); WriteMakefile_arg = Alien::Base::Wrapper->mm_args =head2 FFI::Platypus use FFI::Platypus; use Alien::Foo; my $ffi = FFI::Platypus->new( lib => [ Alien::Foo->dynamic_libs ], ); Not all L<Alien>s provide dynamic libraries, but those that do can be used by L<FFI::Platypus>. Unlike an XS module, these need to be a regular run time prerequisite. =head2 Inline::C use Inline with => 'Alien::Foo'; use Inline C => <<~'END'; #include <foo.h> const char *my_foo_wrapper() { foo(); } END sub exported_foo() { my_foo_wrapper(); } =head2 tool use Alien::Foo; use Env qw( @PATH ); unshift @PATH, Alien::Foo->bin_dir; system 'foo', '--bar', '--baz'; Some L<Alien>s provide tools instead of or in addition to a library. You need to add them to the C<PATH> environment variable though. (Unless the tool is already provided by the system, in which case it is already in the path and the C<bin_dir> method will return an empty list). =head1 ENVIRONMENT =over 4 =item ALIEN_INSTALL_TYPE Although the recommended way for a consumer to use an L<Alien::Base> based L<Alien> is to declare it as a static configure and build-time dependency, some consumers may prefer to fallback on using an L<Alien> only when the consumer itself cannot detect the necessary package. In some cases the consumer may want the user to opt-in to using an L<Alien> before requiring it. To keep the interface consistent among Aliens, the consumer of the fallback opt-in L<Alien> may fallback on the L<Alien> if the environment variable C<ALIEN_INSTALL_TYPE> is set to any value. The rationale is that by setting this environment variable the user is aware that L<Alien> modules may be installed and have indicated consent. The actual implementation of this, by its nature would have to be in the consuming CPAN module. This behavior should be documented in the consumer's POD. See L<Alien::Build/ENVIRONMENT> for more details on the usage of this environment variable. =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Manual/Alien.pod 0000444 00000005345 14711220232 0012632 0 ustar 00 # PODNAME: Alien::Build::Manual::Alien # ABSTRACT: General alien author documentation # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Manual::Alien - General alien author documentation =head1 VERSION version 2.41 =head1 SYNOPSIS perldoc Alien::Build::Manual::Alien =head1 DESCRIPTION The goal of the L<Alien> namespace is to provide non-CPAN dependencies (so called "Alien" dependencies) for CPAN modules. The history and intent of this idea is documented in the documentation-only L<Alien> module. The C<Alien-Build> distribution provides a framework for building aliens. The intent is to fix bugs and enhance the interface of a number of common tools so that all aliens may benefit. The distribution is broken up into these parts: =over 4 =item The Alien Installer (configure / build-time) L<Alien::Build> and L<alienfile> are used to detect and install aliens. They are further documented in L<Alien::Build::Manual::AlienAuthor>. =item The Alien Runtime (runtime) L<Alien::Base> is the base class for aliens in the C<Alien-Build> system. Its use by Alien consumers is documented in L<Alien::Build::Manual::AlienUser>. =item The Plugin system (configure / build-time) Because many packages are implemented using different tools, the detection, build and install logic for a particular L<Alien> can vary a lot. As such, much of L<Alien::Build> is implemented as a series of plugins that inherit from L<Alien::Build::Plugin>. An overview of building your own plugins is documented in L<Alien::Build::Manual::PluginAuthor>. =back Additional useful documentation may be found here: =over 4 =item FAQ L<Alien::Build::Manual::FAQ> =item Contributing L<Alien::Build::Manual::Contributing> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Manual/Contributing.pod 0000444 00000021733 14711220233 0014251 0 ustar 00 # PODNAME: Alien::Build::Manual::Contributing # ABSTRACT: Over-detailed contributing guide # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Manual::Contributing - Over-detailed contributing guide =head1 VERSION version 2.41 =head1 SYNOPSIS perldoc Alien::Build::Manual::Contributing =head1 DESCRIPTION Thank you for considering to contribute to my open source project! If you have a small patch please consider just submitting it. Doing so through the project GitHub is probably the best way: L<https://github.com/plicease/Alien-Build/issues> If you have a more invasive enhancement or bugfix to contribute, please take the time to review these guidelines. In general it is good idea to work closely with the L<Alien::Build> developers, and the best way to contact them is on the C<#native> IRC channel on irc.perl.org. =head2 History Joel Berger wrote the original L<Alien::Base>. This distribution included the runtime code L<Alien::Base> and an installer class L<Alien::Base::ModuleBuild>. The significant thing about L<Alien::Base> was that it provided tools to make it relatively easy for people to roll their own L<Alien> distributions. Over time, the PerlAlien (github organization) or "Alien::Base team" has taken over development of L<Alien::Base> with myself (Graham Ollis) being responsible for integration and releases. Joel Berger is still involved in the project. Since the original development of L<Alien::Base>, L<Module::Build>, on which L<Alien::Base::ModuleBuild> is based, has been removed from the core of Perl. It seemed worthwhile to write a replacement installer that works with L<ExtUtils::MakeMaker> which IS still bundled with the Perl core. Because this is a significant undertaking it is my intention to integrate the many lessons learned by Joel Berger, myself and the "Alien::Base team" as possible. If the interface seems good then it is because I've stolen the ideas from some pretty good places. =head2 Philosophy =head3 Alien runtime should be as config-only as possible. Ideally the code for an L<Alien::Base> based L<Alien> should simply inherit from L<Alien::Base>, like so: package Alien::libfoo; use parent qw( Alien::Base ); 1; The detection logic should be done by the installer code (L<alienfile> and L<Alien::Build>) and saved into runtime properties (see L<Alien::Build/runtime_prop>). And as much as possible the runtime should be implemented in the base class (L<Alien::Base>). Where reasonable, the base class should be expanded to meet the needs of this arrangement. =head3 when downloading a package grab the latest version If the maintainer of an L<Alien> disappears for a while, and if the version downloaded during a "share" install is hardcoded in the L<alienfile>, it can be problematic for end-users. There are exceptions, of course, in particular when a package provides a very unstable interface from version to version it makes sense to hard code the version and for the Alien developer and Alien consumer developer to coordinate closely. =head3 when installing a package the operating system as a whole should not be affected The convenience of using an L<Alien> is that a user of a CPAN module that consumes an L<Alien> doesn't need to know the exact incantation to install the libraries on which it depends (or indeed it may not be easily installed through the package manager anyway). As a corollary, a user of a CPAN module that consumes an L<Alien> module shouldn't expect operating system level packages to be installed, or for these packages to be installed in common system level directories, like C</usr/local> or C</opt>. Instead a "share" directory associated with the Perl install and L<Alien> module should be used. Plugins that require user opt-in could be written to prompt a user to automatically install operating system packages, but this should never be done by default or without consent by the user. =head3 avoid dependencies One of the challenges with L<Alien> development is that you are by the nature of the problem, trying to make everyone happy. Developers working out of CPAN just want stuff to work, and some build environments can be hostile in terms of tool availability, so for reliability you end up pulling a lot of dependencies. On the other hand, operating system vendors who are building Perl modules usually want to use the system version of a library so that they do not have to patch libraries in multiple places. Such vendors have to package any extra dependencies and having to do so for packages that the don't even use makes them understandably unhappy. As general policy the L<Alien::Build> core should have as few dependencies as possible, and should only pull extra dependencies if they are needed. Where dependencies cannot be avoidable, popular and reliable CPAN modules, which are already available as packages in the major Linux vendors (Debian, Red Hat) should be preferred. As such L<Alien::Build> is hyper aggressive at using dynamic prerequisites. =head3 interface agnostic One of the challenges with L<Alien::Buil::ModuleBuild> was that L<Module::Build> was pulled from the core. In addition, there is a degree of hostility toward L<Module::Build> in some corners of the Perl community. I agree with Joel Berger's rationale for choosing L<Module::Build> at the time, as I believe its interface more easily lends itself to building L<Alien> distributions. That said, an important feature of L<Alien::Build> is that it is installer agnostic. Although it is initially designed to work with L<ExtUtils::MakeMaker>, it has been designed from the ground up to work with any installer (Perl, or otherwise). As an extension of this, although L<Alien::Build> may have external CPAN dependencies, they should not be exposed to developers USING L<Alien::Build>. As an example, L<Path::Tiny> is used heavily internally because it does what L<File::Spec> does, plus the things that it doesn't, and uses forward slashes on Windows (backslashes are the "correct separator on windows, but actually using them tends to break everything). However, there aren't any interfaces in L<Alien::Build> that will return a L<Path::Tiny> object (or if there are, then this is a bug). This means that if we ever need to port L<Alien::Build> to a platform that doesn't support L<Path::Tiny> (such as VMS), then it may require some work to L<Alien::Build> itself, modules that USE L<Alien::Build> shouldn't need to be modified. =head3 plugable The actual logic that probes the system, downloads source and builds it should be as pluggable as possible. One of the challenges with L<Alien::Build::ModuleBuild> was that it was designed to work well with software that works with C<autoconf> and C<pkg-config>. While you can build with other tools, you have to know a bit of how the installer logic works, and which hooks need to be tweaked. L<Alien::Build> has plugins for C<autoconf>, C<pkgconf> (successor of C<pkg-config>), vanilla Makefiles, and CMake. If your build system doesn't have a plugin, then all you have to do is write one! Plugins that prove their worth may be merged into the L<Alien::Build> core. Plugins that after a while feel like maybe not such a good idea may be removed from the core, or even from CPAN itself. In addition, L<Alien::Build> has a special type of plugin, called a negotiator which picks the best plugin for the particular environment that it is running in. This way, as development of the negotiator and plugins develop over time modules that use L<Alien::Build> will benefit, without having to change the way they interface with L<Alien::Build> =head1 ACKNOWLEDGEMENT I would like to that Joel Berger for getting things running in the first place. Also important to thank other members of the "Alien::Base team": Zaki Mughal (SIVOAIS) Ed J (ETJ, mohawk) Also kind thanks to all of the developers who have contributed to L<Alien::Base> over the years: L<https://metacpan.org/pod/Alien::Base#CONTRIBUTORS> =head1 SEE ALSO L<alienfile>, L<Alien::Build::MM>, L<Alien::Build::Plugin>, L<Alien::Base>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Manual/AlienAuthor.pod 0000444 00000060067 14711220233 0014020 0 ustar 00 # PODNAME: Alien::Build::Manual::AlienAuthor # ABSTRACT: Alien author documentation # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Manual::AlienAuthor - Alien author documentation =head1 VERSION version 2.41 =head1 SYNOPSIS perldoc Alien::Build::Manual::AlienAuthor =head1 DESCRIPTION B<Note>: Please read the entire document before you get started in writing your own L<alienfile>. The section on dynamic vs. static libraries will likely save you a lot of grief if you read it now! This document is intended to teach L<Alien> authors how to build their own L<Alien> distribution using L<Alien::Build> and L<Alien::Base>. Such an L<Alien> distribution consists of three essential parts: =over 4 =item An L<alienfile> This is a recipe for how to 1) detect an already installed version of the library or tool you are alienizing 2) download and build the library or tool that you are alienizing and 3) gather the configuration settings necessary for the use of that library or tool. =item An installer C<Makefile.PL> or C<Build.PL> or a C<dist.ini> if you are using L<Dist::Zilla> This is a thin layer between your L<alienfile> recipe, and the Perl installer (either L<ExtUtils::MakeMaker> or L<Module::Build>. =item A Perl class (.pm file) that inherits from L<Alien::Base> For most L<Alien>s this does not need to be customized at all, since L<Alien::Base> usually does what you need. =back For example if you were alienizing a library called libfoo, you might have these files: Alien-Libfoo-1.00/Makefile.PL Alien-Libfoo-1.00/alienfile Alien-Libfoo-1.00/lib/Alien/Libfoo.pm This document will focus mainly on instructing you how to construct an L<alienfile>, but we will also briefly cover making a simple C<Makefile.PL> or C<dist.ini> to go along with it. We will also touch on when you might want to extend your subclass to add non-standard functionality. =head2 Using commands Most software libraries and tools will come with instructions for how to install them in the form of commands that you are intended to type into a shell manually. The easiest way to automate those instructions is to just put the commands in your L<alienfile>. For example, lets suppose that libfoo is built using autoconf and provides a C<pkg-config> C<.pc> file. We will also later discuss plugins. For common build systems like autoconf or CMake, it is usually better to use the appropriate plugin because they will handle corner cases better than a simple set of commands. We're going to take a look at commands first because it's easier to understand the different phases with commands. (Aside, autoconf is a series of tools and macros used to configure (usually) a C or C++ library or tool by generating any number of Makefiles. It is the C equivalent to L<ExtUtils::MakeMaker>, if you will. Basically, if your library or tool instructions start with './configure' it is most likely an autoconf based library or tool). (Aside2, C<pkg-config> is a standard-ish way to provide the compiler and linker flags needed for compiling and linking against the library. If your tool installs a C<.pc> file, usually in C<$PREFIX/lib/pkgconfig> then, your tool uses C<pkg-config>). Here is the L<alienfile> that you might have: use alienfile; probe [ 'pkg-config --exists libfoo' ]; share { start_url 'http://www.libfoo.org/src/libfoo-1.00.tar.gz'; download [ 'wget %{.meta.start_url}' ]; extract [ 'tar zxf %{.install.download}' ]; build [ [ './configure --prefix=%{.install.prefix} --disable-shared' ], [ '%{make}' ], [ '%{make} install' ], ]; }; gather [ [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ], [ 'pkg-config --cflags libfoo', \'%{.runtime.cflags}' ], [ 'pkg-config --libs libfoo', \'%{.runtime.libs}' ], ]; There is a lot going on here, so lets decode it a little bit. An L<alienfile> is just some Perl with some alien specific sugar. The first line use alienfile; imports the sugar into the L<alienfile>. It also is a flag for the reader to see that this is an L<alienfile> and not some other kind of Perl script. The second line is the probe directive: probe [ 'pkg-config --exists libfoo' ]; is used to see if the library is already installed on the target system. If C<pkg-config> is in the path, and if libfoo is installed, this should exit with a success (0) and tell L<Alien::Build> to use the system library. If either C<pkg-config> in the PATH, or if libfoo is not installed, then it will exist with non-success (!= 0) and tells L<Alien::Build> to download and build from source. You can provide as many probe directives as you want. This is useful if there are different ways to probe for the system. L<Alien::Build> will stop on the first successfully found system library found. Say our library libfoo comes with a C<.pc> file for use with C<pkg-config> and also provides a C<foo-config> program to find the same values. You could then specify this in your L<alienfile> probe [ 'pkg-config --exists libfoo' ]; probe [ 'foo-config --version' ]; Other directives can be specified multiple times if there are different methods that can be tried for the various steps. Sometimes it is easier to probe for a library from Perl rather than with a command. For that you can use a code reference. For example, another way to call C<pkg-config> would be from Perl: probe sub { my($build) = @_; # $build is the Alien::Build instance. system 'pkg-config --exists libfoo'; $? == 0 ? 'system' : 'share'; }; The Perl code should return 'system' if the library is installed, and 'share' if not. (Other directives should return a true value on success, and a false value). You can also throw an exception with C<die> to indicate a failure. The next part of the L<alienfile> is the C<share> block, which is used to group the directives which are used to download and install the library or tool in the event that it is not already installed. share { start_url 'http://www.libfoo.org/src/libfoo-1.00.tar.gz'; download [ 'wget %{.meta.start_url}' ]; extract [ 'tar zxf %{.install.download}' ]; build [ [ './configure --prefix=%{.install.prefix} --disable-shared' ], [ '%{make}' ], [ '%{make} install' ], ]; }; The start_url specifies where to find the package that you are alienizing. It should be either a tarball (or zip file, or what have you) or an HTML index. The download directive as you might imagine specifies how to download the library or tool. The extract directive specifies how to extract the archive once it is downloaded. In the extract step, you can use the variable C<%{.install.download}> as a placeholder for the archive that was downloaded in the download step. This is also accessible if you use a code reference from the L<Alien::Build> instance: share { ... requires 'Archive::Extract'; extract sub { my($build) = @_; my $tarball = $build->install_prop->{download}; my $ae = Archive::Extract->new( archive => $tarball ); $ae->extract; 1; } ... }; The build directive specifies how to build the library or tool once it has been downloaded and extracted. Note the special variable C<%{.install.prefix}> is the location where the library should be installed. C<%{make}> is a helper which will be replaced by the appropriate C<make>, which may be called something different on some platforms (on Windows for example, it frequently may be called C<nmake> or C<dmake>). The final part of the L<alienfile> has a gather directive which specifies how to get the details on how to compile and link against the library. For this, once again we use the C<pkg-config> command: gather [ [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ], [ 'pkg-config --cflags libfoo', \'%{.runtime.cflags}' ], [ 'pkg-config --libs libfoo', \'%{.runtime.libs}' ], ]; The scalar reference as the final item in the command list tells L<Alien::Build> that the output from the command should be stored in the given variable. The runtime variables are the ones that will be available to C<Alien::Libfoo> once it is installed. (Install properties, which are the ones that we have seen up till now are thrown away once the L<Alien> distribution is installed. You can also provide a C<sys> block for directives that should be used when a system install is detected. Normally you only need to do this if the gather step is different between share and system installs. For example, the above is equivalent to: build { ... gather [ [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ], [ 'pkg-config --cflags libfoo', \'%{.runtime.cflags}' ], [ 'pkg-config --libs libfoo', \'%{.runtime.libs}' ], ]; }; sys { gather [ [ 'pkg-config --modversion libfoo', \'%{.runtime.version}' ], [ 'pkg-config --cflags libfoo', \'%{.runtime.cflags}' ], [ 'pkg-config --libs libfoo', \'%{.runtime.libs}' ], ]; }; (Aside3, the reason it is called C<sys> and not C<system> is so that it does not conflict with the built in C<system> function)! =head2 Using plugins The first example is a good way of showing the full manual path that you can choose, but there is a lot of repetition, if you are doing many L<Alien>s that use autoconf and C<pkg-config> (which are quite common. L<alienfile> allows you to use plugins. See L<Alien::Build::Plugin> for a list of some of the plugin categories. For now, I will just show you how to write the L<alienfile> for libfoo above using L<Alien::Build::Plugin::Build::Autoconf>, L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build::Plugin::Download::Negotiate>, and L<Alien::Build::Plugin::Extract::Negotiate> use alienfile; plugin 'PkgConfig' => ( pkg_name => 'libfoo', ); share { start_url 'http://www.libfoo.org/src'; plugin 'Download' => ( filter => qr/^libfoo-[0-9\.]+\.tar\.gz$/, version => qr/^libfoo-([0-9\.]+)\.tar\.gz$/, ); plugin 'Extract' => 'tar.gz'; plugin 'Build::Autoconf'; build [ '%{configure} --disable-shared', '%{make}', '%{make} install', ]; }; The first plugin that we use is the C<pkg-config> negotiation plugin. A negotiation plugin is one which doesn't do the actual work but selects the best one from a set of plugins depending on your platform and environment. (In the case of L<Alien::Build::Plugin::PkgConfig::Negotiate>, it may choose to use command line tools, a pure Perl implementation (L<PkgConfig>), or libpkgconf, depending on what is available). When using negotiation plugins you may omit the C<::Negotiate> suffix. So as you can see using the plugin here is an advantage because it is more reliable than just specifying a command which may not be installed! Next we use the download negotiation plugin. This is also better than the version above, because again, C<wget> my not be installed on the target system. Also you can specify a URL which will be scanned for links, and use the most recent version. We use the Extract negotiation plugin to use either command line tools, or Perl libraries to extract from the archive once it is downloaded. Finally we use the Autoconf plugin (L<Alien::Build::Plugin::Build::Autoconf>). This is a lot more sophisticated and reliable than in the previous example, for a number of reasons. This version will even work on Windows assuming the library or tool you are alienizing supports that platform! Strictly speaking the build directive is not necessary, because the autoconf plugin provides a default which is reasonable. The only reason that you would want to include it is if you need to provide additional flags to the configure step. share { ... build [ '%{configure} --enable-bar --enable-baz --disable-shared', '%{make}', '%{make} install', ]; }; =head2 A note about dynamic vs. static libraries If you are using your L<Alien> to build an XS module, it is important that you use static libraries if possible. If you have a package that refuses to build a static library, then you can use L<Alien::Role::Dino>. Actually let me back up a minute. For a C<share> install it is best to use static libraries to build your XS extension. This is because if your L<Alien> is ever upgraded to a new version it can break your existing XS modules. For a C<system> install shared libraries are usually best because you can often get security patches without having to re-build anything in perl land. If you looked closely at the "Using commands" and "Using plugins" sections above, you may notice that we went out of our way where possible to tell Autotools to build only static libraries using the C<--disable-shared> command. The Autoconf plugin also does this by default. Sometimes though you will have a package that builds both, or maybe you I<want> both static and dynamic libraries to work with XS and FFI. For that case, there is the L<Alien::Build::Plugin::Gather::IsolateDynamic> plugin. use alienfile; ... plugin 'Gather::IsolateDynamic'; What it does, is that it moves the dynamic libraries (usually .so on Unix and .DLL on Windows) to a place where they can be found by FFI, and where they won't be used by the compiler for building XS. It usually doesn't do any harm to include this plugin, so if you are just starting out you might want to add it anyway. Arguably it should have been the default behavior from the beginning. If you have already published an Alien that does not isolate its dynamic libraries, then you might get some fails from old upgraded aliens because the share directory isn't cleaned up by default (this is perhaps a design bug in the way that share directories work, but it is a long standing characteristic). One work around for this is to use the C<clean_install> property on L<Alien::Build::MM>, which will clean out the share directory on upgrade, and possibly save you a lot of grief. =head2 Verifying and debugging your alienfile You could feed your alienfile directly into L<Alien::Build>, or L<Alien::Build::MM>, but it is sometimes useful to test your alienfile using the C<af> command (it does not come with L<Alien::Build>, you need to install L<App::af>). By default C<af> will use the C<alienfile> in the current directory (just as C<make> uses the C<Makefile> in the current directory; just like C<make> you can use the C<-f> option to specify a different L<alienfile>). You can test your L<alienfile> in dry run mode: % af install --dry-run Alien::Build::Plugin::Core::Legacy> adding legacy hash to config Alien::Build::Plugin::Core::Gather> mkdir -p /tmp/I2YXRyxb0r/_alien --- cflags: '' cflags_static: '' install_type: system legacy: finished_installing: 1 install_type: system name: libfoo original_prefix: /tmp/7RtAusykNN version: 1.2.3 libs: '-lfoo ' libs_static: '-lfoo ' prefix: /tmp/7RtAusykNN version: 1.2.3 You can use the C<--type> option to force a share install (download and build from source): % af install --type=share --dry-run Alien::Build::Plugin::Core::Download> decoding html Alien::Build::Plugin::Core::Download> candidate *https://www.libfoo.org/download/libfoo-1.2.4.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.3.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.2.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.1.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.0.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.1.9.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.1.8.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.1.7.tar.gz Alien::Build::Plugin::Core::Download> candidate ... Alien::Build::Plugin::Core::Download> setting version based on archive to 1.2.4 Alien::Build::Plugin::Core::Download> downloaded libfoo-1.2.4.tar.gz Alien::Build::CommandSequence> + ./configure --prefix=/tmp/P22WEXj80r --with-pic --disable-shared ... snip ... Alien::Build::Plugin::Core::Gather> mkdir -p /tmp/WsoLAQ889w/_alien --- cflags: '' cflags_static: '' install_type: share legacy: finished_installing: 1 install_type: share original_prefix: /tmp/P22WEXj80r version: 1.2.4 libs: '-L/tmp/P22WEXj80r/lib -lfoo ' libs_static: '-L/tmp/P22WEXj80r/lib -lfoo ' prefix: /tmp/P22WEXj80r version: 1.2.4 You can also use the C<--before> and C<--after> options to take a peek at what the build environment looks like at different stages as well, which can sometimes be useful: % af install --dry-run --type=share --before build bash Alien::Build::Plugin::Core::Download> decoding html Alien::Build::Plugin::Core::Download> candidate *https://www.libfoo.org/download/libfoo-1.2.4.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.3.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.2.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.1.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.2.0.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.1.9.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.1.8.tar.gz Alien::Build::Plugin::Core::Download> candidate https://www.libfoo.org/download/libfoo-1.1.7.tar.gz Alien::Build::Plugin::Core::Download> candidate ... Alien::Build::Plugin::Core::Download> setting version based on archive to 1.2.4 Alien::Build::Plugin::Core::Download> downloaded libfoo-1.2.4.tar.gz App::af::install> [ before build ] + bash /tmp/fbVPu4LRTs/build_5AVn/libfoo-1.2.4$ ls CHANGES Makefile autoconf.ac lib /tmp/fbVPu4LRTs/build_5AVn/libfoo-1.2.4$ There are a lot of other useful things that you can do with the C<af> command. See L<af> for details. =head2 Integrating with MakeMaker Once you have a working L<alienfile> you can write your C<Makefile.PL>. use ExtUtils::MakeMaker; use Alien::Build::MM; my $abmm = Alien::Build::MM->new; WriteMakefile($abmm->mm_args( ABSTRACT => 'Discover or download and install libfoo', DISTNAME => 'Alien-Libfoo', NAME => 'Alien::Libfoo', VERSION_FROM => 'lib/Alien/Libfoo.pm', CONFIGURE_REQUIRES => { 'Alien::Build::MM' => 0, }, BUILD_REQUIRES => { 'Alien::Build::MM' => 0, }, PREREQ_PM => { 'Alien::Base' => 0, }, # If you are going to write the recommended # tests you will will want these: TEST_REQUIRES => { 'Test::Alien' => 0, 'Test2::V0' => 0, }, )); sub MY::postamble { $abmm->mm_postamble; } The C<lib/Alien/Libfoo.pm> that goes along with it is very simple: package Alien::Libfoo; use strict; use warnings; use parent qw( Alien::Base ); 1; You are done and can install it normally: % perl Makefile.PL % make % make test % make install =head2 Integrating with Module::Build Please don't! Okay if you have to there is L<Alien::Build::MB>. =head2 Non standard configuration L<Alien::Base> support most of the things that your L<Alien> will need, like compiler flags (cflags), linker flags (libs) and binary directory (bin_dir). Your library or tool may have other configuration items which are not supported by default. You can store the values in the L<alienfile> into the runtime properties: gather [ # standard: [ 'foo-config --version libfoo', \'%{.runtime.version}' ], [ 'foo-config --cflags libfoo', \'%{.runtime.cflags}' ], [ 'foo-config --libs libfoo', \'%{.runtime.libs}' ], # non-standard [ 'foo-config --bar-baz libfoo', \'%{.runtime.bar_baz}' ], ]; then you can expose them in your L<Alien::Base> subclass: package Alien::Libfoo; use strict; use warnings; use parent qw( Alien::Base ); sub bar_baz { my($self) = @_; $self->runtime_prop->{bar_baz}, }; 1; =head2 Testing (optional, but highly recommended) You should write a test using L<Test::Alien> to make sure that your alien will work with any XS modules that are going to use it: use Test2::V0; use Test::Alien; use Alien::Libfoo; alien_ok 'Alien::Libfoo'; xs_ok do { local $/; <DATA> }, with_subtest { is Foo::something(), 1, 'Foo::something() returns 1'; }; done_testing; __DATA__ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include <foo.h> MODULE = Foo PACKAGE = Foo int something() You can also use L<Test::Alien> to test tools instead of libraries: use Test2::V0; use Test::Alien; use Alien::Libfoo; alien_ok 'Alien::Libfoo'; run_ok(['foo', '--version']) ->exit_is(0); done_testing; You can also write tests specifically for L<FFI::Platypus>, if your alien is going to be used to write FFI bindings. (the test below is the FFI equivalent to the XS example above). use Test2::V0; use Test::Alien; use Alien::Libfoo; alien_ok 'Alien::Libfoo'; ffi_ok { symbols => [ 'something' ] }, with_subtest { # $ffi is an instance of FFI::Platypus with the lib # set appropriately. my($ffi) = @_; my $something = $ffi->function( something => [] => 'int' ); is $something->call(), 1, 'Foo::something() returns 1'; }; If you do use C<ffi_ok> you want to make sure that your alien reliably produces dynamic libraries. If it isn't consistent (if for example some platforms tend not to provide or build dynamic libraries), you can check that C<dynamic_libs> doesn't return an empty list. ... alien_ok 'Alien::Libfoo'; SKIP: { skip "This test requires a dynamic library" unless Alien::Libfoo->dynamic_libs; ffi_ok { symbols [ 'something' ] }, with_subtest { ... }; } More details on testing L<Alien> modules can be found in the L<Test::Alien> documentation. You can also run the tests that come with the package that you are alienizing, by using a C<test> block in your L<alienfile>. Keep in mind that some packages use testing tools or have other prerequisites that will not be available on your users machines when they attempt to install your alien. So you do not want to blindly add a test block without checking what the prereqs are. For Autoconf style packages you typically test a package using the C<make check> command: use alienfile; plugin 'PkgConfig' => 'libfoo'; share { ... # standard build steps. test [ '%{make} check' ]; }; =head2 Dist::Zilla (optional, mildly recommended) You can also use the L<Alien::Build> L<Dist::Zilla> plugin L<Dist::Zilla::Plugin::AlienBuild>: name = Alien-Libfoo author = E. Xavier Ample <example@cpan.org> license = Perl_5 copyright_holder = E. Xavier Ample <example@cpan.org> copyright_year = 2017 version = 0.01 [@Basic] [AlienBuild] The plugin takes care of a lot of details like making sure that the correct minimum versions of L<Alien::Build> and L<Alien::Base> are used. See the plugin documentation for additional details. =head2 Using your Alien Once you have installed you can use your Alien. See L<Alien::Build::Manual::AlienUser> for guidance on that. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Manual/PluginAuthor.pod 0000444 00000030733 14711220235 0014225 0 ustar 00 # PODNAME: Alien::Build::Manual::PluginAuthor # ABSTRACT: Alien::Build plugin author documentation # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Manual::PluginAuthor - Alien::Build plugin author documentation =head1 VERSION version 2.41 =head1 SYNOPSIS your plugin: package Alien::Build::Plugin::Build::MyPlugin; use strict; use warnings; use Alien::Build::Plugin; has arg1 => 'default_for arg1'; has arg2 => sub { [ 'default', 'for', 'arg2' ] }; sub init { my($self, $meta) = @_; ... } 1; and then from L<alienfile>: use alienfile; plugin 'Build::MyPlugin' => ( arg1 => 'override for arg1', arg2 => [ 'something', 'else' ], ); =head1 DESCRIPTION This document explains how to write L<Alien::Build> plugins using the L<Alien::Build::Plugin> base class. Plugins use L<Alien::Build::Plugin>, which sets the appropriate base class, and provides you with the C<has> property builder. C<has> takes two arguments, the name of the property and the default value. (As with L<Moose> and L<Moo>, you should use a code reference to specify default values for non-string defaults). The only method that you need to implement is C<init>. From this method you can add hooks to change the behavior of the L<alienfile> recipe. sub init { my($self, $meta) = @_; $meta->register_hook( probe => sub { my($build) = @_; if( ... ) { return 'system'; } else { return 'share'; } }, ); } Hooks get the L<Alien::Build> instance as their first argument, and depending on the hook may get additional arguments. You can also modify hooks using C<before_hook>, C<around_hook> and C<after_hook>: sub init { my($self, $meta) = @_; $meta->before_hook( build => sub { my($build) = @_; $build->log('this runs before the build'); }, ); $meta->after_hook( build => sub { my($build) = @_; $build->log('this runs after the build'); }, ); $meta->around_hook( build => sub { my $orig = shift; # around hooks are useful for setting environment variables local $ENV{CPPFLAGS} = '-I/foo/include'; $orig->(@_); }, ); } You can and should write tests for your plugin. The best way to do this is using L<Test::Alien::Build>, which allows you to write an inline L<alienfile> in your test. use Test::V0; use Test::Alien::Build; my $build = alienfile_ok q{ use alienfile; plugin 'Build::MyPlugin' => ( arg1 => 'override for arg1', arg2 => [ 'something', 'else' ], ); ... }; # you can interrogate $build, it is an instance of L<Alien::Build>. my $alien = alien_build_ok; # you can interrogate $alien, it is an instance of L<Alien::Base>. =head1 HOOKS =head2 probe hook $meta->register_hook( probe => sub { my($build) = @_; return 'system' if ...; # system install return 'share'; # otherwise }); $meta->register_hook( probe => [ $command ] ); This hook should return the string C<system> if the operating system provides the library or tool. It should return C<share> otherwise. You can also use a command that returns true when the tool or library is available. For example for use with C<pkg-config>: $meta->register_hook( probe => [ '%{pkgconf} --exists libfoo' ] ); Or if you needed a minimum version: $meta->register_hook( probe => [ '%{pkgconf} --atleast-version=1.00 libfoo' ] ); Note that this hook SHOULD NOT gather system properties, such as cflags, libs, versions, etc, because the probe hook will be skipped in the event the environment variable C<ALIEN_INSTALL_TYPE> is set. The detection of these properties should instead be done by the C<gather_system> hook, below. =head2 gather_system hook $meta->register_hook( gather_system => sub { my($build) = @_; $build->runtime_prop->{cflags} = ...; $build->runtime_prop->{libs} = ...; $build->runtime_prop->{version} = ...; }); This hook is called for a system install to determine the properties necessary for using the library or tool. These properties should be stored in the C<runtime_prop> hash as shown above. Typical properties that are needed for libraries are cflags and libs. If at all possible you should also try to determine the version of the library or tool. =head2 download hook $meta->register_hook( download => sub { my($build) = @_; ... }); This hook is used to download from the internet the source. Either as an archive (like tar, zip, etc), or as a directory of files (git clone, etc). When the hook is called, the current working directory will be a new empty directory, so you can save the download to the current directory. If you store a single file in the directory, L<Alien::Build> will assume that it is an archive, which will be processed by the extract hook below. If you store multiple files, L<Alien::Build> will assume the current directory is the source root. If no files are stored at all, an exception with an appropriate diagnostic will be thrown. B<Note>: If you register this hook, then the fetch, decode and prefer hooks will NOT be called. =head2 fetch hook package Alien::Build::Plugin::MyPlugin; use strict; use warnings; use Alien::Build::Plugin; use Carp (); has '+url' => sub { Carp::croak "url is required property" }; sub init { my($self, $meta) = @_; $meta->register_hook( fetch => sub { my($build, $url, %options) = @_; ... } } 1; Used to fetch a resource. The first time it will be called without an argument (or with C<$url> set to C<undef>, so the configuration used to find the resource should be specified by the plugin's properties. On subsequent calls the first argument will be a URL. The C<%options> hash may contain these options: =over 4 =item http_headers HTTP request headers, if an appropriate protocol is being used. The headers are provided as an array reference of key/value pairs, which allows for duplicate header keys with multiple values. If a non-HTTP protocol is used, or if the plugin cannot otherwise send HTTP request headers, the plugin SHOULD issue a warning using the C<< $build->log >> method, but because this option wasn't part of the original spec, the plugin MAY no issue that warning while ignoring it. =back Note that versions of L<Alien::Build> prior to 2.39 did not pass the options hash into the fetch plugin. Normally the first fetch will be to either a file or a directory listing. If it is a file then the content should be returned as a hash reference with the following keys: # content of file stored in Perl return { type => 'file', filename => $filename, content => $content, version => $version, # optional, if known }; # content of file stored in the filesystem return { type => 'file', filename => $filename, path => $path, # full file system path to file version => $version, # optional, if known tmp => $tmp, # optional }; C<$tmp> if set will indicate if the file is temporary or not, and can be used by L<Alien::Build> to save a copy in some cases. The default is true, so L<Alien::Build> assumes the file or directory is temporary if you don't tell it otherwise. If the URL points to a directory listing you should return it as either a hash reference containing a list of files: return { type => 'list', list => [ # filename: each filename should be just the # filename portion, no path or url. # url: each url should be the complete url # needed to fetch the file. # version: OPTIONAL, may be provided by some fetch or prefer { filename => $filename1, url => $url1, version => $version1 }, { filename => $filename2, url => $url2, version => $version2 }, ] }; or if the listing is in HTML format as a hash reference containing the HTML information: return { type => 'html', charset => $charset, # optional base => $base, # the base URL: used for computing relative URLs content => $content, # the HTML content }; or a directory listing (usually produced by ftp servers) as a hash reference: return { type => 'dir_listing', base => $base, content => $content, }; =head2 decode hook sub init { my($self, $meta) = @_; $meta->register_hook( decode => sub { my($build, $res) = @_; ... } } This hook takes a response hash reference from the C<fetch> hook above with a type of C<html> or C<dir_listing> and converts it into a response hash reference of type C<list>. In short it takes an HTML or FTP file listing response from a fetch hook and converts it into a list of filenames and links that can be used by the prefer hook to choose the correct file to download. See C<fetch> for the specification of the input and response hash references. =head2 prefer hook sub init { my($self, $meta) = @_; $meta->register_hook( prefer => sub { my($build, $res) = @_; return { type => 'list', list => [sort @{ $res->{list} }], }; } } This hook sorts candidates from a listing generated from either the C<fetch> or C<decode> hooks. It should return a new list hash reference with the candidates sorted from best to worst. It may also remove candidates that are totally unacceptable. =head2 extract hook $meta->register_hook( extract => sub { my($build, $archive) = @_; ... }); =head2 patch hook $meta->register_hook( patch => sub { my($build) = @_; ... }); This hook is completely optional. If registered, it will be triggered after extraction and before build. It allows you to apply any patches or make any modifications to the source if they are necessary. =head2 patch_ffi hook $meta->register_hook( patch_ffi => sub { my($build) = @_; ... }); This hook is exactly like the C<patch> hook, except it fires only on an FFI build. =head2 build hook $meta->register_hook( build => sub { my($build) = @_; ... }); This does the main build of the alienized project and installs it into the staging area. The current directory is the build root. You need to run whatever tools are necessary for the project, and install them into C<%{.install.prefix}>. =head2 build_ffi hook $meta->register_hook( build_ffi => sub { my($build) = @_; ... }); This is the same as C<build>, except it fires only on a FFI build. =head2 gather_share hook $meta->register_hook( gather_share => sub { my($build) = @_; ... }); This is the same as C<gather_system>, except it fires after a C<share> install. =head2 gather_ffi hook $meta->register_hook( gather_ffi => sub { my($build) = @_; ... }); This is the same as C<gather_share>, except it fires after a C<share> FFI install. =head2 override hook $meta->register_hook( override => sub { my($build) = @_; }); This allows you to alter the override logic. It should return one of C<share>, C<system>, C<default> or C<''>. The default implementation is just this: return $ENV{ALIEN_INSTALL_TYPE} || ''; =head2 clean_install $meta->register_hook( clean_install => sub { my($build) = @_; }); This hook allows you to remove files from the final install location before the files are installed by the installer layer (examples: L<Alien::Build::MM>, L<Alien::Build::MB> or L<App::af>). This hook is never called by default, and must be enabled via the interface to the installer layer. This hook SHOULD NOT remove the C<_alien> directory or its content from the install location. The default implementation removes all the files EXCEPT the C<_alien> directory and its content. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Manual/FAQ.pod 0000444 00000043761 14711220236 0012221 0 ustar 00 # PODNAME: Alien::Build::Manual::FAQ # ABSTRACT: Frequently Asked Questions about Alien::Build # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Manual::FAQ - Frequently Asked Questions about Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS perldoc Alien::Build::Manual::FAQ =head1 DESCRIPTION This document serves to answer the most frequently asked questions made by developers creating L<Alien> modules using L<Alien::Build>. =head1 QUESTIONS =head2 What is Alien, Alien::Base and Alien::Build? Alien in a Perl namespace for defining dependencies in CPAN for libraries and tools which are not "native" to CPAN. For a manifesto style description of the Why, and How see L<Alien>. L<Alien::Base> is a base class for the L<Alien> runtime. L<Alien::Build> is a tool for probing the operating system for existing libraries and tools, and downloading, building and installing packages. L<alienfile> is a recipe format for describing how to probe, download, build and install a package. =head2 How do I build a package that uses I<build system> =head3 autoconf Use the autoconf plugin (L<Alien::Build::Plugin::Build::Autoconf>). If your package provides a pkg-config C<.pc> file, then you can also use the PkgConfig plugin (L<Alien::Build::Plugin::PkgConfig::Negotiate>). use alienfile plugin PkgConfig => 'libfoo'; share { start_url => 'http://example.org/dist'; plugin Download => ( version => qr/libfoo-([0-9\.])\.tar\.gz$/, ); plugin Extract => 'tar.gz'; plugin 'Build::Autoconf'; }; If you need to provide custom flags to configure, you can do that too: share { plugin 'Build::Autoconf'; build [ '%{configure} --disable-shared --enable-foo', '%{make}', '%{make} install', ]; }; If your package requires GNU Make, use C<%{gmake}> instead of C<%{make}>. =head3 autoconf-like If you see an error like this: Unknown option "--with-pic". It is because the autoconf plugin uses the C<--with-pic> option by default, since it makes sense most of the time, and autoconf usually ignores options that it does not recognize. Some autoconf style build systems fail when they see an option that they do not recognize. You can turn this behavior off for these packages: plugin 'Build::Autoconf' => ( with_pic => 0, ); Another thing about the autoconf plugin is that it uses C<DESTDIR> to do a double staged install. If you see an error like "nothing was installed into destdir", that means that your package does not support C<DESTDIR>. You should instead use the MSYS plugin and use a command sequence to do the build like this: share { plugin 'Build::MSYS'; build [ # explicitly running configure with "sh" will make sure that # it works on windows as well as UNIX. 'sh configure --prefix=%{.install.prefix} --disable-shared', '%{make}', '%{make} install', ]; }; =head3 CMake There is an alien L<Alien::cmake3> that provides C<cmake> 3.x or better (It is preferred to the older L<Alien::CMake>). Though it is recommended that you use the C<cmake> (L<Alien::Build::Plugin::Build::CMake>) plugin instead of using L<Alien::cmake3>. use alienfile; share { plugin 'Build::CMake'; build [ # this is the default build step, if you do not specify one. [ '%{cmake}', @{ meta->prop->{plugin_build_cmake}->{args} }, # ... put extra cmake args here ... '.' ], '%{make}', '%{make} install', ]; }; =head3 vanilla Makefiles L<Alien::Build> provides a helper (C<%{make}>) for the C<make> that is used by Perl and L<ExtUtils::MakeMaker> (EUMM). Unfortunately the C<make> supported by Perl and EUMM on Windows (C<nmake> and C<dmake>) are not widely supported by most open source projects. (Thankfully recent perls and EUMM support GNU Make on windows now). You can use the C<make> plugin (L<Alien::Build::Plugin::Build::Make>) to tell the L<Alien::Build> system which make the project that you are alienizing requires. plugin 'Build::Make' => 'umake'; # umake makes %{make} either GNU Make or BSD Make on Unix and GNU Make on Windows. build { build [ # You can use the Perl config compiler and cflags using the %{perl.config...} helper [ '%{make}', 'CC=%{perl.config.cc}', 'CFLAGS=%{perl.config.cccdlflags} %{perl.config.optimize}' ], [ '%{make}', 'install', 'PREFIX=%{.install.prefix}' ], ], }; Some open source projects require GNU Make, and you can specify that, and L<Alien::gmake> will be pulled in on platforms that do not already have it. plugin 'Build::Make' => 'gmake'; ... =head2 How do I probe for a package that uses pkg-config Use the C<pkg-config> plugin (L<Alien::Build::Plugin::PkgConfig::Negotiate>): use alienfile; plugin 'PkgConfig' => ( pkg_name => 'libfoo', ); It will probe for a system version of the library. It will also add the appropriate C<version> C<cflags> and C<libs> properties on either a C<system> or C<share> install. =head2 How do I specify a minimum or exact version requirement for packages that use pkg-config? The various pkg-config plugins all support atleast_version, exact_version and maximum_version fields, which have the same meaning as the C<pkg-config> command line interface: use alienfile; plugin 'PkgConfig', pkg_name => foo, atleast_version => '1.2.3'; or use alienfile; plugin 'PkgConfig', pkg_name => foo, exact_version => '1.2.3'; =head2 How to create an Alien module for packages that do not support pkg-config? =head3 Packages that provide a configuration script Many packages provide a command that you can use to get the appropriate version, compiler and linker flags. For those packages you can just use the commands in your L<alienfile>. Something like this: use alienfile; probe [ 'foo-config --version' ]; share { ... build [ '%{make} PREFIX=%{.runtime.prefix}', '%{make} install PREFIX=%{.runtime.prefix}', ]; }; gather [ [ 'foo-config', '--version', \'%{.runtime.version}' ], [ 'foo-config', '--cflags', \'%{.runtime.cflags}' ], [ 'foo-config', '--libs', \'%{.runtime.libs}' ], ]; =head3 Packages that require a compile test Some packages just expect you do know that C<-lfoo> will work. For those you can use the C<cbuilder> plugin (L<Alien::Build::Plugin::Probe::CBuilder>). use alienfile; plugin 'Probe::CBuilder' => ( cflags => '-I/opt/libfoo/include', libs => '-L/opt/libfoo/lib -lfoo', ); share { ... gather sub { my($build) = @_; my $prefix = $build->runtime_prop->{prefix}; $build->runtime_prop->{cflags} = "-I$prefix/include "; $build->runtime_prop->{libs} = "-L$prefix/lib -lfoo "; }; } This plugin will build a small program with these flags and test that it works. (There are also options to provide a program that can make simple tests to ensure the library works). If the probe works, it will set the compiler and linker flags. (There are also options for extracting the version from the test program). If you do a share install you will need to set the compiler and linker flags yourself in the gather step, if you aren't using a build plugin that will do that for you. =head2 Can/Should I write a tool oriented Alien module? Certainly. The original intent was to provide libraries, but tools are also quite doable using the L<Alien::Build> toolset. A good example of how to do this is L<Alien::nasm>. You will want to use the 'Probe::CommandLine': use alienfile; plugin 'Probe::CommandLine' => ( command => 'gzip', ); =head2 How do I test my package once it is built (before it is installed)? Use L<Test::Alien>. It has extensive documentation, and integrates nicely with L<Alien::Base>. =head2 How do I patch packages that need alterations? If you have a diff file you can use patch: use alienfile; probe sub { 'share' }; # replace with appropriate probe share { ... patch [ '%{patch} -p1 < %{.install.patch}/mypatch.diff' ]; build [ ... ] ; } ... You can also patch using Perl if that is easier: use alienfile; probe sub { 'share' }; share { ... patch sub { my($build) = @_; # make changes to source prior to build }; build [ ... ]; }; =head2 The flags that a plugin produces are wrong! Sometimes, the compiler or linker flags that the PkgConfig plugin comes up with are not quite right. (Frequently this is actually because a package maintainer is providing a broken C<.pc> file). (Other plugins may also have problems). You could replace the plugin's C<gather> step but a better way is to provide a subroutine callback to be called after the gather stage is complete. You can do this with the L<alienfile> C<after> directive: use alienfile; plugin 'PkgConfig' => 'libfoo'; share { ... after 'gather' => sub { my($build) = @_; $build->runtime_prop->{libs} .= " -lbar"; # libfoo also requires libbar $build->runtime_prop->{libs_static} .= " -lbar -lbaz"; # libfoo also requires libbaz under static linkage }; }; Sometimes you only need to do this on certain platforms. You can adjust the logic based on C<$^O> appropriately. use alienfile; plugin 'PkgConfig' => 'libfoo'; share { ... after 'gather' => sub { my($build) = @_; if($^O eq 'MSWin32') { $build->runtime_prop->{libs} .= " -lpsapi"; } }; }; =head2 "cannot open shared object file" trying to load XS The error looks something like this: t/acme_alien_dontpanic2.t ....... 1/? # Failed test 'xs' # at t/acme_alien_dontpanic2.t line 13. # XSLoader failed # Can't load '/home/cip/.cpanm/work/1581635869.456/Acme-Alien-DontPanic2-2.0401/_alien/tmp/test-alien-lyiQNX/auto/Test/Alien/XS/Mod0/Mod0.so' for module Test::Alien::XS::Mod0: libdontpanic.so.0: cannot open shared object file: No such file or directory at /opt/perl/5.30.1/lib/5.30.1/x86_64-linux/DynaLoader.pm line 193. # at /home/cip/perl5/lib/perl5/Test/Alien.pm line 414. # Compilation failed in require at /home/cip/perl5/lib/perl5/Test/Alien.pm line 414. # BEGIN failed--compilation aborted at /home/cip/perl5/lib/perl5/Test/Alien.pm line 414. t/acme_alien_dontpanic2.t ....... Dubious, test returned 1 (wstat 256, 0x100) Failed 1/6 subtests t/acme_alien_dontpanic2__ffi.t .. ok This error happened at test time for the Alien, but depending on your environment and Alien it might happen later and the actual diagnostic wording might vary. This is usually because your XS or Alien tries to use dynamic libraries instead of static ones. Please consult the section about dynamic vs. static libraries in L<Alien::Build::Manual::AlienAuthor>. The TL;DR is that L<Alien::Build::Plugin::Gather::IsolateDynamic> might help. If you are the Alien author and the package you are alienizing doesn't have a static option you can use L<Alien::Role::Dino>, but please note the extended set of caveats! =head2 599 Internal Exception errors downloading packages from the internet Alien::Build::Plugin::Fetch::HTTPTiny> 599 Internal Exception fetching http://dist.libuv.org/dist/v1.15.0 Alien::Build::Plugin::Fetch::HTTPTiny> exception: IO::Socket::SSL 1.42 must be installed for https support Alien::Build::Plugin::Fetch::HTTPTiny> exception: Net::SSLeay 1.49 must be installed for https support Alien::Build::Plugin::Fetch::HTTPTiny> An attempt at a SSL URL https was made, but your HTTP::Tiny does not appear to be able to use https. Alien::Build::Plugin::Fetch::HTTPTiny> Please see: https://metacpan.org/pod/Alien::Build::Manual::FAQ#599-Internal-Exception-errors-downloading-packages-from-the-internet error fetching http://dist.libuv.org/dist/v1.15.0: 599 Internal Exception at /Users/ollisg/.perlbrew/libs/perl-5.26.0@test1/lib/perl5/Alien/Build/Plugin/Fetch/HTTPTiny.pm line 68. (Older versions of L<Alien::Build> produced a less verbose more confusing version of this diagnostic). TL;DR, instead of this: share { start_url => 'http://example.org/dist'; ... }; do this: share { start_url => 'https://example.org/dist'; }; If the website is going to redirect to a secure URL anyway. The "599 Internal Exception" indicates an "internal" exception from L<HTTP::Tiny> and is not a real HTTP status code or error. This could mean a number of different problems, but most frequently indicates that a SSL request was made without the required modules (L<Net::SSLeay> and L<IO::Socket::SSL>). Normally the L<Alien::Build::Plugin::Download::Negotiate> and L<Alien::Build::Plugin::Fetch::HTTPTiny> will make sure that the appropriate modules are added to your prerequisites for you if you specify a C<https> URL. Some websites allow an initial request from C<http> but then redirect to C<https>. If you can it is better to specify C<https>, if you cannot, then you can instead use the C<ssl> property on either of those two plugins. =head2 Network fetch is turned off If you get an error like this: Alien::Build> install type share requested or detected, but network fetch is turned off Alien::Build> see see https://metacpan.org/pod/Alien::Build::Manual::FAQ#Network-fetch-is-turned-off This is because your environment is setup not to install aliens that require the network. You can turn network fetch back on by setting C<ALIEN_INSTALL_NETWORK> to true, or by unsetting it. This environment variable is designed for environments that don't ever want to install aliens that require downloading source packages over the internet. =head2 I would really prefer you not download stuff off the internet The idea of L<Alien> is to download missing packages and build them automatically to make installing easier. Some people may not like this, or may even have security requirements that they not download random package over the internet (caveat, downloading random stuff off of CPAN may not be any safer, so make sure you audit all of the open source software that you use appropriately). Another reason you may not want to download from the internet is if you are packaging up an alien for an operating system vendor, which will always want to use the system version of a library. In that situation you don't want L<Alien::Build> to go off and download something from the internet because the probe failed for some reason. This is easy to take care of, simply set C<ALIEN_INSTALL_TYPE> to C<system> and a build from source code will never be attempted. On systems that do not provide system versions of the library or tool you will get an error, allowing you to install the library, and retry the alien install. You can also set the environment variable on just some aliens. % export ALIEN_INSTALL_TYPE=system # for everyone % env ALIEN_INSTALL_TYPE=system cpanm -v Alien::libfoo =head2 For testing I would like to test both system and share installs! You can use the C<ALIEN_INSTALL_TYPE> environment variable. It will force either a C<share> or C<system> install depending on how it is set. For travis you can do something like this: env: matrix: - ALIEN_INSTALL_TYPE=share - ALIEN_INSTALL_TYPE=system =head2 How do I use Alien::Build from Dist::Zilla? For creating L<Alien::Base> and L<Alien::Build> based dist from L<Dist::Zilla> you can use the dzil plugin L<Dist::Zilla::Plugin::AlienBuild>. =head2 Cannot find either a share directory or a ConfigData module If you see an error like this: Cannot find either a share directory or a ConfigData module for Alien::libfoo. (Alien::libfoo loaded from lib/Alien/libfoo.pm) Please see https://metacpan.org/pod/distribution/Alien-Build/lib/Alien/Build/Manual/FAQ.pod#Cannot-find-either-a-share-directory-or-a-ConfigData-module Can't locate Alien/libfoo/ConfigData.pm in @INC (you may need to install the Alien::libfoo::ConfigData module) (@INC contains: ...) it means you are trying to use an Alien that hasn't been properly installed. An L<Alien::Base> based Alien needs to have either the share directory build during the install process or for older legacy L<Alien::Base::ModuleBuild> based Aliens, a ConfigData module generated by L<Module::Build>. This usually happens if you try to use an Alien module from the lib directory as part of the Alien's distribution. You need to build the alien and use C<blib/lib> instead of C<lib> or install the alien and use the installed path. It is also possible that your Alien installer is not set up correctly. Make sure your C<Makefile.PL> is using L<Alien::Build::MM> correctly. =head2 I have a question not listed here! There are a number of forums available to people working on L<Alien>, L<Alien::Base> and L<Alien::Build> modules: =over 4 =item C<#native> on irc.perl.org This is intended for native interfaces in general so is a good place for questions about L<Alien> generally or L<Alien::Base> and L<Alien::Build> specifically. =item mailing list The C<perl5-alien> google group is intended for L<Alien> issues generally, including L<Alien::Base> and L<Alien::Build>. L<https://groups.google.com/forum/#!forum/perl5-alien> =item Open a support ticket If you have an issue with L<Alien::Build> itself, then please open a support ticket on the project's GitHub issue tracker. L<https://github.com/PerlAlien/Alien-Build/issues> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::MM>, L<Alien::Build::Plugin>, L<alienfile> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build/CMake.pm 0000444 00000013313 14711220240 0013465 0 ustar 00 package Alien::Build::Plugin::Build::CMake; use strict; use warnings; use 5.008004; use Config; use Alien::Build::Plugin; use Capture::Tiny qw( capture ); # ABSTRACT: CMake plugin for Alien::Build our $VERSION = '2.41'; # VERSION sub cmake_generator { if($^O eq 'MSWin32') { return 'MinGW Makefiles' if is_dmake(); { my($out, $err) = capture { system $Config{make}, '/?' }; return 'NMake Makefiles' if $out =~ /NMAKE/; } { my($out, $err) = capture { system $Config{make}, '--version' }; return 'MinGW Makefiles' if $out =~ /GNU Make/; } die 'make not detected'; } else { return 'Unix Makefiles'; } } sub init { my($self, $meta) = @_; $meta->prop->{destdir} = $^O eq 'MSWin32' ? 0 : 1; $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::CMake' => '0.99'); $meta->add_requires('share' => 'Alien::cmake3' => '0.02'); if(is_dmake()) { # even on at least some older versions of strawberry that do not # use it, come with gmake in the PATH. So to save us the effort # of having to install Alien::gmake lets just use that version # if we can find it! my $found_gnu_make = 0; foreach my $exe (qw( gmake make mingw32-make )) { my($out, $err) = capture { system $exe, '--version' }; if($out =~ /GNU Make/) { $meta->interpolator->replace_helper('make' => sub { $exe }); $found_gnu_make = 1; last; } } if(!$found_gnu_make) { $meta->add_requires('share' => 'Alien::gmake' => '0.20'); $meta->interpolator->replace_helper('make' => sub { require Alien::gmake; Alien::gmake->exe }); } } $meta->interpolator->replace_helper('cmake' => sub { require Alien::cmake3; Alien::cmake3->exe }); $meta->interpolator->add_helper('cmake_generator' => \&cmake_generator); my @args = ( -G => '%{cmake_generator}', '-DCMAKE_POSITION_INDEPENDENT_CODE:BOOL=true', '-DCMAKE_INSTALL_PREFIX:PATH=%{.install.prefix}', '-DCMAKE_INSTALL_LIBDIR:PATH=lib', '-DCMAKE_MAKE_PROGRAM:PATH=%{make}', ); $meta->prop->{plugin_build_cmake}->{args} = \@args; $meta->default_hook( build => [ ['%{cmake}', @args, '%{.install.extract}' ], ['%{make}' ], ['%{make}', 'install' ], ], ); # TODO: handle destdir on windows ?? } my $is_dmake; sub is_dmake { unless(defined $is_dmake) { if($^O eq 'MSWin32') { my($out, $err) = capture { system $Config{make}, '-V' }; $is_dmake = $out =~ /dmake/ ? 1 : 0; } else { $is_dmake = 0; } } $is_dmake; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build::CMake - CMake plugin for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { plugin 'Build::CMake'; build [ # this is the default build step, if you do not specify one. [ '%{cmake}', @{ meta->prop->{plugin_build_cmake}->{args} }, # ... put extra cmake args here ... '%{.install.extract}' ], '%{make}', '%{make} install', ]; }; =head1 DESCRIPTION This plugin helps build alienized projects that use C<cmake>. The intention is to make this a core L<Alien::Build> plugin if/when it becomes stable enough. This plugin provides a meta property C<plugin_build_cmake.args> which may change over time but for the moment includes: -G %{cmake_generator} \ -DCMAKE_POSITION_INDEPENDENT_CODE:BOOL=true \ -DCMAKE_INSTALL_PREFIX:PATH=%{.install.prefix} \ -DCMAKE_INSTALL_LIBDIR:PATH=lib \ -DCMAKE_MAKE_PROGRAM:PATH=%{make} This plugin supports out-of-source builds via the meta property C<out_of_source>. =head1 METHODS =head2 cmake_generator Returns the C<cmake> generator according to your Perl's C<make>. =head2 is_dmake Returns true if your Perls C<make> appears to be C<dmake>. =head1 HELPERS =head2 cmake This plugin replaces the default C<cmake> helper with the one that comes from L<Alien::cmake3>. =head2 cmake_generator This is the appropriate C<cmake> generator to use based on the make used by your Perl. This is frequently C<Unix Makefiles>. One place where it may be different is if your Windows Perl uses C<nmake>, which comes with Visual C++. =head2 make This plugin I<may> replace the default C<make> helper if the default C<make> is not supported by C<cmake>. This is most often an issue with older versions of Strawberry Perl which used C<dmake>. On Perls that use C<dmake>, this plugin will search for GNU Make in the PATH, and if it can't be found will fallback on using L<Alien::gmake>. =head1 SEE ALSO =over 4 =item L<Alien::Build> =item L<Alien::Build::Plugin::Build::Autoconf> =item L<alienfile> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build/SearchDep.pm 0000444 00000012534 14711220240 0014347 0 ustar 00 package Alien::Build::Plugin::Build::SearchDep; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Text::ParseWords qw( shellwords ); # ABSTRACT: Add dependencies to library and header search path our $VERSION = '2.41'; # VERSION has aliens => {}; has public_I => 0; has public_l => 0; sub init { my($self, $meta) = @_; $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::SearchDep' => '0.35'); $meta->add_requires('share' => 'Env::ShellWords' => 0.01); if($self->public_I || $self->public_l) { $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::SearchDep' => '0.53'); } my @aliens; if(ref($self->aliens) eq 'HASH') { @aliens = keys %{ $self->aliens }; $meta->add_requires('share' => $_ => $self->aliens->{$_}) for @aliens; } else { @aliens = ref $self->aliens ? @{ $self->aliens } : ($self->aliens); $meta->add_requires('share' => $_ => 0) for @aliens; } $meta->around_hook( build => sub { my($orig, $build) = @_; local $ENV{CFLAGS} = $ENV{CFLAGS}; local $ENV{CXXFLAGS} = $ENV{CXXFLAGS}; local $ENV{LDFLAGS} = $ENV{LDFLAGS}; tie my @CFLAGS, 'Env::ShellWords', 'CFLAGS'; tie my @CXXFLAGS, 'Env::ShellWords', 'CXXFLAGS'; tie my @LDFLAGS, 'Env::ShellWords', 'LDFLAGS'; my $cflags = $build->install_prop->{plugin_build_searchdep_cflags} = []; my $ldflags = $build->install_prop->{plugin_build_searchdep_ldflags} = []; my $libs = $build->install_prop->{plugin_build_searchdep_libs} = []; foreach my $other (@aliens) { my $other_cflags; my $other_libs; if($other->install_type('share')) { $other_cflags = $other->cflags_static; $other_libs = $other->libs_static; } else { $other_cflags = $other->cflags; $other_libs = $other->libs; } unshift @$cflags, grep /^-I/, shellwords($other_cflags); unshift @$ldflags, grep /^-L/, shellwords($other_libs); unshift @$libs, grep /^-l/, shellwords($other_libs); } unshift @CFLAGS, @$cflags; unshift @CXXFLAGS, @$cflags; unshift @LDFLAGS, @$ldflags; $orig->($build); }, ); $meta->after_hook( gather_share => sub { my($build) = @_; $build->runtime_prop->{libs} = '' unless defined $build->runtime_prop->{libs}; $build->runtime_prop->{libs_static} = '' unless defined $build->runtime_prop->{libs_static}; if($self->public_l) { $build->runtime_prop->{$_} = join(' ', _space_escape(@{ $build->install_prop->{plugin_build_searchdep_libs} })) . ' ' . $build->runtime_prop->{$_} for qw( libs libs_static ); } $build->runtime_prop->{$_} = join(' ', _space_escape(@{ $build->install_prop->{plugin_build_searchdep_ldflags} })) . ' ' . $build->runtime_prop->{$_} for qw( libs libs_static ); if($self->public_I) { $build->runtime_prop->{cflags} = '' unless defined $build->runtime_prop->{cflags}; $build->runtime_prop->{cflags_static} = '' unless defined $build->runtime_prop->{cflags_static}; $build->runtime_prop->{$_} = join(' ', _space_escape(@{ $build->install_prop->{plugin_build_searchdep_cflags} })) . ' ' . $build->runtime_prop->{$_} for qw( cflags cflags_static ); } }, ); } sub _space_escape { map { my $str = $_; $str =~ s{(\s)}{\\$1}g; $str; } @_; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build::SearchDep - Add dependencies to library and header search path =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Build::SearchDep' => ( aliens => [qw( Alien::Foo Alien::Bar )], ); =head1 DESCRIPTION This plugin adds the other aliens as prerequisites, and adds their header and library search path to C<CFLAGS> and C<LDFLAGS> environment variable, so that tools that use them (like autoconf) can pick them up. =head1 PROPERTIES =head2 aliens Either a list reference or hash reference of the other aliens. If a hash reference then the keys are the class names and the values are the versions of those classes. =head2 public_I Include the C<-I> flags when setting the runtime cflags property. =head2 public_l Include the C<-l> flags when setting the runtime libs property. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build/Autoconf.pm 0000444 00000020646 14711220241 0014273 0 ustar 00 package Alien::Build::Plugin::Build::Autoconf; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use constant _win => $^O eq 'MSWin32'; use Path::Tiny (); use File::Temp (); # ABSTRACT: Autoconf plugin for Alien::Build our $VERSION = '2.41'; # VERSION has with_pic => 1; has ffi => 0; has msys_version => undef; has config_site => sub { my $config_site = "# file automatically generated by @{[ __FILE__ ]}\n"; $config_site .= ". $ENV{CONFIG_SITE}\n" if defined $ENV{CONFIG_SITE}; $config_site .= ". $ENV{ALIEN_BUILD_SITE_CONFIG}\n" if defined $ENV{ALIEN_BUILD_SITE_CONFIG}; # on some platforms autofools sorry I mean autotools likes to install into # exec_prefix/lib64 or even worse exec_prefix/lib/64 but that messes everything # else up so we try to nip that in the bud. $config_site .= "libdir='\${prefix}/lib'\n"; $config_site; }; sub init { my($self, $meta) = @_; $meta->apply_plugin('Build::MSYS', (defined $self->msys_version ? (msys_version => $self->msys_version) : ()), ); $meta->prop->{destdir} = 1; $meta->prop->{autoconf} = 1; my $intr = $meta->interpolator; my $set_autoconf_prefix = sub { my($build) = @_; my $prefix = $build->install_prop->{prefix}; die "Prefix is not set. Did you forget to run 'make alien_prefix'?" unless $prefix; if(_win) { $prefix = Path::Tiny->new($prefix)->stringify; $prefix =~ s!^([a-z]):!/$1!i if _win; } $build->install_prop->{autoconf_prefix} = $prefix; }; $meta->before_hook( build_ffi => $set_autoconf_prefix, ); # FFI mode undocumented for now... if($self->ffi) { $meta->add_requires('configure', 'Alien::Build::Plugin::Build::Autoconf' => '0.41'); $meta->default_hook( build_ffi => [ '%{configure} --enable-shared --disable-static --libdir=%{.install.autoconf_prefix}/dynamic', '%{make}', '%{make} install', ] ); if($^O eq 'MSWin32') { # for whatever reason autohell puts the .dll files in bin, even if you # point --bindir somewhere else. $meta->after_hook( build_ffi => sub { my($build) = @_; my $prefix = $build->install_prop->{autoconf_prefix}; my $bin = Path::Tiny->new($ENV{DESTDIR})->child($prefix)->child('bin'); my $lib = Path::Tiny->new($ENV{DESTDIR})->child($prefix)->child('dynamic'); if(-d $bin) { foreach my $from (grep { $_->basename =~ /.dll$/i } $bin->children) { $lib->mkpath; my $to = $lib->child($from->basename); $build->log("copy $from => $to"); $from->copy($to); } } } ); } } $meta->around_hook( build => sub { my $orig = shift; my $build = shift; $set_autoconf_prefix->($build); my $prefix = $build->install_prop->{autoconf_prefix}; die "Prefix is not set. Did you forget to run 'make alien_prefix'?" unless $prefix; local $ENV{CONFIG_SITE} = do { my $site_config = Path::Tiny->new(File::Temp::tempdir( CLEANUP => 1 ))->child('config.site'); $site_config->spew($self->config_site); "$site_config"; }; $intr->replace_helper( configure => sub { my $configure; if($build->meta_prop->{out_of_source}) { my $extract = $build->install_prop->{extract}; $configure = _win ? "sh $extract/configure" : "$extract/configure"; } else { $configure = _win ? 'sh ./configure' : './configure'; } $configure .= ' --prefix=' . $prefix; $configure .= ' --with-pic' if $self->with_pic; $configure; } ); my $ret = $orig->($build, @_); if(_win) { my $real_prefix = Path::Tiny->new($build->install_prop->{prefix}); my @pkgconf_dirs; push @pkgconf_dirs, Path::Tiny->new($ENV{DESTDIR})->child($prefix)->child("$_/pkgconfig") for qw(lib share); # for any pkg-config style .pc files that are dropped, we need # to convert the MSYS /C/Foo style paths to C:/Foo for my $pkgconf_dir (@pkgconf_dirs) { if(-d $pkgconf_dir) { foreach my $pc_file ($pkgconf_dir->children) { $pc_file->edit(sub {s/\Q$prefix\E/$real_prefix->stringify/eg;}); } } } } $ret; }, ); $intr->add_helper( configure => sub { my $configure = _win ? 'sh configure' : './configure'; $configure .= ' --with-pic' if $self->with_pic; $configure; }, ); $meta->default_hook( build => [ '%{configure} --disable-shared', '%{make}', '%{make} install', ] ); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build::Autoconf - Autoconf plugin for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Build::Autoconf'; =head1 DESCRIPTION This plugin provides some tools for building projects that use autoconf. The main thing this provides is a C<configure> helper, documented below and the default build stage, which is: '%{configure} --disable-shared', '%{make}', '%{make} install', On Windows, this plugin also pulls in the L<Alien::Build::Plugin::Build::MSYS> which is required for autoconf style projects on windows. The other thing that this plugin does is that it does a double staged C<DESTDIR> install. The author has found this improves the overall reliability of L<Alien> modules that are based on autoconf packages. This plugin supports out-of-source builds (known in autoconf terms as "VPATH" builds) via the meta property C<out_of_source>. =head1 PROPERTIES =head2 with_pic Adds C<--with-pic> option when running C<configure>. If supported by your package, it will generate position independent code on platforms that support it. This is required to XS modules, and generally what you want. autoconf normally ignores options that it does not understand, so it is usually a safe and reasonable default to include it. A small number of projects look like they use autoconf, but are really an autoconf style interface with a different implementation. They may fail if you try to provide it with options such as C<--with-pic> that they do not recognize. Such packages are the rationale for this property. =head2 msys_version The version of L<Alien::MSYS> required if it is deemed necessary. If L<Alien::MSYS> isn't needed (if running under Unix, or MSYS2, for example) this will do nothing. =head2 config_site The content for the generated C<config.site>. =head1 HELPERS =head2 configure %{configure} The correct incantation to start an autoconf style C<configure> script on your platform. Some reasonable default flags will be provided. =head1 ENVIRONMENT =over 4 =item C<ALIEN_BUILD_SITE_CONFIG> This plugin needs to alter the behavior of autotools via the C<site.config> file and so sets and possibly overrides any existing C<SITE_CONFIG>. Normally that is what you want but you can also insert your own C<site.config> in addition by using this environment variable. =back =head1 SEE ALSO L<Alien::Build::Plugin::Build::MSYS>, L<Alien::Build::Plugin>, L<Alien::Build>, L<Alien::Base>, L<Alien> L<https://www.gnu.org/software/autoconf/autoconf.html> L<https://www.gnu.org/prep/standards/html_node/DESTDIR.html> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build/MSYS.pm 0000444 00000007272 14711220241 0013310 0 ustar 00 package Alien::Build::Plugin::Build::MSYS; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Which (); use Env qw( @PATH ); # ABSTRACT: MSYS plugin for Alien::Build our $VERSION = '2.41'; # VERSION has msys_version => '0.07'; sub init { my($self, $meta) = @_; if($self->msys_version ne '0.07') { $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::MSYS' => '0.84'); } if(_win_and_needs_msys($meta)) { $meta->add_requires('share' => 'Alien::MSYS' => $self->msys_version); $meta->around_hook( $_ => sub { my $orig = shift; my $build = shift; local $ENV{PATH} = $ENV{PATH}; unshift @PATH, Alien::MSYS::msys_path(); $orig->($build, @_); }, ) for qw( build build_ffi test_share test_ffi ); } if($^O eq 'MSWin32') { # Most likely if we are trying to build something unix-y and # we are using MSYS, then we want to use the make that comes # with MSYS. $meta->interpolator->replace_helper( make => sub { 'make' }, ); } $self; } sub _win_and_needs_msys { my($meta) = @_; # check to see if we are running on windows. # if we are running on windows, check to see if # it is MSYS2, then we can just use that. Otherwise # we are probably on Strawberry, or (less likely) # VC Perl, in which case we will still need Alien::MSYS return 0 unless $^O eq 'MSWin32'; return 0 if $meta->prop->{platform}->{system_type} eq 'windows-mingw'; return 1; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build::MSYS - MSYS plugin for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Build::MSYS'; =head1 DESCRIPTION This plugin sets up the MSYS environment for your build on Windows. It does not do anything on non-windows platforms. MSYS provides the essential tools for building software that is normally expected in a UNIX or POSIX environment. This like C<sh>, C<awk> and C<make>. To provide MSYS, this plugin uses L<Alien::MSYS>. =head1 PROPERTIES =head2 msys_version The version of L<Alien::MSYS> required if it is deemed necessary. If L<Alien::MSYS> isn't needed (if running under Unix, or MSYS2, for example) this will do nothing. =head1 HELPERS =head2 make %{make} On windows the default C<%{make}> helper is replace with the make that comes with L<Alien::MSYS>. This is almost certainly what you want, as most unix style make projects will not build with C<nmake> or C<dmake> typically used by Perl on Windows. =head1 SEE ALSO L<Alien::Build::Plugin::Autoconf>, L<Alien::Build::Plugin>, L<Alien::Build>, L<Alien::Base>, L<Alien> L<http://www.mingw.org/wiki/MSYS> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build/Copy.pm 0000444 00000006547 14711220242 0013434 0 ustar 00 package Alien::Build::Plugin::Build::Copy; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Path::Tiny (); # ABSTRACT: Copy plugin for Alien::Build our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->add_requires( 'configure', __PACKAGE__, 0); if($^O eq 'MSWin32') { $meta->register_hook(build => sub { my($build) = @_; my $stage = Path::Tiny->new($build->install_prop->{stage})->canonpath; $build->system("xcopy . $stage /E"); }); } else { $meta->register_hook(build => [ 'cp -aR * %{.install.stage}', # TODO: some platforms might not support -a # I think most platforms will support -r ]); } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build::Copy - Copy plugin for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Build::Copy'; =head1 DESCRIPTION This plugin copies all of the files from the source to the staging prefix. This is mainly useful for software packages that are provided as binary blobs. It works on both Unix and Windows using the appropriate commands for those platforms without having worry about the platform details in your L<alienfile>. If you want to filter add or remove files from what gets installed you can use a C<before> hook. build { ... before 'build' => sub { # remove or modify files }; plugin 'Build::Copy'; ... }; Some packages might have binary blobs on some platforms and require build from source on others. In that situation you can use C<if> statements with the appropriate logic in your L<alienfile>. configure { # normally the Build::Copy plugin will insert itself # as a config requires, but since it is only used # on some platforms, you will want to explicitly # require it in your alienfile in case you build your # alien dist on a platform that doesn't use it. requires 'Alien::Build::Plugin::Build::Copy'; }; build { ... if($^O eq 'linux') { start_url 'http://example.com/binary-blob-linux.tar.gz'; plugin 'Download'; plugin 'Extract' => 'tar.gz'; plugin 'Build::Copy'; } else { start_url 'http://example.com/source.tar.gz'; plugin 'Download'; plugin 'Extract' => 'tar.gz'; plugin 'Build::Autoconf'; } }; =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build/Make.pm 0000444 00000010211 14711220242 0013356 0 ustar 00 package Alien::Build::Plugin::Build::Make; use strict; use warnings; use 5.008004; use Carp (); use Capture::Tiny qw( capture ); use Alien::Build::Plugin; # ABSTRACT: Make plugin for Alien::Build our $VERSION = '2.41'; # VERSION has '+make_type' => undef; sub init { my($self, $meta) = @_; $meta->add_requires('configure', 'Alien::Build::Plugin::Build::Make', '0.99'); my $type = $self->make_type; return unless defined $type; $type = 'gmake' if $^O eq 'MSWin32' && $type eq 'umake'; if($type eq 'nmake') { $meta->interpolator->replace_helper( make => sub { 'nmake' } ); } elsif($type eq 'dmake') { $meta->interpolator->replace_helper( make => sub { 'dmake' } ); } elsif($type eq 'gmake') { my $found = 0; foreach my $make (qw( gmake make mingw32-make )) { my($out, $err) = capture { system $make, '--version' }; if($out =~ /GNU Make/) { $meta->interpolator->replace_helper( make => sub { $make } ); $found = 1; } } unless($found) { $meta->add_requires('share' => 'Alien::gmake' => '0.20'); $meta->interpolator->replace_helper('make' => sub { require Alien::gmake; Alien::gmake->exe }); } } elsif($type eq 'umake') { # nothing } else { Carp::croak("unknown make type = ", $self->make_type); } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build::Make - Make plugin for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # For a recipe that requires GNU Make plugin 'Build::Make' => 'gmake'; =head1 DESCRIPTION By default L<Alien::Build> provides a helper for the C<make> that is used by Perl and L<ExtUtils::MakeMaker> itself. This is handy, because it is the one make that you can mostly guarantee that you will have. Unfortunately it may be a C<make> that isn't supported by the library or tool that you are trying to alienize. This is mostly a problem on Windows, where the supported C<make>s for years were Microsoft's C<nmake> and Sun's C<dmake>, which many open source projects do not use. This plugin will alter the L<alienfile> recipe to use a different C<make>. It may (as in the case of C<gmake> / L<Alien::gmake>) automatically download and install an alienized version of that C<make> if it is not already installed. This plugin should NOT be used with other plugins that replace the C<make> helper, like L<Alien::Build::Plugin::Build::CMake>, L<Alien::Build::Plugin::Build::Autoconf>, L<Alien::Build::Plugin::Build::MSYS>. This plugin is intended instead for projects that use vanilla makefiles of a specific type. This plugin is for now distributed separately from L<Alien::Build>, but the intention is for it to soon become a core plugin for L<Alien::Build>. =head1 PROPERTIES =head2 make_type The make type needed by the L<alienfile> recipe: =over 4 =item dmake Sun's dmake. =item gmake GNU Make. =item nmake Microsoft's nmake. It comes with Visual C++. =item umake Any UNIX C<make> Usually either BSD or GNU Make. =back =head1 HELPERS =head2 make %{make} This plugin may change the make helper used by your L<alienfile> recipe. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Prefer/BadVersion.pm 0000444 00000010201 14711220243 0014721 0 ustar 00 package Alien::Build::Plugin::Prefer::BadVersion; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); # ABSTRACT: Plugin to filter out known bad versions our $VERSION = '2.41'; # VERSION has '+filter' => sub { Carp::croak("The filter property is required for the Prefer::BadVersion plugin") }; sub init { my($self, $meta) = @_; $meta->add_requires('configure', __PACKAGE__, '1.05'); my $filter; if(ref($self->filter) eq '') { my $string = $self->filter; $filter = sub { my($file) = @_; $file->{version} ne $string; }; } elsif(ref($self->filter) eq 'ARRAY') { my %filter = map { $_ => 1 } @{ $self->filter }; $filter = sub { my($file) = @_; ! $filter{$file->{version}}; }; } elsif(ref($self->filter) eq 'CODE') { my $code = $self->filter; $filter = sub { ! $code->($_[0]) }; } else { Carp::croak("unknown filter type for Prefer::BadVersion"); } $meta->around_hook( prefer => sub { my($orig, $build, @therest) = @_; my $res1 = $orig->($build, @therest); return $res1 unless $res1->{type} eq 'list'; return { type => 'list', list => [ grep { $filter->($_) } @{ $res1->{list} } ], }; }, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Prefer::BadVersion - Plugin to filter out known bad versions =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Prefer::BadVersion' => '1.2.3'; =head1 DESCRIPTION This plugin allows you to easily filter out known bad versions of libraries in a share install. It doesn't affect a system install at all. You need a Prefer plugin that filters and sorts files first. You may specify the filter in one of three ways: =over =item as a string Filter out any files that match the given version. use alienfile; plugin 'Prefer::BadVersion' => '1.2.3'; =item as an array Filter out all files that match any of the given versions. use alienfile; plugin 'Prefer::BadVersion' => [ '1.2.3', '1.2.4' ]; =item as a code reference Filter out any files return a true value. use alienfile; plugin 'Prefer::BadVersion' => sub { my($file) = @_; $file->{version} eq '1.2.3'; # same as the string version above }; =back This plugin can also be used to filter out known bad versions of a library on just one platform. For example, if you know that version 1.2.3 if bad on windows, but okay on other platforms: use alienfile; plugin 'Prefer::BadVersion' => '1.2.3' if $^O eq 'MSWin32'; =head1 PROPERTIES =head2 filter Filter out entries that match the filter. =head1 CAVEATS If you are using the string or array mode, then you need an existing Prefer plugin that sets the version number for each file candidate, such as L<Alien::Build::Plugin::Prefer::SortVersions>. Unless you want to exclude the latest version from a share install, this plugin isn't really that useful. It has no effect on system installs, which may not be obvious at first. =head1 SEE ALSO =over 4 =item L<alienfile> =item L<Alien::Build> =item L<Alien::Build::Plugin::Prefer::SortVersions> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Prefer/SortVersions.pm 0000444 00000007125 14711220243 0015360 0 ustar 00 package Alien::Build::Plugin::Prefer::SortVersions; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Plugin to sort candidates by most recent first our $VERSION = '2.41'; # VERSION has 'filter' => undef; has '+version' => qr/([0-9](?:[0-9\.]*[0-9])?)/; sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'Sort::Versions' => 0); $meta->register_hook( prefer => sub { my(undef, $res) = @_; my $cmp = sub { my($A,$B) = map { ($_ =~ $self->version)[0] } @_; Sort::Versions::versioncmp($B,$A); }; my @list = sort { $cmp->($a->{filename}, $b->{filename}) } map { ($_->{version}) = $_->{filename} =~ $self->version; $_ } grep { $_->{filename} =~ $self->version } grep { defined $self->filter ? $_->{filename} =~ $self->filter : 1 } @{ $res->{list} }; return { type => 'list', list => \@list, }; }); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Prefer::SortVersions - Plugin to sort candidates by most recent first =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Prefer::SortVersions'; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This Prefer plugin sorts the packages that were retrieved from a dir listing, either directly from a Fetch plugin, or from a Decode plugin. It Returns a listing with the items sorted from post preferable to least, and filters out any undesirable candidates. This plugin updates the file list to include the versions that are extracted, so they can be used by other plugins, such as L<Alien::Build::Plugin::Prefer::BadVersion>. =head1 PROPERTIES =head2 filter This is a regular expression that lets you filter out files that you do not want to consider downloading. For example, if the directory listing contained tarballs and readme files like this: foo-1.0.0.tar.gz foo-1.0.0.readme You could specify a filter of C<qr/\.tar\.gz$/> to make sure only tarballs are considered for download. =head2 version Regular expression to parse out the version from a filename. The regular expression should store the result in C<$1>. The default C<qr/([0-9\.]+)/> is frequently reasonable. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Prefer/GoodVersion.pm 0000444 00000010276 14711220243 0015137 0 ustar 00 package Alien::Build::Plugin::Prefer::GoodVersion; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); # ABSTRACT: Plugin to filter known good versions our $VERSION = '2.41'; # VERSION has '+filter' => sub { Carp::croak("The filter property is required for the Prefer::GoodVersion plugin") }; sub init { my($self, $meta) = @_; $meta->add_requires('configure', __PACKAGE__, '1.44'); my $filter; if(ref($self->filter) eq '') { my $string = $self->filter; $filter = sub { my($file) = @_; $file->{version} eq $string; }; } elsif(ref($self->filter) eq 'ARRAY') { my %filter = map { $_ => 1 } @{ $self->filter }; $filter = sub { my($file) = @_; !! $filter{$file->{version}}; }; } elsif(ref($self->filter) eq 'CODE') { my $code = $self->filter; $filter = sub { !! $code->($_[0]) }; } else { Carp::croak("unknown filter type for Prefer::GoodVersion"); } $meta->around_hook( prefer => sub { my($orig, $build, @therest) = @_; my $res1 = $orig->($build, @therest); return $res1 unless $res1->{type} eq 'list'; return { type => 'list', list => [ grep { $filter->($_) } @{ $res1->{list} } ], }; }, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Prefer::GoodVersion - Plugin to filter known good versions =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Prefer::GoodVersion' => '1.2.3'; =head1 DESCRIPTION This plugin allows you to specify one or more good versions of a library. This doesn't affect a system install at all. This plugin does the opposite of the C<Prefer::BadVersion> plugin. You need need a Prefer plugin that filters and sorts files first. You may specify the filter in one of three ways: =over =item as a string Filter any files that match the given version. use alienfile; plugin 'Prefer::GoodVersion' => '1.2.3'; =item as an array Filter all files that match any of the given versions. use alienfile; plugin 'Prefer::GoodVersion' => [ '1.2.3', '1.2.4' ]; =item as a code reference Filter any files return a true value. use alienfile; plugin 'Prefer::GoodVersion' => sub { my($file) = @_; $file->{version} eq '1.2.3'; # same as the string version above }; =back This plugin can also be used to filter known good versions of a library on just one platform. For example, if you know that version 1.2.3 if good on windows, but the default logic is fine on other platforms: use alienfile; plugin 'Prefer::GoodVersion' => '1.2.3' if $^O eq 'MSWin32'; =head1 PROPERTIES =head2 filter Filter entries that match the filter. =head1 CAVEATS If you are using the string or array mode, then you need an existing Prefer plugin that sets the version number for each file candidate, such as L<Alien::Build::Plugin::Prefer::SortVersions>. Unless you want to exclude the latest version from a share install, this plugin isn't really that useful. It has no effect on system installs, which may not be obvious at first. =head1 SEE ALSO =over 4 =item L<alienfile> =item L<Alien::Build> =item L<Alien::Build::Plugin::Prefer::SortVersions> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Extract/Negotiate.pm 0000444 00000007217 14711220243 0015010 0 ustar 00 package Alien::Build::Plugin::Extract::Negotiate; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Alien::Build::Plugin::Extract::ArchiveTar; use Alien::Build::Plugin::Extract::ArchiveZip; use Alien::Build::Plugin::Extract::CommandLine; use Alien::Build::Plugin::Extract::Directory; # ABSTRACT: Extraction negotiation plugin our $VERSION = '2.41'; # VERSION has '+format' => 'tar'; sub init { my($self, $meta) = @_; my $format = $self->format; $format = 'tar.gz' if $format eq 'tgz'; $format = 'tar.bz2' if $format eq 'tbz'; $format = 'tar.xz' if $format eq 'txz'; my $plugin = $self->pick($format); $meta->apply_plugin($plugin, format => $format); $self; } sub pick { my(undef, $format) = @_; if($format =~ /^tar(\.(gz|bz2))?$/) { if(Alien::Build::Plugin::Extract::ArchiveTar->available($format)) { return 'Extract::ArchiveTar'; } else { return 'Extract::CommandLine'; } } elsif($format eq 'zip') { # Archive::Zip is not that reliable. But if it is already installed it is probably working if(Alien::Build::Plugin::Extract::ArchiveZip->available($format)) { return 'Extract::ArchiveZip'; } # If it isn't available, then use the command-line unzip. Alien::unzip will be used # as necessary in environments where it isn't already installed. else { return 'Extract::CommandLine'; } } elsif($format eq 'tar.xz' || $format eq 'tar.Z') { return 'Extract::CommandLine'; } elsif($format eq 'd') { return 'Extract::Directory'; } else { die "do not know how to handle format: $format"; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Extract::Negotiate - Extraction negotiation plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Extract' => ( format => 'tar.gz', ); =head1 DESCRIPTION This is a negotiator plugin for extracting packages downloaded from the internet. This plugin picks the best Extract plugin to do the actual work. Which plugins are picked depend on the properties you specify, your platform and environment. It is usually preferable to use a negotiator plugin rather than using a specific Extract Plugin from your L<alienfile>. =head1 PROPERTIES =head2 format The expected format for the download. Possible values include: C<tar>, C<tar.gz>, C<tar.bz2>, C<tar.xz>, C<zip>, C<d>. =head1 METHODS =head2 pick my $name = Alien::Build::Plugin::Extract::Negotiate->pick($format); Returns the name of the best plugin for the given format. =head1 SEE ALSO L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Extract/ArchiveTar.pm 0000444 00000010675 14711220243 0015123 0 ustar 00 package Alien::Build::Plugin::Extract::ArchiveTar; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::chdir; use File::Temp (); use Path::Tiny (); # ABSTRACT: Plugin to extract a tarball using Archive::Tar our $VERSION = '2.41'; # VERSION has '+format' => 'tar'; sub handles { my(undef, $ext) = @_; return 1 if $ext =~ /^(tar|tar.gz|tar.bz2|tbz|taz)$/; return 0; } sub available { my(undef, $ext) = @_; if($ext eq 'tar.gz') { return !! eval { require Archive::Tar; Archive::Tar->has_zlib_support }; } elsif($ext eq 'tar.bz2') { return !! eval { require Archive::Tar; Archive::Tar->has_bzip2_support && __PACKAGE__->_can_bz2 }; } else { return $ext eq 'tar'; } } sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'Archive::Tar' => 0); if($self->format eq 'tar.gz' || $self->format eq 'tgz') { $meta->add_requires('share' => 'IO::Zlib' => 0); } elsif($self->format eq 'tar.bz2' || $self->format eq 'tbz') { $meta->add_requires('share' => 'IO::Uncompress::Bunzip2' => 0); $meta->add_requires('share' => 'IO::Compress::Bzip2' => 0); } $meta->register_hook( extract => sub { my($build, $src) = @_; my $tar = Archive::Tar->new; $tar->read($src); $tar->extract; } ); } sub _can_bz2 { # even when Archive::Tar reports that it supports bz2, I can sometimes get this error: # 'Cannot read enough bytes from the tarfile', so lets just probe for actual support! my $dir = Path::Tiny->new(File::Temp::tempdir( CLEANUP => 1 )); eval { local $CWD = $dir; my $tarball = unpack "u", q{M0EIH.3%!62936=+(]$0``$A[D-$0`8!``7^``!!AI)Y`!```""``=!JGIH-(MT#0]0/2!**---&F@;4#0&:D;X?(6@JH(2<%'N$%3VHC-9E>S/N@"6&I*1@GNJNHCC2>$I5(<0BKR.=XBZ""HVZ;T,CV\LJ!K&*?9`#\7<D4X4)#2R/1$`}; Path::Tiny->new('xx.tar.bz2')->spew_raw($tarball); require Archive::Tar; my $tar = Archive::Tar->new; $tar->read('xx.tar.bz2'); $tar->extract; my $content = Path::Tiny->new('xx.txt')->slurp; die unless $content && $content eq "xx\n"; }; my $error = $@; $dir->remove_tree; !$error; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Extract::ArchiveTar - Plugin to extract a tarball using Archive::Tar =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Extract::ArchiveTar' => ( format => 'tar.gz', ); =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Extract::Negotiate> instead. It picks the appropriate Extract plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin extracts from an archive in tarball format (optionally compressed by either gzip or bzip2) using L<Archive::Tar>. =head1 PROPERTIES =head2 format Gives a hint as to the expected format. This helps make sure the prerequisites are set correctly, since compressed archives require extra Perl modules to be installed. =head1 METHODS =head2 handles Alien::Build::Plugin::Extract::ArchiveTar->handles($ext); $plugin->handles($ext); Returns true if the plugin is able to handle the archive of the given format. =head2 available Alien::Build::Plugin::Extract::ArchiveTar->available($ext); Returns true if the plugin has what it needs right now to extract from the given format =head1 SEE ALSO L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Extract/CommandLine.pm 0000444 00000032507 14711220244 0015260 0 ustar 00 package Alien::Build::Plugin::Extract::CommandLine; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Path::Tiny (); use File::Which (); use File::chdir; use File::Temp qw( tempdir ); use Capture::Tiny qw( capture_merged ); # ABSTRACT: Plugin to extract an archive using command line tools our $VERSION = '2.41'; # VERSION has '+format' => 'tar'; sub gzip_cmd { _which('gzip') ? 'gzip' : undef; } sub _which { scalar File::Which::which(@_) } sub bzip2_cmd { _which('bzip2') ? 'bzip2' : undef; } sub xz_cmd { _which('xz') ? 'xz' : undef; } { my $bsd_tar; # Note: GNU tar can be iffy to very bad on windows, where absolute # paths get confused with remote tars. We used to assume that 'tar.exe' # is borked on Windows, but recent versions of Windows 10 come bundled # with bsdtar (libarchive) named 'tar.exe', and we should definitely # prefer that to ptar. sub _windows_tar_is_bsdtar { return 1 if $^O ne 'MSWin32'; return $bsd_tar if defined $bsd_tar; my($out) = capture_merged { system 'tar', '--version'; }; return $bsd_tar = $out =~ /bsdtar/ ? 1 : 0 } } sub tar_cmd { _which('bsdtar') ? 'bsdtar' # Slowlaris /usr/bin/tar doesn't seem to like pax global header # but seems to have gtar in the path by default, which is okay with it : $^O eq 'solaris' && _which('gtar') ? 'gtar' # See note above for Windows logic. : _which('tar') && _windows_tar_is_bsdtar() ? 'tar' : _which('ptar') ? 'ptar' : undef; }; sub unzip_cmd { if($^O eq 'MSWin32' && _which('tar') && _windows_tar_is_bsdtar()) { (_which('tar'), 'xf'); } else { _which('unzip') ? 'unzip' : undef; } } sub _run { my(undef, $build, @cmd) = @_; $build->log("+ @cmd"); system @cmd; die "execute failed" if $?; } sub _cp { my(undef, $build, $from, $to) = @_; require File::Copy; $build->log("copy $from => $to"); File::Copy::cp($from, $to) || die "unable to copy: $!"; } sub _mv { my(undef, $build, $from, $to) = @_; $build->log("move $from => $to"); rename($from, $to) || die "unable to rename: $!"; } sub _dcon { my($self, $src) = @_; my $name; my $cmd; if($src =~ /\.(gz|tgz|Z|taz)$/) { $self->gzip_cmd(_which('gzip')) unless defined $self->gzip_cmd; if($src =~ /\.(gz|tgz)$/) { $cmd = $self->gzip_cmd unless $self->_tar_can('tar.gz'); } elsif($src =~ /\.(Z|taz)$/) { $cmd = $self->gzip_cmd unless $self->_tar_can('tar.Z'); } } elsif($src =~ /\.(bz2|tbz)$/) { $self->bzip2_cmd(_which('bzip2')) unless defined $self->bzip2_cmd; $cmd = $self->bzip2_cmd unless $self->_tar_can('tar.bz2'); } elsif($src =~ /\.(xz|txz)$/) { $self->xz_cmd(_which('xz')) unless defined $self->xz_cmd; $cmd = $self->xz_cmd unless $self->_tar_can('tar.xz'); } if($cmd && $src =~ /\.(gz|bz2|xz|Z)$/) { $name = $src; $name =~ s/\.(gz|bz2|xz|Z)$//g; } elsif($cmd && $src =~ /\.(tgz|tbz|txz|taz)$/) { $name = $src; $name =~ s/\.(tgz|tbz|txz|taz)$/.tar/; } ($name,$cmd); } sub handles { my($class, $ext) = @_; my $self = ref $class ? $class : __PACKAGE__->new; $ext = 'tar.Z' if $ext eq 'taz'; $ext = 'tar.gz' if $ext eq 'tgz'; $ext = 'tar.bz2' if $ext eq 'tbz'; $ext = 'tar.xz' if $ext eq 'txz'; return 1 if $ext eq 'tar.gz' && $self->_tar_can('tar.gz'); return 1 if $ext eq 'tar.Z' && $self->_tar_can('tar.Z'); return 1 if $ext eq 'tar.bz2' && $self->_tar_can('tar.bz2'); return 1 if $ext eq 'tar.xz' && $self->_tar_can('tar.xz'); return 0 if $ext =~ s/\.(gz|Z)$// && (!$self->gzip_cmd); return 0 if $ext =~ s/\.bz2$// && (!$self->bzip2_cmd); return 0 if $ext =~ s/\.xz$// && (!$self->xz_cmd); return 1 if $ext eq 'tar' && $self->_tar_can('tar'); return 1 if $ext eq 'zip' && $self->_tar_can('zip'); return 0; } sub available { my(undef, $ext) = @_; # this is actually the same as handles __PACKAGE__->handles($ext); } sub init { my($self, $meta) = @_; if($self->format eq 'tar.xz' && !$self->handles('tar.xz')) { $meta->add_requires('share' => 'Alien::xz' => '0.06'); } elsif($self->format eq 'tar.bz2' && !$self->handles('tar.bz2')) { $meta->add_requires('share' => 'Alien::Libbz2' => '0.22'); } elsif($self->format =~ /^tar\.(gz|Z)$/ && !$self->handles($self->format)) { $meta->add_requires('share' => 'Alien::gzip' => '0.03'); } elsif($self->format eq 'zip' && !$self->handles('zip')) { $meta->add_requires('share' => 'Alien::unzip' => '0'); } $meta->register_hook( extract => sub { my($build, $src) = @_; my($dcon_name, $dcon_cmd) = _dcon($self, $src); if($dcon_name) { unless($dcon_cmd) { die "unable to decompress $src"; } # if we have already decompressed, then keep it. unless(-f $dcon_name) { # we don't use pipes, because that may not work on Windows. # keep the original archive, in case another extract # plugin needs it. keep the decompressed archive # in case WE need it again. my $src_tmp = Path::Tiny::path($src) ->parent ->child('x'.Path::Tiny::path($src)->basename); my $dcon_tmp = Path::Tiny::path($dcon_name) ->parent ->child('x'.Path::Tiny::path($dcon_name)->basename); $self->_cp($build, $src, $src_tmp); $self->_run($build, $dcon_cmd, "-d", $src_tmp); $self->_mv($build, $dcon_tmp, $dcon_name); } $src = $dcon_name; } if($src =~ /\.zip$/i) { $self->_run($build, $self->unzip_cmd, $src); } elsif($src =~ /\.tar/ || $src =~ /(\.tgz|\.tbz|\.txz|\.taz)$/i) { $self->_run($build, $self->tar_cmd, '-xf', $src); } else { die "not sure of archive type from extension"; } } ); } my %tars; sub _tar_can { my($self, $ext) = @_; unless(%tars) { my $name = ''; local $_; # to avoid dynamically scoped read-only $_ from upper scopes while(my $line = <DATA>) { if($line =~ /^\[ (.*) \]$/) { $name = $1; } else { $tars{$name} .= $line; } } foreach my $key (keys %tars) { $tars{$key} = unpack "u", $tars{$key}; } } my $name = "xx.$ext"; return 0 unless $tars{$name}; local $CWD = tempdir( CLEANUP => 1 ); my $cleanup = sub { my $save = $CWD; unlink $name; unlink 'xx.txt'; $CWD = '..'; rmdir $save; }; Path::Tiny->new($name)->spew_raw($tars{$name}); my @cmd = ($self->tar_cmd, 'xf', $name); if($ext eq 'zip') { @cmd = ($self->unzip_cmd, $name); } my(undef, $exit) = capture_merged { system(@cmd); $?; }; if($exit) { $cleanup->(); return 0; } my $content = eval { Path::Tiny->new('xx.txt')->slurp }; $cleanup->(); return defined $content && $content eq "xx\n"; } 1; =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Extract::CommandLine - Plugin to extract an archive using command line tools =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Extract::CommandLine' => ( format => 'tar.gz', ); =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Extract::Negotiate> instead. It picks the appropriate Extract plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin extracts from an archive in various formats using command line tools. =head1 PROPERTIES =head2 format Gives a hint as to the expected format. =head2 gzip_cmd The C<gzip> command, if available. C<undef> if not available. =head2 bzip2_cmd The C<bzip2> command, if available. C<undef> if not available. =head2 xz_cmd The C<xz> command, if available. C<undef> if not available. =head2 tar_cmd The C<tar> command, if available. C<undef> if not available. =head2 unzip_cmd The C<unzip> command, if available. C<undef> if not available. =head1 METHODS =head2 handles Alien::Build::Plugin::Extract::CommandLine->handles($ext); $plugin->handles($ext); Returns true if the plugin is able to handle the archive of the given format. =head2 available Alien::Build::Plugin::Extract::CommandLine->available($ext); Returns true if the plugin is available to extract without installing anything new. =head1 SEE ALSO L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 __DATA__ [ xx.tar ] M>'@N='AT```````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M`````````````#`P,#8T-"``,#`P-S8U(``P,#`P,C0@`#`P,#`P,#`P,#`S M(#$S-#,U,#0S-#(R(#`Q,C<P,P`@,``````````````````````````````` M```````````````````````````````````````````````````````````` M``````````````````````````````````````````!U<W1A<@`P,&]L;&ES M9P``````````````````````````````````<W1A9F8````````````````` M```````````````````P,#`P,#`@`#`P,#`P,"`````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M``````````````````````!X>`H````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` M```````````````````````````````````````````````````````````` 7```````````````````````````````` [ xx.tar.Z ] M'YV0>/"XH(.'#H"#"!,J7,BPH<.'$"-*1`BCH@T:-$``J`CCAHT:&CG"D)%Q MH\B3,T#$F$%C1@T8+6G(D`$"1@P9-V#,`%!SHL^?0(,*!5!G#ITP<DR^8<,F MS9PS0Q<:#6/&3-2%)V&$/*GQJM>O8,.*'1I0P=BS:-.J7<NVK=NW<./*G4NW 7KMV[>//JW<NWK]^_@`,+'DRXL.'#0P$` [ xx.tar.bz2 ] M0EIH.3%!629365(,+ID``$A[D-$0`8!``7^``!!AI)Y`!```""``=!JGIBC3 M30&CU`]($HHTTR:`>D#0)SI*Z'R%H*J"&3@H]P@J>U$F5BMHOC`$L-"8C!(V I"`'?*WA:(9*4U)@4)+"(V%.G]#W(_E6B'J8G]D`/Q=R13A0D%(,+ID`` [ xx.tar.gz ] M'XL("!)'=%P``WAX+G1A<@"KJ-`KJ2AAH"DP,#`P,S%1`-'F9J9@VL`(PH<" M8P5#8Q-C4P,38Q,C(P4#0R-S`V,&!0/:.@L"2HM+$HN`3LG/R<DL3L>M#J@L E+0V/.1"/*,#I(0(J*K@&V@FC8!2,@E$P"@8````U:,3F``@````` [ xx.tar.xz ] M_3=Z6%H```3FUK1&`@`A`18```!T+^6CX`?_`&!=`#Q@M.AX.4O&N38V648. M[J6L\\<_[3M*R;CASOTX?B.F\V:^)+G;\YY4"!4MLF9`*\N40G=O+K,J0"NF M0VU7J%NN(A,R^DM8@/(_YGR5CAO+1CS_YNHE:,1!G%6L1\GT``"[$^?"O*"! 9`P`!?(`0````:OY*7K'$9_L"``````196@`` [ xx.zip ] M4$L#!`H``````%5V64X:^I"B`P````,````&`!P`>'@N='AT550)``,21W1< M$D=T7'5X"P`!!/4!```$%````'AX"E!+`0(>`PH``````%5V64X:^I"B`P`` M``,````&`!@```````$```"D@0````!X>"YT>'155`4``Q)'=%QU>`L``03U >`0``!!0```!02P4&``````$``0!,````0P`````` perl5/Alien/Build/Plugin/Extract/Directory.pm 0000444 00000006526 14711220244 0015040 0 ustar 00 package Alien::Build::Plugin::Extract::Directory; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Alien::Build::Util qw( _mirror ); use Path::Tiny (); # ABSTRACT: Plugin to extract a downloaded directory to a build directory our $VERSION = '2.41'; # VERSION has '+format' => 'd'; sub handles { my(undef, $ext) = @_; $ext eq 'd' ? 1 : (); } sub available { my(undef, $ext) = @_; __PACKAGE__->handles($ext); } sub init { my($self, $meta) = @_; $meta->register_hook( extract => sub { my($build, $src) = @_; die "not a directory: $src" unless -d $src; if($build->meta_prop->{out_of_source}) { $build->install_prop->{extract} = Path::Tiny->new($src)->absolute->stringify; } else { my $dst = Path::Tiny->new('.')->absolute; # Please note: _mirror and Alien::Build::Util are ONLY # allowed to be used by core plugins. If you are writing # a non-core plugin it may be removed. That is why it # is private. _mirror $src => $dst, { verbose => 1 }; } } ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Extract::Directory - Plugin to extract a downloaded directory to a build directory =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Extract::Directory'; =head1 DESCRIPTION Some Download or Fetch plugins may produce a directory instead of an archive file. This plugin is used to mirror the directory from the Download step into a fresh directory in the Extract step. An example of when you might use this plugin is if you were using the C<git> command in the Download step, which results in a directory hierarchy. =head1 PROPERTIES =head2 format Should always set to C<d> (for directories). =head1 METHODS =head2 handles Alien::Build::Plugin::Extract::Directory->handles($ext); $plugin->handles($ext); Returns true if the plugin is able to handle the archive of the given format. Only returns true for C<d> (for directory). =head2 available Alien::Build::Plugin::Extract::Directory->available($ext); $plugin->available($ext); Returns true if the plugin can extract the given format with what is already installed. =head1 SEE ALSO L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Extract/ArchiveZip.pm 0000444 00000006146 14711220244 0015136 0 ustar 00 package Alien::Build::Plugin::Extract::ArchiveZip; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Plugin to extract a tarball using Archive::Zip our $VERSION = '2.41'; # VERSION has '+format' => 'zip'; sub handles { my($class, $ext) = @_; return 1 if $ext eq 'zip'; return 0; } sub available { my(undef, $ext) = @_; !! ( $ext eq 'zip' && eval { require Archive::Zip; 1} ); } sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'Archive::Zip' => 0); $meta->register_hook( extract => sub { my($build, $src) = @_; my $zip = Archive::Zip->new; $zip->read($src); $zip->extractTree; } ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Extract::ArchiveZip - Plugin to extract a tarball using Archive::Zip =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Extract::ArchiveZip' => ( format => 'zip', ); =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Extract::Negotiate> instead. It picks the appropriate Extract plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. B<Note>: Seriously do NOT use this plugin! L<Archive::Zip> is pretty unreliable and breaks all-the-time. If you use the negotiator plugin mentioned above, then it will prefer installing L<Alien::unzip>, which is much more reliable than L<Archive::Zip>. This plugin extracts from an archive in zip format using L<Archive::Zip>. =head2 format Gives a hint as to the expected format. This should always be C<zip>. =head1 METHODS =head2 handles Alien::Build::Plugin::Extract::ArchiveZip->handles($ext); $plugin->handles($ext); Returns true if the plugin is able to handle the archive of the given format. =head2 available Alien::Build::Plugin::Extract::ArchiveZip->available($ext); Returns true if the plugin has what it needs right now to extract from the given format =head1 SEE ALSO L<Alien::Build::Plugin::Extract::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/Wget.pm 0000444 00000012215 14711220245 0013412 0 ustar 00 package Alien::Build::Plugin::Fetch::Wget; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Temp qw( tempdir ); use Path::Tiny qw( path ); use File::Which qw( which ); use Capture::Tiny qw( capture capture_merged ); use File::chdir; use List::Util qw( pairmap ); # ABSTRACT: Plugin for fetching files using wget our $VERSION = '2.41'; # VERSION sub _wget { my $wget = defined $ENV{WGET} ? which($ENV{WGET}) : which('wget'); return undef unless defined $wget; my $output = capture_merged { system $wget, '--help' }; # The wget that BusyBox implements does not follow that same interface # as GNU wget and may not check ssl certs which is not good. return undef if $output =~ /BusyBox/; return $wget; } has wget_command => sub { _wget() }; has ssl => 0; # when bootstrapping we have to specify this plugin as a prereq # 1 is the default so that when this plugin is used directly # you also get the prereq has bootstrap_ssl => 1; sub init { my($self, $meta) = @_; $meta->add_requires('configure', 'Alien::Build::Plugin::Fetch::Wget' => '1.19') if $self->bootstrap_ssl; $meta->register_hook( fetch => sub { my($build, $url, %options) = @_; $url ||= $meta->prop->{start_url}; my($scheme) = $url =~ /^([a-z0-9]+):/i; if($scheme eq 'http' || $scheme eq 'https') { local $CWD = tempdir( CLEANUP => 1 ); my @headers; if(my $headers = $options{http_headers}) { if(ref $headers eq 'ARRAY') { my @copy = @$headers; my %headers; while(@copy) { my $key = shift @copy; my $value = shift @copy; push @{ $headers{$key} }, $value; } @headers = pairmap { "--header=$a: @{[ join ', ', @$b ]}" } %headers; } else { $build->log("Fetch for $url with http_headers that is not an array reference"); } } my($stdout, $stderr) = $self->_execute( $build, $self->wget_command, '-k', '--content-disposition', '-S', @headers, $url, ); my($path) = path('.')->children; die "no file found after wget" unless $path; my($type) = $stderr =~ /Content-Type:\s*(.*?)$/m; $type =~ s/;.*$// if $type; if($type eq 'text/html') { return { type => 'html', base => $url, content => scalar $path->slurp, }; } else { return { type => 'file', filename => $path->basename, path => $path->absolute->stringify, }; } } else { die "scheme $scheme is not supported by the Fetch::Wget plugin"; } }, ) if $self->wget_command; } sub _execute { my($self, $build, @command) = @_; $build->log("+ @command"); my($stdout, $stderr, $err) = capture { system @command; $?; }; if($err) { chomp $stderr; $stderr = [split /\n/, $stderr]->[-1]; die "error in wget fetch: $stderr"; } ($stdout, $stderr); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::Wget - Plugin for fetching files using wget =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'https://www.openssl.org/source/'; plugin 'Fetch::Wget'; }; =head1 DESCRIPTION B<WARNING>: This plugin is somewhat experimental at this time. This plugin provides a fetch based on the C<wget> command. It works with other fetch plugins (that is, the first one which succeeds will be used). Most of the time the best plugin to use will be L<Alien::Build::Plugin::Download::Negotiate>, but for some SSL bootstrapping it may be desirable to try C<wget> first. Protocols supported: C<http>, C<https> =head1 PROPERTIES =head2 wget_command The full path to the C<wget> command. The default is usually correct. =head2 ssl Ignored by this plugin. Provided for compatibility with some other fetch plugins. =head1 SEE ALSO =over 4 =item L<alienfile> =item L<Alien::Build> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/Local.pm 0000444 00000010141 14711220245 0013532 0 ustar 00 package Alien::Build::Plugin::Fetch::Local; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::chdir; use Path::Tiny (); # ABSTRACT: Plugin for fetching a local file our $VERSION = '2.41'; # VERSION has '+url' => ''; has root => undef; has ssl => 0; sub init { my($self, $meta) = @_; $meta->prop->{start_url} ||= $self->url; $self->url($meta->prop->{start_url} || 'patch'); if($self->url =~ /^file:/) { $meta->add_requires('share' => 'URI' => 0 ); $meta->add_requires('share' => 'URI::file' => 0 ); $meta->add_requires('share' => 'URI::Escape' => 0 ); } { my $root = $self->root; if(defined $root) { $root = Path::Tiny->new($root)->absolute->stringify; } else { $root = "$CWD"; } $self->root($root); } $meta->register_hook( fetch => sub { my($build, $path, %options) = @_; $build->log("plugin Fetch::Local does not support http_headers option") if $options{http_headers}; $path ||= $self->url; if($path =~ /^file:/) { my $root = URI::file->new($self->root); my $url = URI->new_abs($path, $root); $path = URI::Escape::uri_unescape($url->path); $path =~ s{^/([a-z]:)}{$1}i if $^O eq 'MSWin32'; } $path = Path::Tiny->new($path)->absolute($self->root); if(-d $path) { return { type => 'list', list => [ map { { filename => $_->basename, url => $_->stringify } } sort { $a->basename cmp $b->basename } $path->children, ], }; } elsif(-f $path) { return { type => 'file', filename => $path->basename, path => $path->stringify, tmp => 0, }; } else { die "no such file or directory $path"; } }); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::Local - Plugin for fetching a local file =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'patch/libfoo-1.00.tar.gz'; plugin 'Fetch::Local'; }; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This fetch plugin fetches files from the local file system. It is mostly useful if you intend to bundle packages (as tarballs or zip files) with your Alien. If you intend to bundle a source tree, use L<Alien::Build::Plugin::Fetch::LocalDir>. =head1 PROPERTIES =head2 url The initial URL to fetch. This may be a C<file://> style URL, or just the path on the local system. =head2 root The directory from which the URL should be relative. The default is usually reasonable. =head2 ssl This property is for compatibility with other fetch plugins, but is not used. =head1 SEE ALSO =over 4 =item L<Alien::Build::Plugin::Download::Negotiate> =item L<Alien::Build::Plugin::Fetch::LocalDir> =item L<Alien::Build> =item L<alienfile> =item L<Alien::Build::MM> =item L<Alien> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/CurlCommand.pm 0000444 00000020162 14711220245 0014710 0 ustar 00 package Alien::Build::Plugin::Fetch::CurlCommand; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Which qw( which ); use Path::Tiny qw( path ); use Capture::Tiny qw( capture ); use File::Temp qw( tempdir ); use List::Util 1.33 qw( any pairmap ); use File::chdir; # ABSTRACT: Plugin for fetching files using curl our $VERSION = '2.41'; # VERSION sub curl_command { defined $ENV{CURL} ? scalar which($ENV{CURL}) : scalar which('curl'); } has ssl => 0; has _see_headers => 0; has '+url' => ''; # when bootstrapping we have to specify this plugin as a prereq # 1 is the default so that when this plugin is used directly # you also get the prereq has bootstrap_ssl => 1; sub protocol_ok { my($class, $protocol) = @_; my $curl = $class->curl_command; return 0 unless defined $curl; my($out, $err, $exit) = capture { system $curl, '--version'; }; { # make sure curl supports the -J option. # CentOS 6 for example is recent enough # that it does not. gh#147, gh#148, gh#149 local $CWD = tempdir( CLEANUP => 1 ); my $file1 = path('foo/foo.txt'); $file1->parent->mkpath; $file1->spew("hello world\n"); my $url = 'file://' . $file1->absolute; my($out, $err, $exit) = capture { system $curl, '-O', '-J', $url; }; my $file2 = $file1->parent->child($file1->basename); unlink "$file1"; unlink "$file2"; rmdir($file1->parent); return 0 if $exit; } foreach my $line (split /\n/, $out) { if($line =~ /^Protocols:\s*(.*)\s*$/) { my %proto = map { $_ => 1 } split /\s+/, $1; return $proto{$protocol} if $proto{$protocol}; } } return 0; } sub init { my($self, $meta) = @_; $meta->prop->{start_url} ||= $self->url; $self->url($meta->prop->{start_url}); $self->url || Carp::croak('url is a required property'); $meta->add_requires('configure', 'Alien::Build::Plugin::Fetch::CurlCommand' => '1.19') if $self->bootstrap_ssl; $meta->register_hook( fetch => sub { my($build, $url, %options) = @_; $url ||= $self->url; my($scheme) = $url =~ /^([a-z0-9]+):/i; if($scheme =~ /^https?$/) { local $CWD = tempdir( CLEANUP => 1 ); my @writeout = ( "ab-filename :%{filename_effective}", "ab-content_type :%{content_type}", "ab-url :%{url_effective}", ); $build->log("writeout: $_\\n") for @writeout; path('writeout')->spew(join("\\n", @writeout)); my @headers; if(my $headers = $options{http_headers}) { if(ref $headers eq 'ARRAY') { @headers = pairmap { -H => "$a: $b" } @$headers; } else { $build->log("Fetch for $url with http_headers that is not an array reference"); } } my @command = ( $self->curl_command, '-L', '-f', '-O', '-J', -w => '@writeout', @headers, ); push @command, -D => 'head' if $self->_see_headers; push @command, $url; my($stdout, $stderr) = $self->_execute($build, @command); my %h = map { /^ab-(.*?)\s*:(.*)$/ ? ($1 => $2) : () } split /\n/, $stdout; if(-e 'head') { $build->log(" ~ $_ => $h{$_}") for sort keys %h; $build->log(" header: $_") for path('headers')->lines; } my($type) = split /;/, $h{content_type}; if($type eq 'text/html') { return { type => 'html', base => $h{url}, content => scalar path($h{filename})->slurp, }; } else { return { type => 'file', filename => $h{filename}, path => path($h{filename})->absolute->stringify, }; } } # elsif($scheme eq 'ftp') # { # if($url =~ m{/$}) # { # my($stdout, $stderr) = $self->_execute($build, $self->curl_command, -l => $url); # chomp $stdout; # return { # type => 'list', # list => [ # map { { filename => $_, url => "$url$_" } } sort split /\n/, $stdout, # ], # }; # } # # my $first_error; # # { # local $CWD = tempdir( CLEANUP => 1 ); # # my($filename) = $url =~ m{/([^/]+)$}; # $filename = 'unknown' if (! defined $filename) || ($filename eq ''); # my($stdout, $stderr) = eval { $self->_execute($build, $self->curl_command, -o => $filename, $url) }; # $first_error = $@; # if($first_error eq '') # { # return { # type => 'file', # filename => $filename, # path => path($filename)->absolute->stringify, # }; # } # } # # { # my($stdout, $stderr) = eval { $self->_execute($build, $self->curl_command, -l => "$url/") }; # if($@ eq '') # { # chomp $stdout; # return { # type => 'list', # list => [ # map { { filename => $_, url => "$url/$_" } } sort split /\n/, $stdout, # ], # }; # }; # } # # $first_error ||= 'unknown error'; # die $first_error; # # } else { die "scheme $scheme is not supported by the Fetch::CurlCommand plugin"; } }, ) if $self->curl_command; $self; } sub _execute { my($self, $build, @command) = @_; $build->log("+ @command"); my($stdout, $stderr, $err) = capture { system @command; $?; }; if($err) { chomp $stderr; $build->log($_) for split /\n/, $stderr; if($stderr =~ /Remote filename has no length/ && !!(any { /^-O$/ } @command)) { my @new_command = map { /^-O$/ ? ( -o => 'index.html' ) : /^-J$/ ? () : ($_) } @command; return $self->_execute($build, @new_command); } die "error in curl fetch"; } ($stdout, $stderr); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::CurlCommand - Plugin for fetching files using curl =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'https://www.openssl.org/source/'; plugin 'Fetch::CurlCommand'; }; =head1 DESCRIPTION This plugin provides a fetch based on the C<curl> command. It works with other fetch plugins (that is, the first one which succeeds will be used). Most of the time the best plugin to use will be L<Alien::Build::Plugin::Download::Negotiate>, but for some SSL bootstrapping it may be desirable to try C<curl> first. Protocols supported: C<http>, C<https> C<https> support requires that curl was built with SSL support. =head1 PROPERTIES =head2 curl_command The full path to the C<curl> command. The default is usually correct. =head2 ssl Ignored by this plugin. Provided for compatibility with some other fetch plugins. =head1 METHODS =head2 protocol_ok my $bool = $plugin->protocol_ok($protocol); my $bool = Alien::Build::Plugin::Fetch::CurlCommand->protocol_ok($protocol); =head1 SEE ALSO =over 4 =item L<alienfile> =item L<Alien::Build> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/NetFTP.pm 0000444 00000012647 14711220246 0013616 0 ustar 00 package Alien::Build::Plugin::Fetch::NetFTP; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); use File::Temp (); use Path::Tiny qw( path ); # ABSTRACT: Plugin for fetching files using Net::FTP our $VERSION = '2.41'; # VERSION has '+url' => ''; has ssl => 0; has passive => 0; sub init { my($self, $meta) = @_; $meta->prop->{start_url} ||= $self->url; $self->url($meta->prop->{start_url}); $self->url || Carp::croak('url is a required property'); $meta->add_requires('share' => 'Net::FTP' => 0 ); $meta->add_requires('share' => 'URI' => 0 ); $meta->add_requires('share' => 'Alien::Build::Plugin::Fetch::NetFTP' => '0.61') if $self->passive; $meta->register_hook( fetch => sub { my($build, $url, %options) = @_; $url ||= $self->url; $build->log("plugin Fetch::NetFTP does not support http_headers option") if $options{http_headers}; $url = URI->new($url); die "Fetch::NetFTP does not support @{[ $url->scheme ]}" unless $url->scheme eq 'ftp'; $build->log("trying passive mode FTP first") if $self->passive; my $ftp = _ftp_connect($url, $self->passive); my $path = $url->path; unless($path =~ m!/$!) { my(@parts) = split /\//, $path; my $filename = pop @parts; my $dir = join '/', @parts; my $path = eval { $ftp->cwd($dir) or die; my $tdir = File::Temp::tempdir( CLEANUP => 1); my $path = path("$tdir/$filename")->stringify; unless(eval { $ftp->get($filename, $path) }) # NAT problem? try to use passive mode { $ftp->quit; $build->log("switching to @{[ $self->passive ? 'active' : 'passive' ]} mode"); $ftp = _ftp_connect($url, !$self->passive); $ftp->cwd($dir) or die; $ftp->get($filename, $path) or die; } $path; }; if(defined $path) { return { type => 'file', filename => $filename, path => $path, }; } $path .= "/"; } $ftp->quit; $ftp = _ftp_connect($url, $self->passive); $ftp->cwd($path) or die "unable to fetch $url as either a directory or file"; my $list = eval { $ftp->ls }; unless(defined $list) # NAT problem? try to use passive mode { $ftp->quit; $build->log("switching to @{[ $self->passive ? 'active' : 'passive' ]} mode"); $ftp = _ftp_connect($url, !$self->passive); $ftp->cwd($path) or die "unable to fetch $url as either a directory or file"; $list = $ftp->ls; die "cannot list directory $path on $url" unless defined $list; } die "no files found at $url" unless @$list; $path .= '/' unless $path =~ /\/$/; return { type => 'list', list => [ map { my $filename = $_; my $furl = $url->clone; $furl->path($path . $filename); my %h = ( filename => $filename, url => $furl->as_string, ); \%h; } sort @$list, ], }; }); $self; } sub _ftp_connect { my $url = shift; my $is_passive = shift || 0; my $ftp = Net::FTP->new( $url->host, Port =>$url->port, Passive =>$is_passive, ) or die "error fetching $url: $@"; $ftp->login($url->user, $url->password) or die "error on login $url: @{[ $ftp->message ]}"; $ftp->binary; $ftp; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::NetFTP - Plugin for fetching files using Net::FTP =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'ftp://ftp.gnu.org/gnu/make'; plugin 'Fetch::NetFTP'; }; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This fetch plugin fetches files and directory listings via the C<ftp>, protocol using L<Net::FTP>. =head1 PROPERTIES =head2 url The initial URL to fetch. This may be a directory or the final file. =head2 ssl This property is for compatibility with other fetch plugins, but is not used. =head2 passive If set to true, try passive mode FIRST. By default it will try an active mode, then passive mode. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/LWP.pm 0000444 00000010142 14711220246 0013144 0 ustar 00 package Alien::Build::Plugin::Fetch::LWP; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); # ABSTRACT: Plugin for fetching files using LWP our $VERSION = '2.41'; # VERSION has '+url' => ''; has ssl => 0; sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'LWP::UserAgent' => 0 ); $meta->prop->{start_url} ||= $self->url; $self->url($meta->prop->{start_url}); $self->url || Carp::croak('url is a required property'); if($self->url =~ /^https:/ || $self->ssl) { $meta->add_requires('share' => 'LWP::Protocol::https' => 0 ); } $meta->register_hook( fetch => sub { my($build, $url, %options) = @_; $url ||= $self->url; my @headers; if(my $headers = $options{http_headers}) { if(ref $headers eq 'ARRAY') { @headers = @$headers; } else { $build->log("Fetch for $url with http_headers that is not an array reference"); } } my $ua = LWP::UserAgent->new; $ua->env_proxy; my $res = $ua->get($url, @headers); die "error fetching $url: @{[ $res->status_line ]}" unless $res->is_success; my($type, $charset) = $res->content_type_charset; my $base = $res->base; my $filename = $res->filename; if($type eq 'text/html') { return { type => 'html', charset => $charset, base => "$base", content => $res->decoded_content || $res->content, }; } elsif($type eq 'text/ftp-dir-listing') { return { type => 'dir_listing', base => "$base", content => $res->decoded_content || $res->content, }; } else { return { type => 'file', filename => $filename || 'downloadedfile', content => $res->content, }; } }); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::LWP - Plugin for fetching files using LWP =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'http://ftp.gnu.org/gnu/make'; plugin 'Fetch::LWP'; }; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This fetch plugin fetches files and directory listings via the C<http> C<https>, C<ftp>, C<file> protocol using L<LWP>. If the URL specified uses the C<https> scheme, then the required SSL modules will automatically be injected as requirements. If your initial URL is not C<https>, but you know that it will be needed on a subsequent request you can use the ssl property below. =head1 PROPERTIES =head2 url The initial URL to fetch. This may be a directory listing (in HTML) or the final file. =head2 ssl If set to true, then the SSL modules required to make an C<https> connection will be added as prerequisites. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/HTTPTiny.pm 0000444 00000013632 14711220246 0014134 0 ustar 00 package Alien::Build::Plugin::Fetch::HTTPTiny; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Basename (); use Alien::Build::Util qw( _ssl_reqs ); use Carp (); # ABSTRACT: Plugin for fetching files using HTTP::Tiny our $VERSION = '2.41'; # VERSION has '+url' => ''; has ssl => 0; # ignored for compatability has bootstrap_ssl => 1; sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'HTTP::Tiny' => '0.044' ); $meta->add_requires('share' => 'URI' => 0 ); $meta->prop->{start_url} ||= $self->url; $self->url($meta->prop->{start_url}); $self->url || Carp::croak('url is a required property'); if($self->url =~ /^https:/ || $self->ssl) { my $reqs = _ssl_reqs; foreach my $mod (sort keys %$reqs) { $meta->add_requires('share' => $mod => $reqs->{$mod}); } } $meta->register_hook( fetch => sub { my($build, $url, %options) = @_; $url ||= $self->url; my %headers; if(my $headers = $options{http_headers}) { if(ref $headers eq 'ARRAY') { my @headers = @$headers; while(@headers) { my $key = shift @headers; my $value = shift @headers; unless(defined $key && defined $value) { $build->log("Fetch for $url with http_headers contains undef key or value"); next; } push @{ $headers{$key} }, $value; } } else { $build->log("Fetch for $url with http_headers that is not an array reference"); } } my $ua = HTTP::Tiny->new( agent => "Alien-Build/@{[ $Alien::Build::VERSION || 'dev' ]} " ); my $res = $ua->get($url, { headers => \%headers }); unless($res->{success}) { my $status = $res->{status} || '---'; my $reason = $res->{reason} || 'unknown'; $build->log("$status $reason fetching $url"); if($status == 599) { $build->log("exception: $_") for split /\n/, $res->{content}; my($can_ssl, $why_ssl) = HTTP::Tiny->can_ssl; if(! $can_ssl) { if($res->{redirects}) { foreach my $redirect (@{ $res->{redirects} }) { if(defined $redirect->{headers}->{location} && $redirect->{headers}->{location} =~ /^https:/) { $build->log("An attempt at a SSL URL https was made, but your HTTP::Tiny does not appear to be able to use https."); $build->log("Please see: https://metacpan.org/pod/Alien::Build::Manual::FAQ#599-Internal-Exception-errors-downloading-packages-from-the-internet"); } } } } } die "error fetching $url: $status $reason"; } my($type) = split /;/, $res->{headers}->{'content-type'}; $type = lc $type; my $base = URI->new($res->{url}); my $filename = File::Basename::basename do { my $name = $base->path; $name =~ s{/$}{}; $name }; # TODO: this doesn't get exercised by t/bin/httpd if(my $disposition = $res->{headers}->{"content-disposition"}) { # Note: from memory without quotes does not match the spec, # but many servers actually return this sort of value. if($disposition =~ /filename="([^"]+)"/ || $disposition =~ /filename=([^\s]+)/) { $filename = $1; } } if($type eq 'text/html') { return { type => 'html', base => $base->as_string, content => $res->{content}, }; } else { return { type => 'file', filename => $filename || 'downloadedfile', content => $res->{content}, }; } }); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::HTTPTiny - Plugin for fetching files using HTTP::Tiny =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'http://ftp.gnu.org/gnu/make'; plugin 'Fetch::HTTPTiny'; }; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This fetch plugin fetches files and directory listings via the C<http> and C<https> protocol using L<HTTP::Tiny>. If the URL specified uses the C<https> scheme, then the required SSL modules will automatically be injected as requirements. If your initial URL is not C<https>, but you know that it will be needed on a subsequent request you can use the ssl property below. =head1 PROPERTIES =head2 url The initial URL to fetch. This may be a directory listing (in HTML) or the final file. =head2 ssl If set to true, then the SSL modules required to make an C<https> connection will be added as prerequisites. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch/LocalDir.pm 0000444 00000007505 14711220246 0014204 0 ustar 00 package Alien::Build::Plugin::Fetch::LocalDir; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::chdir; use Path::Tiny (); # ABSTRACT: Plugin for fetching a local directory our $VERSION = '2.41'; # VERSION has root => undef; has ssl => 0; sub init { my($self, $meta) = @_; my $url = $meta->prop->{start_url} || 'patch'; $meta->add_requires('configure' => 'Alien::Build::Plugin::Fetch::LocalDir' => '0.72' ); if($url =~ /^file:/) { $meta->add_requires('share' => 'URI' => 0 ); $meta->add_requires('share' => 'URI::file' => 0 ); } { my $root = $self->root; if(defined $root) { $root = Path::Tiny->new($root)->absolute->stringify; } else { $root = "$CWD"; } $self->root($root); } $meta->register_hook( fetch => sub { my($build, $path, %options) = @_; $build->log("plugin Fetch::LocalDir does not support http_headers option") if $options{http_headers}; $path ||= $url; if($path =~ /^file:/) { my $root = URI::file->new($self->root); my $url = URI->new_abs($path, $root); $path = $url->path; $path =~ s{^/([a-z]:)}{$1}i if $^O eq 'MSWin32'; } $path = Path::Tiny->new($path)->absolute($self->root); if(-d $path) { return { type => 'file', filename => $path->basename, path => $path->stringify, tmp => 0, }; } else { $build->log("path $path is not a directory"); $build->log("(you specified $url with root @{[ $self->root ]})"); die "$path is not a directory"; } } ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch::LocalDir - Plugin for fetching a local directory =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'patch/libfoo-1.00/'; plugin 'Fetch::LocalDir'; }; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This fetch plugin fetches files from the local file system. It is mostly useful if you intend to bundle source with your Alien. If you are bundling tarballs see L<Alien::Build::Plugin::Fetch::Local>. =head1 PROPERTIES =head2 root The directory from which the start URL should be relative. The default is usually reasonable. =head2 ssl This property is for compatibility with other fetch plugins, but is not used. =head1 SEE ALSO =over 4 =item L<Alien::Build::Plugin::Download::Negotiate> =item L<Alien::Build::Plugin::Fetch::Local> =item L<Alien::Build> =item L<alienfile> =item L<Alien::Build::MM> =item L<Alien> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Download/Negotiate.pm 0000444 00000020714 14711220247 0015146 0 ustar 00 package Alien::Build::Plugin::Download::Negotiate; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Alien::Build::Util qw( _has_ssl ); use Carp (); # ABSTRACT: Download negotiation plugin our $VERSION = '2.41'; # VERSION has '+url' => undef; has 'filter' => undef; has 'version' => undef; has 'ssl' => 0; has 'passive' => 0; has 'scheme' => undef; has 'bootstrap_ssl' => 0; has 'prefer' => 1; has 'decoder' => undef; sub pick { my($self) = @_; my($fetch, @decoders) = $self->_pick; if($self->decoder) { @decoders = ref $self->decoder ? @{ $self->decoder } : ($self->decoder); } ($fetch, @decoders); } sub _pick_decoder { my($self) = @_; if(eval { require Mojo::DOM58; Mojo::DOM58->VERSION(1.00); 1 }) { return "Decode::Mojo" } elsif(eval { require Mojo::DOM; require Mojolicious; Mojolicious->VERSION('7.00'); 1 }) { return "Decode::Mojo" } elsif(eval { require HTML::LinkExtor; 1; }) { return "Decode::HTML" } else { return "Decode::Mojo" } } sub _pick { my($self) = @_; $self->scheme( $self->url !~ m!(ftps?|https?|file):!i ? 'file' : $self->url =~ m!^([a-z]+):!i ) unless defined $self->scheme; if($self->scheme eq 'https' || ($self->scheme eq 'http' && $self->ssl)) { if($self->bootstrap_ssl && ! _has_ssl) { return (['Fetch::CurlCommand','Fetch::Wget'], __PACKAGE__->_pick_decoder); } elsif(_has_ssl) { return ('Fetch::HTTPTiny', __PACKAGE__->_pick_decoder); } elsif(do { require Alien::Build::Plugin::Fetch::CurlCommand; Alien::Build::Plugin::Fetch::CurlCommand->protocol_ok('https') }) { return ('Fetch::CurlCommand', __PACKAGE__->_pick_decoder); } else { return ('Fetch::HTTPTiny', __PACKAGE__->_pick_decoder); } } elsif($self->scheme eq 'http') { return ('Fetch::HTTPTiny', __PACKAGE__->_pick_decoder); } elsif($self->scheme eq 'ftp') { if($ENV{ftp_proxy} || $ENV{all_proxy}) { return $self->scheme =~ /^ftps?/ ? ('Fetch::LWP', 'Decode::DirListing', __PACKAGE__->_pick_decoder) : ('Fetch::LWP', __PACKAGE__->_pick_decoder); } else { return ('Fetch::NetFTP'); } } elsif($self->scheme eq 'file') { return ('Fetch::Local'); } else { die "do not know how to handle scheme @{[ $self->scheme ]} for @{[ $self->url ]}"; } } sub init { my($self, $meta) = @_; unless(defined $self->url) { if(defined $meta->prop->{start_url}) { $self->url($meta->prop->{start_url}); } else { Carp::croak "url is a required property unless you use the start_url directive"; } } $meta->add_requires('share' => 'Alien::Build::Plugin::Download::Negotiate' => '0.61') if $self->passive; $meta->prop->{plugin_download_negotiate_default_url} = $self->url; my($fetch, @decoders) = $self->pick; $fetch = [ $fetch ] unless ref $fetch; foreach my $fetch (@$fetch) { my @args; push @args, ssl => $self->ssl; # For historical reasons, we pass the URL into older fetch plugins, because # this used to be the interface. Using start_url is now preferred! push @args, url => $self->url if $fetch =~ /^Fetch::(HTTPTiny|LWP|Local|LocalDir|NetFTP|CurlCommand)$/; push @args, passive => $self->passive if $fetch eq 'Fetch::NetFTP'; push @args, bootstrap_ssl => $self->bootstrap_ssl if $self->bootstrap_ssl; $meta->apply_plugin($fetch, @args); } if($self->version) { $meta->apply_plugin($_) for @decoders; if(defined $self->prefer && ref($self->prefer) eq 'CODE') { $meta->add_requires('share' => 'Alien::Build::Plugin::Download::Negotiate' => '1.30'); $meta->register_hook( prefer => $self->prefer, ); } elsif($self->prefer) { $meta->apply_plugin('Prefer::SortVersions', (defined $self->filter ? (filter => $self->filter) : ()), version => $self->version, ); } else { $meta->add_requires('share' => 'Alien::Build::Plugin::Download::Negotiate' => '1.30'); } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Download::Negotiate - Download negotiation plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'http://ftp.gnu.org/gnu/make'; plugin 'Download' => ( filter => qr/^make-.*\.tar\.gz$/, version => qr/([0-9\.]+)/, ); }; =head1 DESCRIPTION This is a negotiator plugin for downloading packages from the internet. This plugin picks the best Fetch, Decode and Prefer plugins to do the actual work. Which plugins are picked depend on the properties you specify, your platform and environment. It is usually preferable to use a negotiator plugin rather than the Fetch, Decode and Prefer plugins directly from your L<alienfile>. =head1 PROPERTIES =head2 url [DEPRECATED] use C<start_url> instead. The Initial URL for your package. This may be a directory listing (either in HTML or ftp listing format) or the final tarball intended to be downloaded. =head2 filter This is a regular expression that lets you filter out files that you do not want to consider downloading. For example, if the directory listing contained tarballs and readme files like this: foo-1.0.0.tar.gz foo-1.0.0.readme You could specify a filter of C<qr/\.tar\.gz$/> to make sure only tarballs are considered for download. =head2 version Regular expression to parse out the version from a filename. The regular expression should store the result in C<$1>. Note: if you provide a C<version> property, this plugin will assume that you will be downloading an initial index to select package downloads from. Depending on the protocol (and typically this is the case for http and HTML) that may bring in additional dependencies. If start_url points to a tarball or other archive directly (without needing to do through an index selection process), it is recommended that you not specify this property. =head2 ssl If your initial URL does not need SSL, but you know ahead of time that a subsequent request will need it (for example, if your directory listing is on C<http>, but includes links to C<https> URLs), then you can set this property to true, and the appropriate Perl SSL modules will be loaded. =head2 passive If using FTP, attempt a passive mode transfer first, before trying an active mode transfer. =head2 bootstrap_ssl If set to true, then the download negotiator will avoid using plugins that have a dependency on L<Net::SSLeay>, or other Perl SSL modules. The intent for this option is to allow OpenSSL to be alienized and be a useful optional dependency for L<Net::SSLeay>. The implementation may improve over time, but as of this writing, this option relies on you having a working C<curl> or C<wget> with SSL support in your C<PATH>. =head2 prefer How to sort candidates for selection. This should be one of three types of values: =over 4 =item code reference This will be used as the prefer hook. =item true value Use L<Alien::Build::Plugin::Prefer::SortVersions>. =item false value Don't set any preference at all. A hook must be installed, or another prefer plugin specified. =back =head2 decoder Override the detected decoder. =head1 METHODS =head2 pick my($fetch, @decoders) = $plugin->pick; Returns the fetch plugin and any optional decoders that should be used. =head1 SEE ALSO L<Alien::Build::Plugin::Prefer::BadVersion>, L<Alien::Build::Plugin::Prefer::GoodVersion> L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Fetch.pod 0000444 00000004100 14711220247 0012646 0 ustar 00 # PODNAME: Alien::Build::Plugin::Fetch # ABSTRACT: Fetch Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Fetch - Fetch Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'http://ftp.gnu.org/gnu/make'; plugin 'Download'; }; =head1 DESCRIPTION Fetch plugins retrieve single resources from the internet. The difference between a Fetch plugin and a Download plugin is that Download plugin may fetch several resources from the internet (usually using a Fetch plugin), before finding the final archive. Normally you will not need to use Fetch plugins directly but should instead use the L<Alien::Build::Plugin::Download::Negotiate> plugin, which will pick the best plugins for your given URL. =over 4 =item L<Alien::Build::Plugin::Fetch::HTTPTiny> =item L<Alien::Build::Plugin::Fetch::Local> =item L<Alien::Build::Plugin::Fetch::LWP> =item L<Alien::Build::Plugin::Fetch::NetFTP> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Build.pod 0000444 00000003251 14711220247 0012662 0 ustar 00 # PODNAME: Alien::Build::Plugin::Build # ABSTRACT: Build Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Build - Build Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS For autoconf: use alienfile; plugin 'Build::Autoconf'; for unixy (even on windows): use alienfile; plugin 'Build::MSYS'; =head1 DESCRIPTION Build plugins provide tools for building your package once it has been downloaded and extracted. =over 4 =item L<Alien::Build::Plugin::Build::Autoconf> =item L<Alien::Build::Plugin::Build::MSYS> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/Tail.pm 0000444 00000003246 14711220250 0013234 0 ustar 00 package Alien::Build::Plugin::Core::Tail; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Core tail setup plugin our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; if($meta->prop->{out_of_source}) { $meta->add_requires('configure' => 'Alien::Build' => '1.08'); } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::Tail - Core tail setup plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin does some core tail setup for you. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/Gather.pm 0000444 00000012620 14711220250 0013551 0 ustar 00 package Alien::Build::Plugin::Core::Gather; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Env qw( @PATH @PKG_CONFIG_PATH ); use Path::Tiny (); use File::chdir; use Alien::Build::Util qw( _mirror _destdir_prefix ); use JSON::PP (); # ABSTRACT: Core gather plugin our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->default_hook( $_ => sub {}, ) for qw( gather_system gather_share ); $meta->around_hook( gather_share => sub { my($orig, $build) = @_; local $ENV{PATH} = $ENV{PATH}; local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH}; unshift @PATH, Path::Tiny->new('bin')->absolute->stringify if -d 'bin'; for my $dir (qw(share lib)) { unshift @PKG_CONFIG_PATH, Path::Tiny->new("$dir/pkgconfig")->absolute->stringify if -d "$dir/pkgconfig"; } $orig->($build) } ); foreach my $type (qw( share ffi )) { $meta->around_hook( "gather_$type" => sub { my($orig, $build) = @_; if($build->meta_prop->{destdir}) { my $destdir = $ENV{DESTDIR}; if(-d $destdir) { my $src = Path::Tiny->new(_destdir_prefix($ENV{DESTDIR}, $build->install_prop->{prefix})); my $dst = Path::Tiny->new($build->install_prop->{stage}); my $res = do { local $CWD = "$src"; $orig->($build); }; $build->log("mirror $src => $dst"); $dst->mkpath; # Please note: _mirror and Alien::Build::Util are ONLY # allowed to be used by core plugins. If you are writing # a non-core plugin it may be removed. That is why it # is private. _mirror("$src", "$dst", { verbose => 1, filter => $build->meta_prop->{$type eq 'share' ? 'destdir_filter' : 'destdir_ffi_filter'}, }); return $res; } else { die "nothing was installed into destdir" if $type eq 'share'; } } else { local $CWD = $build->install_prop->{stage}; my $ret = $orig->($build); # if we are not doing a double staged install we want to substitute the install # prefix with the runtime prefix. my $old = $build->install_prop->{prefix}; my $new = $build->runtime_prop->{prefix}; foreach my $flag (qw( cflags cflags_static libs libs_static )) { next unless defined $build->runtime_prop->{$flag}; $build->runtime_prop->{$flag} =~ s{(-I|-L|-LIBPATH:)\Q$old\E}{$1 . $new}eg; } return $ret; } } ); } $meta->after_hook( $_ => sub { my($build) = @_; die "stage is not defined. be sure to call set_stage on your Alien::Build instance" unless $build->install_prop->{stage}; my $stage = Path::Tiny->new($build->install_prop->{stage}); $build->log("mkdir -p $stage/_alien"); $stage->child('_alien')->mkpath; # drop a alien.json file for the runtime properties $stage->child('_alien/alien.json')->spew( JSON::PP->new->pretty->canonical(1)->ascii->encode($build->runtime_prop) ); # copy the alienfile, if we managed to keep it around. if($build->meta->filename && -r $build->meta->filename && $build->meta->filename !~ /\.(pm|pl)$/ && ! -d $build->meta->filename) { Path::Tiny->new($build->meta->filename) ->copy($stage->child('_alien/alienfile')); } if($build->install_prop->{patch} && -d $build->install_prop->{patch}) { # Please note: _mirror and Alien::Build::Util are ONLY # allowed to be used by core plugins. If you are writing # a non-core plugin it may be removed. That is why it # is private. _mirror($build->install_prop->{patch}, $stage->child('_alien/patch')->stringify); } }, ) for qw( gather_share gather_system ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::Gather - Core gather plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin helps make the gather stage work. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/FFI.pm 0000444 00000003331 14711220251 0012743 0 ustar 00 package Alien::Build::Plugin::Core::FFI; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Core FFI plugin our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->default_hook( $_ => sub {}, ) for qw( build_ffi gather_ffi ); $meta->prop->{destdir_ffi_filter} = '^dynamic'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::FFI - Core FFI plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin helps make the build_ffi work. You should not need to interact with it directly. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/Override.pm 0000444 00000003322 14711220251 0014116 0 ustar 00 package Alien::Build::Plugin::Core::Override; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Core override plugin our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->default_hook( override => sub { my($build) = @_; return $ENV{ALIEN_INSTALL_TYPE} || ''; }, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::Override - Core override plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin implements the C<ALIEN_INSTALL_TYPE> environment variable. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/CleanInstall.pm 0000444 00000004240 14711220252 0014711 0 ustar 00 package Alien::Build::Plugin::Core::CleanInstall; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Path::Tiny (); # ABSTRACT: Implementation for clean_install hook. our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->default_hook( clean_install => sub { my($build) = @_; my $root = Path::Tiny->new( $build->runtime_prop->{prefix} ); if(-d $root) { foreach my $child ($root->children) { if($child->basename eq '_alien') { $build->log("keeping $child"); } else { $build->log("removing $child"); $child->remove_tree({ safe => 0}); } } } } ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::CleanInstall - Implementation for clean_install hook. =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin implements the default C<clean_install> hook. You shouldn't use it directly. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/Download.pm 0000444 00000010260 14711220252 0014106 0 ustar 00 package Alien::Build::Plugin::Core::Download; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Path::Tiny (); use Alien::Build::Util qw( _mirror ); # ABSTRACT: Core download plugin our $VERSION = '2.41'; # VERSION sub _hook { my($build) = @_; my $res = $build->fetch; if($res->{type} =~ /^(?:html|dir_listing)$/) { my $type = $res->{type}; $type =~ s/_/ /; $build->log("decoding $type"); $res = $build->decode($res); } if($res->{type} eq 'list') { $res = $build->prefer($res); die "no matching files in listing" if @{ $res->{list} } == 0; my $version = $res->{list}->[0]->{version}; my($pick, @other) = map { $_->{url} } @{ $res->{list} }; if(@other > 8) { splice @other, 7; push @other, '...'; } $build->log("candidate *$pick"); $build->log("candidate $_") for @other; $res = $build->fetch($pick); if($version) { $version =~ s/\.+$//; $build->log("setting version based on archive to $version"); $build->runtime_prop->{version} = $version; } } if($res->{type} eq 'file') { my $alienfile = $res->{filename}; $build->log("downloaded $alienfile"); if($res->{content}) { my $tmp = Alien::Build::TempDir->new($build, "download"); my $path = Path::Tiny->new("$tmp/$alienfile"); $path->spew_raw($res->{content}); $build->install_prop->{download} = $path->stringify; $build->install_prop->{complete}->{download} = 1; return $build; } elsif($res->{path}) { if(defined $res->{tmp} && !$res->{tmp}) { if(-e $res->{path}) { $build->install_prop->{download} = $res->{path}; $build->install_prop->{complete}->{download} = 1; } else { die "not a file or directory: @{[ $res->{path} ]}"; } } else { my $from = Path::Tiny->new($res->{path}); my $tmp = Alien::Build::TempDir->new($build, "download"); my $to = Path::Tiny->new("$tmp/@{[ $from->basename ]}"); if(-d $res->{path}) { # Please note: _mirror and Alien::Build::Util are ONLY # allowed to be used by core plugins. If you are writing # a non-core plugin it may be removed. That is why it # is private. _mirror $from, $to; } else { require File::Copy; File::Copy::copy( "$from" => "$to", ) || die "copy $from => $to failed: $!"; } $build->install_prop->{download} = $to->stringify; $build->install_prop->{complete}->{download} = 1; } return $build; } die "file without content or path"; } die "unknown fetch response type: @{[ $res->{type} ]}"; } sub init { my($self, $meta) = @_; $meta->default_hook(download => \&_hook); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::Download - Core download plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin does some core download logic. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/Legacy.pm 0000444 00000004703 14711220252 0013550 0 ustar 00 package Alien::Build::Plugin::Core::Legacy; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Core Alien::Build plugin to maintain compatibility with legacy Alien::Base our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->after_hook( $_ => sub { my($build) = @_; $build->log("adding legacy hash to config"); my $runtime = $build->runtime_prop; if($runtime->{cflags} && ! defined $runtime->{cflags_static}) { $runtime->{cflags_static} = $runtime->{cflags}; } if($runtime->{libs} && ! defined $runtime->{libs_static}) { $runtime->{libs_static} = $runtime->{libs}; } $runtime->{legacy}->{finished_installing} = 1; $runtime->{legacy}->{install_type} = $runtime->{install_type}; $runtime->{legacy}->{version} = $runtime->{version}; $runtime->{legacy}->{original_prefix} = $runtime->{prefix}; } ) for qw( gather_system gather_share ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::Legacy - Core Alien::Build plugin to maintain compatibility with legacy Alien::Base =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin provides some compatibility with the legacy L<Alien::Build::ModuleBuild> interfaces. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core/Setup.pm 0000444 00000005217 14711220252 0013445 0 ustar 00 package Alien::Build::Plugin::Core::Setup; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Config; use File::Which qw( which ); # ABSTRACT: Core setup plugin our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->prop->{platform} ||= {}; $self->_platform($meta->prop->{platform}); } sub _platform { my(undef, $hash) = @_; if($^O eq 'MSWin32' && $Config{ccname} eq 'cl') { $hash->{compiler_type} = 'microsoft'; } else { $hash->{compiler_type} = 'unix'; } if($^O eq 'MSWin32') { $hash->{system_type} = 'windows-unknown'; if(defined &Win32::BuildNumber) { $hash->{system_type} = 'windows-activestate'; } elsif($Config{myuname} =~ /strawberry-perl/) { $hash->{system_type} = 'windows-strawberry'; } elsif($hash->{compiler_type} eq 'microsoft') { $hash->{system_type} = 'windows-microsoft'; } else { my $uname_exe = which('uname'); if($uname_exe) { my $uname = `$uname_exe`; if($uname =~ /^(MINGW)(32|64)_NT/) { $hash->{system_type} = 'windows-' . lc $1; } } } } elsif($^O =~ /^(VMS)$/) { # others probably belong in here... $hash->{system_type} = lc $^O; } else { $hash->{system_type} = 'unix'; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core::Setup - Core setup plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # already loaded =head1 DESCRIPTION This plugin does some core setup for you. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base::ModuleBuild> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/PkgConfig/Negotiate.pm 0000444 00000011774 14711220253 0015251 0 ustar 00 package Alien::Build::Plugin::PkgConfig::Negotiate; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Alien::Build::Plugin::PkgConfig::PP; use Alien::Build::Plugin::PkgConfig::LibPkgConf; use Alien::Build::Plugin::PkgConfig::CommandLine; use Alien::Build::Util qw( _perl_config ); use Carp (); # ABSTRACT: Package configuration negotiation plugin our $VERSION = '2.41'; # VERSION has '+pkg_name' => sub { Carp::croak "pkg_name is a required property"; }; has atleast_version => undef; has exact_version => undef; has max_version => undef; has minimum_version => undef; sub pick { my($class) = @_; return $ENV{ALIEN_BUILD_PKG_CONFIG} if $ENV{ALIEN_BUILD_PKG_CONFIG}; if(Alien::Build::Plugin::PkgConfig::LibPkgConf->available) { return 'PkgConfig::LibPkgConf'; } if(Alien::Build::Plugin::PkgConfig::CommandLine->available) { # TODO: determine environment or flags necessary for using pkg-config # on solaris 64 bit. # Some advice on pkg-config and 64 bit Solaris # https://docs.oracle.com/cd/E53394_01/html/E61689/gplhi.html my $is_solaris64 = (_perl_config('osname') eq 'solaris' && _perl_config('ptrsize') == 8); # PkgConfig.pm is more reliable on windows my $is_windows = _perl_config('osname') eq 'MSWin32'; if(!$is_solaris64 && !$is_windows) { return 'PkgConfig::CommandLine'; } } if(Alien::Build::Plugin::PkgConfig::PP->available) { return 'PkgConfig::PP'; } else { # this is a fata error. because we check for a pkg-config implementation # at configure time, we expect at least one of these to work. (and we # fallback on installing PkgConfig.pm as a prereq if nothing else is avail). # we therefore expect at least one of these to work, if not, then the configuration # of the system has shifted from underneath us. Carp::croak("Could not find an appropriate pkg-config or pkgconf implementation, please install PkgConfig.pm, PkgConfig::LibPkgConf, pkg-config or pkgconf"); } } sub init { my($self, $meta) = @_; my $plugin = $self->pick; Alien::Build->log("Using PkgConfig plugin: $plugin"); if(ref($self->pkg_name) eq 'ARRAY') { $meta->add_requires('configure', 'Alien::Build::Plugin::PkgConfig::Negotiate' => '0.79'); } if($self->atleast_version || $self->exact_version || $self->max_version) { $meta->add_requires('configure', 'Alien::Build::Plugin::PkgConfig::Negotiate' => '1.53'); } my @args; push @args, pkg_name => $self->pkg_name; push @args, register_prereqs => 0; foreach my $method (map { "${_}_version" } qw( minimum atleast exact max )) { push @args, $method => $self->$method if defined $self->$method; } $meta->apply_plugin($plugin, @args); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::PkgConfig::Negotiate - Package configuration negotiation plugin =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'PkgConfig' => ( pkg_name => 'libfoo', ); =head1 DESCRIPTION This plugin provides Probe and Gather steps for pkg-config based packages. It picks the best C<PkgConfig> plugin depending your platform and environment. =head1 PROPERTIES =head2 pkg_name The package name. =head2 atleast_version The minimum required version that is acceptable version as provided by the system. =head2 exact_version The exact required version that is acceptable version as provided by the system. =head2 max_version The max required version that is acceptable version as provided by the system. =head2 minimum_version Alias for C<atleast_version> for backward compatibility. =head1 METHODS =head2 pick my $name = Alien::Build::Plugijn::PkgConfig::Negotiate->pick; Returns the name of the negotiated plugin. =head1 ENVIRONMENT =over 4 =item ALIEN_BUILD_PKG_CONFIG If set, this plugin will be used instead of the build in logic which attempts to automatically pick the best plugin. =back =head1 SEE ALSO L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/PkgConfig/MakeStatic.pm 0000444 00000006525 14711220253 0015355 0 ustar 00 package Alien::Build::Plugin::PkgConfig::MakeStatic; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Path::Tiny (); # ABSTRACT: Convert .pc files into static our $VERSION = '2.41'; # VERSION has path => undef; sub _convert { my($self, $build, $path) = @_; die "unable to read $path" unless -r $path; die "unable to write $path" unless -w $path; $build->log("converting $path to static"); my %h = map { my($key, $value) = /^(.*?):(.*?)$/; $value =~ s{^\s+}{}; $value =~ s{\s+$}{}; ($key => $value); } grep /^(?:Libs|Cflags)(?:\.private)?:/, $path->lines; $h{Cflags} = '' unless defined $h{Cflags}; $h{Libs} = '' unless defined $h{Libs}; $h{Cflags} .= ' ' . $h{"Cflags.private"} if defined $h{"Cflags.private"}; $h{Libs} .= ' ' . $h{"Libs.private"} if defined $h{"Libs.private"}; $h{"Cflags.private"} = ''; $h{"Libs.private"} = ''; $path->edit_lines(sub { if(/^(.*?):/) { my $key = $1; if(defined $h{$key}) { s/^(.*?):.*$/$1: $h{$key} /; delete $h{$key}; } } }); $path->append("$_: $h{$_}\n") foreach keys %h; } sub _recurse { my($self, $build, $dir) = @_; foreach my $child ($dir->children) { if(-d $child) { $self->_recurse($build, $child); } elsif($child->basename =~ /\.pc$/) { $self->_convert($build, $child); } } } sub init { my($self, $meta) = @_; $meta->add_requires('configure' => 'Alien::Build::Plugin::Build::SearchDep' => '0.35'); $meta->before_hook( gather_share => sub { my($build) = @_; if($self->path) { $self->_convert($build, Path::Tiny->new($self->path)->absolute); } else { $self->_recurse($build, Path::Tiny->new(".")->absolute); } }, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::PkgConfig::MakeStatic - Convert .pc files into static =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'PkgConfig::MakeStatic' => ( path => 'lib/pkgconfig/foo.pc', ); =head1 DESCRIPTION Convert C<.pc> file to use static linkage by default. This is an experimental plugin, so use with caution. =head1 PROPERTIES =head2 path The path to the C<.pc> file. If not provided, all C<.pc> files in the stage directory will be converted. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/PkgConfig/CommandLine.pm 0000444 00000015734 14711220254 0015521 0 ustar 00 package Alien::Build::Plugin::PkgConfig::CommandLine; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); # ABSTRACT: Probe system and determine library or tool properties using the pkg-config command line interface our $VERSION = '2.41'; # VERSION has '+pkg_name' => sub { Carp::croak "pkg_name is a required property"; }; # NOT used, for compat with other PkgConfig plugins has register_prereqs => 1; sub _bin_name { # We prefer pkgconf to pkg-config because it seems to be the future. require File::Which; File::Which::which($ENV{PKG_CONFIG}) ? $ENV{PKG_CONFIG} : File::Which::which('pkgconf') ? 'pkgconf' : File::Which::which('pkg-config') ? 'pkg-config' : undef; }; has bin_name => \&_bin_name; has atleast_version => undef; has exact_version => undef; has max_version => undef; has minimum_version => undef; sub _val { my($build, $args, $prop_name) = @_; my $string = $args->{out}; chomp $string; $string =~ s{^\s+}{}; if($prop_name =~ /version$/) { $string =~ s{\s*$}{} } else { $string =~ s{\s*$}{ } } if($prop_name =~ /^(.*?)\.(.*?)\.(.*?)$/) { $build->runtime_prop->{$1}->{$2}->{$3} = $string } else { $build->runtime_prop->{$prop_name} = $string } (); } sub available { !!_bin_name(); } sub init { my($self, $meta) = @_; my @probe; my @gather; my $pkgconf = $self->bin_name; unless(defined $meta->prop->{env}->{PKG_CONFIG}) { $meta->prop->{env}->{PKG_CONFIG} = $pkgconf; } my($pkg_name, @alt_names) = (ref $self->pkg_name) ? (@{ $self->pkg_name }) : ($self->pkg_name); push @probe, map { [$pkgconf, '--exists', $_] } ($pkg_name, @alt_names); if(defined $self->minimum_version) { push @probe, [ $pkgconf, '--atleast-version=' . $self->minimum_version, $pkg_name ]; } elsif(defined $self->atleast_version) { push @probe, [ $pkgconf, '--atleast-version=' . $self->atleast_version, $pkg_name ]; } if(defined $self->exact_version) { push @probe, [ $pkgconf, '--exact-version=' . $self->exact_version, $pkg_name ]; } if(defined $self->max_version) { push @probe, [ $pkgconf, '--max-version=' . $self->max_version, $pkg_name ]; } push @probe, [ $pkgconf, '--modversion', $pkg_name, sub { my($build, $args) = @_; my $version = $args->{out}; $version =~ s{^\s+}{}; $version =~ s{\s*$}{}; $build->hook_prop->{version} = $version; }]; unshift @probe, sub { my($build) = @_; $build->runtime_prop->{legacy}->{name} ||= $pkg_name; $build->hook_prop->{probe_class} = __PACKAGE__; $build->hook_prop->{probe_instance_id} = $self->instance_id; }; $meta->register_hook( probe => \@probe ); push @gather, sub { my($build) = @_; die 'pkg-config command line probe does not match gather' if $build->hook_prop->{name} eq 'gather_system' && ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id; }; push @gather, map { [ $pkgconf, '--exists', $_] } ($pkg_name, @alt_names); foreach my $prop_name (qw( cflags libs version )) { my $flag = $prop_name eq 'version' ? '--modversion' : "--$prop_name"; push @gather, [ $pkgconf, $flag, $pkg_name, sub { _val @_, $prop_name } ]; if(@alt_names) { foreach my $alt ($pkg_name, @alt_names) { push @gather, [ $pkgconf, $flag, $alt, sub { _val @_, "alt.$alt.$prop_name" } ]; } } } foreach my $prop_name (qw( cflags libs )) { push @gather, [ $pkgconf, '--static', "--$prop_name", $pkg_name, sub { _val @_, "${prop_name}_static" } ]; if(@alt_names) { foreach my $alt ($pkg_name, @alt_names) { push @gather, [ $pkgconf, '--static', "--$prop_name", $alt, sub { _val @_, "alt.$alt.${prop_name}_static" } ]; } } } $meta->register_hook(gather_system => [@gather]); if($meta->prop->{platform}->{system_type} eq 'windows-mingw') { @gather = map { if(ref $_ eq 'ARRAY') { my($pkgconf, @rest) = @$_; [$pkgconf, '--dont-define-prefix', @rest], } else { $_ } } @gather; } $meta->register_hook(gather_share => [@gather]); $meta->after_hook( $_ => sub { my($build) = @_; if(keys %{ $build->runtime_prop->{alt} } < 2) { delete $build->runtime_prop->{alt}; } }, ) for qw( gather_system gather_share ); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::PkgConfig::CommandLine - Probe system and determine library or tool properties using the pkg-config command line interface =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'PkgConfig::CommandLine' => ( pkg_name => 'libfoo', ); =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::PkgConfig::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin provides Probe and Gather steps for pkg-config based packages. It uses the best command line tools to accomplish this task. =head1 PROPERTIES =head2 pkg_name The package name. If this is a list reference then .pc files with all those package names must be present. =head2 atleast_version The minimum required version that is acceptable version as provided by the system. =head2 exact_version The exact required version that is acceptable version as provided by the system. =head2 max_version The max required version that is acceptable version as provided by the system. =head2 minimum_version Alias for C<atleast_version> for backward compatibility. =head1 METHODS =head2 available my $bool = Alien::Build::Plugin::PkgConfig::CommandLine->available; Returns true if the necessary prereqs for this plugin are I<already> installed. =head1 SEE ALSO L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/PkgConfig/LibPkgConf.pm 0000444 00000016351 14711220254 0015305 0 ustar 00 package Alien::Build::Plugin::PkgConfig::LibPkgConf; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); # ABSTRACT: Probe system and determine library or tool properties using PkgConfig::LibPkgConf our $VERSION = '2.41'; # VERSION has '+pkg_name' => sub { Carp::croak "pkg_name is a required property"; }; has atleast_version => undef; has exact_version => undef; has max_version => undef; has minimum_version => undef; # private for now, used by negotiator has register_prereqs => 1; use constant _min_version => '0.04'; sub available { !!eval { require PkgConfig::LibPkgConf; PkgConfig::LibPkgConf->VERSION(_min_version) }; } sub init { my($self, $meta) = @_; unless(defined $meta->prop->{env}->{PKG_CONFIG}) { # TODO: this doesn't yet find pkgconf in the bin dir of a share # install. my $command_line = File::Which::which('pkgconf') ? 'pkgconf' : File::Which::which('pkg-config') ? 'pkg-config' : undef; $meta->prop->{env}->{PKG_CONFIG} = $command_line if defined $command_line; } if($self->register_prereqs) { # Also update in Neotiate.pm $meta->add_requires('configure' => 'PkgConfig::LibPkgConf::Client' => _min_version); if(defined $self->minimum_version || defined $self->atleast_version || defined $self->exact_version || defined $self->max_version) { $meta->add_requires('configure' => 'PkgConfig::LibPkgConf::Util' => _min_version); } } my($pkg_name, @alt_names) = (ref $self->pkg_name) ? (@{ $self->pkg_name }) : ($self->pkg_name); $meta->register_hook( probe => sub { my($build) = @_; $build->runtime_prop->{legacy}->{name} ||= $pkg_name; $build->hook_prop->{probe_class} = __PACKAGE__; $build->hook_prop->{probe_instance_id} = $self->instance_id; require PkgConfig::LibPkgConf::Client; my $client = PkgConfig::LibPkgConf::Client->new; my $pkg = $client->find($pkg_name); die "package $pkg_name not found" unless $pkg; $build->hook_prop->{version} = $pkg->version; my $atleast_version = $self->atleast_version; $atleast_version = $self->minimum_version unless defined $self->atleast_version; if($atleast_version) { require PkgConfig::LibPkgConf::Util; if(PkgConfig::LibPkgConf::Util::compare_version($pkg->version, $atleast_version) < 0) { die "package $pkg_name is version @{[ $pkg->version ]}, but at least $atleast_version is required."; } } if($self->exact_version) { require PkgConfig::LibPkgConf::Util; if(PkgConfig::LibPkgConf::Util::compare_version($pkg->version, $self->exact_version) != 0) { die "package $pkg_name is version @{[ $pkg->version ]}, but exactly @{[ $self->exact_version ]} is required."; } } if($self->max_version) { require PkgConfig::LibPkgConf::Util; if(PkgConfig::LibPkgConf::Util::compare_version($pkg->version, $self->max_version) > 0) { die "package $pkg_name is version @{[ $pkg->version ]}, but max @{[ $self->max_version ]} is required."; } } foreach my $alt (@alt_names) { my $pkg = $client->find($alt); die "package $alt not found" unless $pkg; } 'system'; }, ); $meta->register_hook( $_ => sub { my($build) = @_; return if $build->hook_prop->{name} eq 'gather_system' && ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id; require PkgConfig::LibPkgConf::Client; my $client = PkgConfig::LibPkgConf::Client->new; foreach my $name ($pkg_name, @alt_names) { my $pkg = $client->find($name); die "reload of package $name failed" unless defined $pkg; my %prop; $prop{version} = $pkg->version; $prop{cflags} = $pkg->cflags; $prop{libs} = $pkg->libs; $prop{cflags_static} = $pkg->cflags_static; $prop{libs_static} = $pkg->libs_static; $build->runtime_prop->{alt}->{$name} = \%prop; } foreach my $key (keys %{ $build->runtime_prop->{alt}->{$pkg_name} }) { $build->runtime_prop->{$key} = $build->runtime_prop->{alt}->{$pkg_name}->{$key}; } if(keys %{ $build->runtime_prop->{alt} } == 1) { delete $build->runtime_prop->{alt}; } }, ) for qw( gather_system gather_share ); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::PkgConfig::LibPkgConf - Probe system and determine library or tool properties using PkgConfig::LibPkgConf =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'PkgConfig::LibPkgConf' => ( pkg_name => 'libfoo', ); =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::PkgConfig::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin provides Probe and Gather steps for pkg-config based packages. It uses L<PkgConfig::LibPkgConf> to accomplish this task. This plugin is part of the Alien::Build core For Now, but may be removed in a future date. While It Seemed Like A Good Idea at the time, it may not be appropriate to keep it in core. If it is spun off it will get its own distribution some time in the future. =head1 PROPERTIES =head2 pkg_name The package name. If this is a list reference then .pc files with all those package names must be present. =head2 atleast_version The minimum required version that is acceptable version as provided by the system. =head2 exact_version The exact required version that is acceptable version as provided by the system. =head2 max_version The max required version that is acceptable version as provided by the system. =head2 minimum_version Alias for C<atleast_version> for backward compatibility. =head1 METHODS =head2 available my $bool = Alien::Build::Plugin::PkgConfig::LibPkgConf->available; Returns true if the necessary prereqs for this plugin are I<already> installed. =head1 SEE ALSO L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/PkgConfig/PP.pm 0000444 00000017145 14711220255 0013651 0 ustar 00 package Alien::Build::Plugin::PkgConfig::PP; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); use File::Which (); use Env qw( @PKG_CONFIG_PATH ); # ABSTRACT: Probe system and determine library or tool properties using PkgConfig.pm our $VERSION = '2.41'; # VERSION has '+pkg_name' => sub { Carp::croak "pkg_name is a required property"; }; has atleast_version => undef; has exact_version => undef; has max_version => undef; has minimum_version => undef; use constant _min_version => '0.14026'; # private for now, used by negotiator has register_prereqs => 1; sub available { !!eval { require PkgConfig; PkgConfig->VERSION(_min_version) }; } sub _cleanup { my($value) = @_; $value =~ s{\s*$}{ }; $value; } sub init { my($self, $meta) = @_; unless(defined $meta->prop->{env}->{PKG_CONFIG}) { # TODO: Better would be to to "execute" lib/PkgConfig.pm # as that should always be available, and will match the # exact version of PkgConfig.pm that we are using here. # there are a few corner cases to deal with before we # can do this. What is here should handle most use cases. my $command_line = File::Which::which('ppkg-config') ? 'ppkg-config' : File::Which::which('pkg-config.pl') ? 'pkg-config.pl' : File::Which::which('pkg-config') ? 'pkg-config' : undef; $meta->prop->{env}->{PKG_CONFIG} = $command_line if defined $command_line; } if($self->register_prereqs) { $meta->add_requires('configure' => 'PkgConfig' => _min_version); } my($pkg_name, @alt_names) = (ref $self->pkg_name) ? (@{ $self->pkg_name }) : ($self->pkg_name); $meta->register_hook( probe => sub { my($build) = @_; $build->runtime_prop->{legacy}->{name} ||= $pkg_name; $build->hook_prop->{probe_class} = __PACKAGE__; $build->hook_prop->{probe_instance_id} = $self->instance_id; require PkgConfig; my $pkg = PkgConfig->find($pkg_name); die "package @{[ $pkg_name ]} not found" if $pkg->errmsg; $build->hook_prop->{version} = $pkg->pkg_version; my $version = PkgConfig::Version->new($pkg->pkg_version); my $atleast_version = $self->atleast_version; $atleast_version = $self->minimum_version unless defined $atleast_version; if(defined $atleast_version) { my $need = PkgConfig::Version->new($atleast_version); if($version < $need) { die "package @{[ $pkg_name ]} is @{[ $pkg->pkg_version ]}, but at least $atleast_version is required."; } } if(defined $self->exact_version) { my $need = PkgConfig::Version->new($self->exact_version); if($version != $need) { die "package @{[ $pkg_name ]} is @{[ $pkg->pkg_version ]}, but exactly @{[ $self->exact_version ]} is required."; } } if(defined $self->max_version) { my $need = PkgConfig::Version->new($self->max_version); if($version > $need) { die "package @{[ $pkg_name ]} is @{[ $pkg->pkg_version ]}, but max of @{[ $self->max_version ]} is required."; } } foreach my $alt (@alt_names) { my $pkg = PkgConfig->find($alt); die "package $alt not found" if $pkg->errmsg; } 'system'; }, ); $meta->register_hook( $_ => sub { my($build) = @_; return if $build->hook_prop->{name} eq 'gather_system' && ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id; require PkgConfig; foreach my $name ($pkg_name, @alt_names) { require PkgConfig; my $pkg = PkgConfig->find($name, search_path => [@PKG_CONFIG_PATH]); if($pkg->errmsg) { $build->log("Trying to load the pkg-config information from the source code build"); $build->log("of your package failed"); $build->log("You are currently using the pure-perl implementation of pkg-config"); $build->log("(AB Plugin is named PkgConfig::PP, which uses PkgConfig.pm"); $build->log("It may work better with the real pkg-config."); $build->log("Try installing your OS' version of pkg-config or unset ALIEN_BUILD_PKG_CONFIG"); die "second load of PkgConfig.pm @{[ $name ]} failed: @{[ $pkg->errmsg ]}" } my %prop; $prop{cflags} = _cleanup scalar $pkg->get_cflags; $prop{libs} = _cleanup scalar $pkg->get_ldflags; $prop{version} = $pkg->pkg_version; $pkg = PkgConfig->find($name, static => 1, search_path => [@PKG_CONFIG_PATH]); $prop{cflags_static} = _cleanup scalar $pkg->get_cflags; $prop{libs_static} = _cleanup scalar $pkg->get_ldflags; $build->runtime_prop->{alt}->{$name} = \%prop; } foreach my $key (keys %{ $build->runtime_prop->{alt}->{$pkg_name} }) { $build->runtime_prop->{$key} = $build->runtime_prop->{alt}->{$pkg_name}->{$key}; } if(keys %{ $build->runtime_prop->{alt} } == 1) { delete $build->runtime_prop->{alt}; } } ) for qw( gather_system gather_share ); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::PkgConfig::PP - Probe system and determine library or tool properties using PkgConfig.pm =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'PkgConfig::PP' => ( pkg_name => 'libfoo', ); =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::PkgConfig::Negotiate> instead. It picks the appropriate fetch plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin provides Probe and Gather steps for pkg-config based packages. It uses L<PkgConfig> to accomplish this task. =head1 PROPERTIES =head2 pkg_name The package name. If this is a list reference then .pc files with all those package names must be present. =head2 atleast_version The minimum required version that is acceptable version as provided by the system. =head2 exact_version The exact required version that is acceptable version as provided by the system. =head2 max_version The max required version that is acceptable version as provided by the system. =head2 minimum_version Alias for C<atleast_version> for backward compatibility. =head1 METHODS =head2 available my $bool = Alien::Build::Plugin::PkgConfig::PP->available; Returns true if the necessary prereqs for this plugin are I<already> installed. =head1 SEE ALSO L<Alien::Build::Plugin::PkgConfig::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Probe/CBuilder.pm 0000444 00000014141 14711220255 0014214 0 ustar 00 package Alien::Build::Plugin::Probe::CBuilder; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::chdir; use File::Temp (); use Capture::Tiny qw( capture_merged capture ); # ABSTRACT: Probe for system libraries by guessing with ExtUtils::CBuilder our $VERSION = '2.41'; # VERSION has options => sub { {} }; has cflags => ''; has libs => ''; has program => 'int main(int argc, char *argv[]) { return 0; }'; has version => undef; has aliens => []; has lang => 'C'; sub init { my($self, $meta) = @_; $meta->add_requires('configure' => 'ExtUtils::CBuilder' => 0 ); if(@{ $self->aliens }) { die "You can't specify both 'aliens' and either 'cflags' or 'libs' for the Probe::CBuilder plugin" if $self->cflags || $self->libs; $meta->add_requires('configure' => $_ => 0 ) for @{ $self->aliens }; $meta->add_requires('Alien::Build::Plugin::Probe::CBuilder' => '0.53'); my $cflags = ''; my $libs = ''; foreach my $alien (@{ $self->aliens }) { my $pm = "$alien.pm"; $pm =~ s/::/\//g; require $pm; $cflags .= $alien->cflags . ' '; $libs .= $alien->libs . ' '; } $self->cflags($cflags); $self->libs($libs); } my @cpp; if($self->lang ne 'C') { $meta->add_requires('Alien::Build::Plugin::Probe::CBuilder' => '0.53'); @cpp = ('C++' => 1) if $self->lang eq 'C++'; } $meta->register_hook( probe => sub { my($build) = @_; $build->hook_prop->{probe_class} = __PACKAGE__; $build->hook_prop->{probe_instance_id} = $self->instance_id; local $CWD = File::Temp::tempdir( CLEANUP => 1, DIR => $CWD ); open my $fh, '>', 'mytest.c'; print $fh $self->program; close $fh; $build->log("trying: cflags=@{[ $self->cflags ]} libs=@{[ $self->libs ]}"); my $cb = ExtUtils::CBuilder->new(%{ $self->options }); my($out1, $obj) = capture_merged { eval { $cb->compile( source => 'mytest.c', extra_compiler_flags => $self->cflags, @cpp, ); } }; if(my $error = $@) { $build->log("compile failed: $error"); $build->log("compile failed: $out1"); die $@; } my($out2, $exe) = capture_merged { eval { $cb->link_executable( objects => [$obj], extra_linker_flags => $self->libs, ); } }; if(my $error = $@) { $build->log("link failed: $error"); $build->log("link failed: $out2"); die $@; } my($out, $err, $ret) = capture { system($^O eq 'MSWin32' ? $exe : "./$exe") }; die "execute failed" if $ret; my $cflags = $self->cflags; my $libs = $self->libs; $cflags =~ s{\s*$}{ }; $libs =~ s{\s*$}{ }; $build->install_prop->{plugin_probe_cbuilder_gather}->{$self->instance_id} = { cflags => $cflags, libs => $libs, }; if(defined $self->version) { my($version) = $out =~ $self->version; $build->hook_prop->{version} = $version; $build->install_prop->{plugin_probe_cbuilder_gather}->{$self->instance_id}->{version} = $version; } 'system'; } ); $meta->register_hook( gather_system => sub { my($build) = @_; return if $build->hook_prop->{name} eq 'gather_system' && ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id; if(my $p = $build->install_prop->{plugin_probe_cbuilder_gather}->{$self->instance_id}) { $build->runtime_prop->{$_} = $p->{$_} for keys %$p; } }, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Probe::CBuilder - Probe for system libraries by guessing with ExtUtils::CBuilder =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Probe::CBuilder' => ( cflags => '-I/opt/libfoo/include', libs => '-L/opt/libfoo/lib -lfoo', ); alternately: ues alienfile; plugin 'Probe::CBuilder' => ( aliens => [ 'Alien::libfoo', 'Alien::libbar' ], ); =head1 DESCRIPTION This plugin probes for compiler and linker flags using L<ExtUtils::CBuilder>. This is a useful alternative to L<Alien::Build::Plugin::PkgConfig::Negotiate> for packages that do not provide a pkg-config C<.pc> file, or for when those C<.pc> files may not be available. (For example, on FreeBSD, C<libarchive> is a core part of the operating system, but doesn't include a C<.pc> file which is usually provided when you install the C<libarchive> package on Linux). =head1 PROPERTIES =head2 options Any extra options that you want to have passed into the constructor to L<ExtUtils::CBuilder>. =head2 cflags The compiler flags. =head2 libs The linker flags =head2 program The program to use in the test. =head2 version This is a regular expression to parse the version out of the output from the test program. =head2 aliens List of aliens to query fro compiler and linker flags. =head2 lang The programming language to use. One of either C<C> or C<C++>. =head1 SEE ALSO L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Probe/Vcpkg.pm 0000444 00000015363 14711220256 0013605 0 ustar 00 package Alien::Build::Plugin::Probe::Vcpkg; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Probe for system libraries using Vcpkg our $VERSION = '2.41'; # VERSION has '+name'; has 'lib'; has 'ffi_name'; has 'include'; sub init { my($self, $meta) = @_; if(defined $self->include) { $meta->add_requires('configure' => 'Alien::Build::Plugin::Probe::Vcpkg' => '2.16' ); } elsif(defined $self->ffi_name) { $meta->add_requires('configure' => 'Alien::Build::Plugin::Probe::Vcpkg' => '2.14' ); } else { $meta->add_requires('configure' => 'Alien::Build::Plugin::Probe::Vcpkg' => '0' ); } if($meta->prop->{platform}->{compiler_type} eq 'microsoft') { $meta->register_hook( probe => sub { my($build) = @_; $build->hook_prop->{probe_class} = __PACKAGE__; $build->hook_prop->{probe_instance_id} = $self->instance_id; eval { require Win32::Vcpkg; require Win32::Vcpkg::List; require Win32::Vcpkg::Package; Win32::Vcpkg->VERSION('0.02'); }; if(my $error = $@) { $build->log("unable to load Win32::Vcpkg: $error"); return 'share'; } my $package; if($self->name) { $package = Win32::Vcpkg::List->new ->search($self->name, include => $self->include); } elsif($self->lib) { $package = eval { Win32::Vcpkg::Package->new( lib => $self->lib, include => $self->include) }; return 'share' if $@; } else { $build->log("you must provode either name or lib property for Probe::Vcpkg"); return 'share'; } my $version = $package->version; $version = 'unknown' unless defined $version; $build->install_prop->{plugin_probe_vcpkg}->{$self->instance_id} = { version => $version, cflags => $package->cflags, libs => $package->libs, }; $build->hook_prop->{version} = $version; $build->install_prop->{plugin_probe_vcpkg}->{$self->instance_id}->{ffi_name} = $self->ffi_name if defined $self->ffi_name; return 'system'; }, ); $meta->register_hook( gather_system => sub { my($build) = @_; return if $build->hook_prop->{name} eq 'gather_system' && ($build->install_prop->{system_probe_instance_id} || '') ne $self->instance_id; if(my $c = $build->install_prop->{plugin_probe_vcpkg}->{$self->instance_id}) { $build->runtime_prop->{version} = $c->{version} unless defined $build->runtime_prop->{version}; $build->runtime_prop->{$_} = $c->{$_} for grep { defined $c->{$_} } qw( cflags libs ffi_name ); } }, ); } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Probe::Vcpkg - Probe for system libraries using Vcpkg =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Probe::Vcpkg' => 'libffi'; =head1 DESCRIPTION This plugin probe can be used to find "system" packages using Microsoft's C<Vcpkg> package manager for Visual C++ builds of Perl. C<Vcpkg> is a package manager for Visual C++ that includes a number of open source packages. Although C<Vcpkg> does also support Linux and macOS, this plugin does not support finding C<Vcpkg> packages on those platforms. For more details on C<Vcpkg>, see the project github page here: L<https://github.com/microsoft/vcpkg> Here is the quick start guide for getting L<Alien::Build> to work with C<Vpkg>: # install Vcpkg C:\> git clone https://github.com/Microsoft/vcpkg.git C:\> cd vcpkg C:\vcpkg> .\bootstrap-vcpkg.bat C:\vcpkg> .\vcpkg integrate install # update PATH to include the bin directory # so that .DLL files can be found by Perl C:\vcpkg> path c:\vcpkg\installed\x64-windows\bin;%PATH% # install the packages that you want C:\vcpkg> .\vcpkg install libffi # install the alien that uses it C:\vcpkg> cpanm Alien::FFI If you are using 32 bit build of Perl, then substitute C<x86-windows> for C<x64-windows>. If you do not want to add the C<bin> directory to the C<PATH>, then you can use C<x64-windows-static> instead, which will provide static libraries. (As of this writing static libraries for 32 bit Windows are not available). The main downside to using C<x64-windows-static> is that Aliens that require dynamic libraries for FFI will not be installable. If you do not want to install C<Vcpkg> user wide (the C<integrate install> command above), then you can use the C<PERL_WIN32_VCPKG_ROOT> environment variable instead: # install Vcpkg C:\> git clone https://github.com/Microsoft/vcpkg.git C:\> cd vcpkg C:\vcpkg> .\bootstrap-vcpkg.bat C:\vcpkg> set PERL_WIN32_VCPKG_ROOT=c:\vcpkg =head1 PROPERTIES =head2 name Specifies the name of the Vcpkg. This should not be used with the C<lib> property below, choose only one. This is the default property, so these two are equivalent: plugin 'Probe::Vcpkg' => (name => 'foo'); and plugin 'Probe::Vcpkg' => 'foo'; =head2 lib Specifies the list of libraries that make up the Vcpkg. This should not be used with the C<name> property above, choose only one. Note that using this detection method, the version number of the package will not be automatically determined (since multiple packages could potentially make up the list of libraries), so you need to determine the version number another way if you need it. This must be an array reference. Do not include the C<.lib> extension. plugin 'Probe::Vcpkg' => (lib => ['foo','bar']); =head2 ffi_name Specifies an alternate ffi_name for finding dynamic libraries. =head1 SEE ALSO L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Probe/CommandLine.pm 0000444 00000011237 14711220256 0014715 0 ustar 00 package Alien::Build::Plugin::Probe::CommandLine; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); use Capture::Tiny qw( capture ); use File::Which (); # ABSTRACT: Probe for tools or commands already available our $VERSION = '2.41'; # VERSION has '+command' => sub { Carp::croak "@{[ __PACKAGE__ ]} requires command property" }; has 'args' => []; has 'secondary' => 0; has 'match' => undef; has 'match_stderr' => undef; has 'version' => undef; has 'version_stderr' => undef; sub init { my($self, $meta) = @_; my $check = sub { my($build) = @_; unless(File::Which::which($self->command)) { die 'Command not found ' . $self->command; } if(defined $self->match || defined $self->match_stderr || defined $self->version || defined $self->version_stderr) { my($out,$err,$ret) = capture { system( $self->command, @{ $self->args } ); }; die 'Command did not return a true value' if $ret; die 'Command output did not match' if defined $self->match && $out !~ $self->match; die 'Command standard error did not match' if defined $self->match_stderr && $err !~ $self->match_stderr; if(defined $self->version) { if($out =~ $self->version) { $build->runtime_prop->{version} = $1; } } if(defined $self->version_stderr) { if($err =~ $self->version_stderr) { $build->hook_prop->{version} = $1; $build->runtime_prop->{version} = $1; } } } $build->runtime_prop->{command} = $self->command; 'system'; }; if($self->secondary) { $meta->around_hook( probe => sub { my $orig = shift; my $build = shift; my $type = $orig->($build, @_); return $type unless $type eq 'system'; $check->($build); }, ); } else { $meta->register_hook( probe => $check, ); } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Probe::CommandLine - Probe for tools or commands already available =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Probe::CommandLine' => ( command => 'gzip', args => [ '--version' ], match => qr/gzip/, version => qr/gzip ([0-9\.]+)/, ); =head1 DESCRIPTION This plugin probes for the existence of the given command line program. =head1 PROPERTIES =head2 command The name of the command. =head2 args The arguments to pass to the command. =head2 secondary If you are using another probe plugin (such as L<Alien::Build::Plugin::Probe::CBuilder> or L<Alien::Build::Plugin::PkgConfig::Negotiate>) to detect the existence of a library, but also need a program to exist, then you should set secondary to a true value. For example when you need both: use alienfile; # requires both liblzma library and xz program plugin 'PkgConfig' => 'liblzma'; plugin 'Probe::CommandLine => ( command => 'xz', secondary => 1, ); When you don't: use alienfile; plugin 'Probe::CommandLine' => ( command => 'gzip', secondary => 0, # default ); =head2 match Regular expression for which the program output should match. =head2 match_stderr Regular expression for which the program standard error should match. =head2 version Regular expression to parse out the version from the program output. The regular expression should store the version number in C<$1>. =head2 version_stderr Regular expression to parse out the version from the program standard error. The regular expression should store the version number in C<$1>. =head1 SEE ALSO L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Test/Mock.pm 0000444 00000022743 14711220256 0013274 0 ustar 00 package Alien::Build::Plugin::Test::Mock; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Carp (); use Path::Tiny (); use File::chdir; # ABSTRACT: Mock plugin for testing our $VERSION = '2.41'; # VERSION has 'probe'; has 'download'; has 'extract'; has 'build'; has 'gather'; sub init { my($self, $meta) = @_; if(my $probe = $self->probe) { if($probe =~ /^(share|system)$/) { $meta->register_hook( probe => sub { $probe; }, ); } elsif($probe eq 'die') { $meta->register_hook( probe => sub { die "fail"; }, ); } else { Carp::croak("usage: plugin 'Test::Mock' => ( probe => $probe ); where $probe is one of share, system or die"); } } if(my $download = $self->download) { $download = { 'foo-1.00.tar.gz' => _tarball() } unless ref $download eq 'HASH'; $meta->register_hook( download => sub { my($build) = @_; _fs($build, $download); }, ); } if(my $extract = $self->extract) { $extract = { 'foo-1.00' => { 'configure' => _tarball_configure(), 'foo.c' => _tarball_foo_c(), }, } unless ref $extract eq 'HASH'; $meta->register_hook( extract => sub { my($build) = @_; _fs($build, $extract); }, ); } if(my $build = $self->build) { $build = [ { 'foo.o', => _build_foo_o(), 'libfoo.a' => _build_libfoo_a(), }, { 'lib' => { 'libfoo.a' => _build_libfoo_a(), 'pkgconfig' => { 'foo.pc' => sub { my($build) = @_; "prefix=$CWD\n" . "exec_prefix=\${prefix}\n" . "libdir=\${prefix}/lib\n" . "includedir=\${prefix}/include\n" . "\n" . "Name: libfoo\n" . "Description: libfoo\n" . "Version: 1.0.0\n" . "Cflags: -I\${includedir}\n" . "Libs: -L\${libdir} -lfoo\n"; }, }, }, }, ] unless ref $build eq 'ARRAY'; my($build_dir, $install_dir) = @$build; $meta->register_hook( build => sub { my($build) = @_; _fs($build, $build_dir); local $CWD = $build->install_prop->{prefix}; _fs($build, $install_dir); }, ); } if(my $gather = $self->gather) { $meta->register_hook( $_ => sub { my($build) = @_; if(ref $gather eq 'HASH') { foreach my $key (keys %$gather) { $build->runtime_prop->{$key} = $gather->{$key}; } } else { my $prefix = $build->runtime_prop->{prefix}; $build->runtime_prop->{cflags} = "-I$prefix/include"; $build->runtime_prop->{libs} = "-L$prefix/lib -lfoo"; } }, ) for qw( gather_share gather_system ); } } sub _fs { my($build, $hash) = @_; foreach my $key (sort keys %$hash) { my $val = $hash->{$key}; if(ref $val eq 'HASH') { mkdir $key; local $CWD = $key; _fs($build,$val); } elsif(ref $val eq 'CODE') { Path::Tiny->new($key)->spew($val->($build)); } elsif(defined $val) { Path::Tiny->new($key)->spew($val); } } } sub _tarball { return unpack 'u', <<'EOF'; M'XL(`+DM@5@``^V4P4K$,!"&>YZGF-V]J*SM9#=)#RN^B'BHV;0)U`32U(OX M[D;0*LJREZVRF.\R?TA@)OS\TWI_S4JBJI@/(JJ%P%19+>AKG4"V)4Z;C922 M(;T=6(%BQIDFQB$V(8WB^]X.W>%WQ^[?_S'5,Z']\%]YU]IN#/KT/8[ZO^6? M_B=-C-=<%$BG'^4G_]S_U:)ZL*X:#(!6QN/26(Q&![W<P5_/EIF?*?])E&J> M'BD/DO/#^6<DON__6O*<_]]@99WJQ[W&FR'NK2_-+8!U$1X;ZRZ2P"9T:HW* D-`&ODGZZN[^$9T`,.H[!(>W@)2^*3":3.3]>`:%LBYL`#@`` ` EOF } sub _tarball_configure { return unpack 'u', <<'EOF'; <(R$O8FEN+W-H"@IE8VAO(")H:2!T:&5R92(["@`` ` EOF } sub _tarball_foo_c { return unpack 'u', <<'EOF'; M(VEN8VQU9&4@/'-T9&EO+F@^"@II;G0*;6%I;BAI;G0@87)G8RP@8VAA<B`J 887)G=EM=*0I["B`@<F5T=7)N(#`["GT* ` EOF } sub _build_foo_o { return unpack 'u', <<'EOF'; MS_KM_@<```$#`````0````0```"P`0```"`````````9````.`$````````` M`````````````````````````&@`````````T`$```````!H``````````<` M```'`````P````````!?7W1E>'0`````````````7U]415A4```````````` M````````````"`````````#0`0``!`````````````````0`@``````````` M`````%]?8V]M<&%C=%]U;G=I;F1?7TQ$````````````````"``````````@ M`````````-@!```#````.`(```$````````"````````````````7U]E:%]F M<F%M90```````%]?5$585``````````````H`````````$``````````^`$` M``,```````````````L``&@````````````````D````$``````-"@`````` M`@```!@```!``@```0```%`"```(````"P```%`````````````````````! M`````0`````````````````````````````````````````````````````` M``````````````````!52(GE,<!=PP``````````"`````````$````````` M````````````%``````````!>E(``7@0`1`,!PB0`0``)````!P```"X____ M_____P@``````````$$.$(8"0PT&```````````````!```&`0````\!```` /``````````!?;6%I;@`` ` EOF } sub _build_libfoo_a { return unpack 'u', <<'EOF'; M(3QA<F-H/@HC,2\R,"`@("`@("`@("`@,34S,S$U-38Q."`@-3`Q("`@,C`@ M("`@,3`P-C0T("`T-"`@("`@("`@8`I?7RY364U$148@4T]25$5$``````@` M````````<`````@```!?;6%I;@```",Q+S$R("`@("`@("`@("`Q-3,S,34U M-#8X("`U,#$@("`R,"`@("`Q,#`V-#0@(#8Q,B`@("`@("!@"F9O;RYO```` M`````,_Z[?X'```!`P````$````$````L`$````@````````&0```#@!```` M``````````````````````````````!H`````````-`!````````:``````` M```'````!P````,`````````7U]T97AT`````````````%]?5$585``````` M``````````````````@`````````T`$```0````````````````$`(`````` M``````````!?7V-O;7!A8W1?=6YW:6YD7U],1`````````````````@````` M````(`````````#8`0```P```#@"```!`````````@```````````````%]? M96A?9G)A;64```````!?7U1%6%0`````````````*`````````!````````` M`/@!```#```````````````+``!H````````````````)````!``````#0H` M``````(````8````0`(```$```!0`@``"`````L```!0```````````````` M`````0````$````````````````````````````````````````````````` M````````````````````````54B)Y3'`7<,```````````@````````!```` M`````````````````!0``````````7I2``%X$`$0#`<(D`$``"0````<```` MN/________\(``````````!!#A"&`D,-!@```````````````0``!@$````/ 3`0``````````````7VUA:6X````` ` EOF } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Test::Mock - Mock plugin for testing =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Test::Mock' => ( probe => 'share', download => 1, extract => 1, build => 1, gather => 1, ); =head1 DESCRIPTION This plugin is used for testing L<Alien::Build> plugins. Usually you only want to test one or two phases in an L<alienfile> for your plugin, but you still have to have a fully formed L<alienfile> that contains all required phases. This plugin lets you fill in the other phases with the appropriate hooks. This is usually better than using real plugins which may pull in additional dynamic requirements that you do not want to rely on at test time. =head1 PROPERTIES =head2 probe plugin 'Test::Mock' => ( probe => $probe, ); Override the probe behavior by one of the following: =over =item share For a C<share> build. =item system For a C<system> build. =item die To throw an exception in the probe hook. This will usually cause L<Alien::Build> to try the next probe hook, if available, or to assume a C<share> install. =back =head2 download plugin 'Test::Mock' => ( download => \%fs_spec, ); plugin 'Test::Mock' => ( download => 1, ); Mock out a download. The C<%fs_spec> is a hash where the hash values are directories and the string values are files. This a spec like this: plugin 'Test::Mock' => ( download => { 'foo-1.00' => { 'README.txt' => "something to read", 'foo.c' => "#include <stdio.h>\n", "int main() {\n", " printf(\"hello world\\n\");\n", "}\n", } }, ); Would generate two files in the directory 'foo-1.00', a C<README.txt> and a C file named C<foo.c>. The default, if you provide a true non-hash value is to generate a single tarball with the name C<foo-1.00.tar.gz>. =head2 extract plugin 'Test::Mock' => ( extract => \%fs_spec, ); plugin 'Test::Mock' => ( extract => 1, ); Similar to C<download> above, but for the C<extract> phase. =head2 build plugin 'Test::Mock' => ( build => [ \%fs_spec_build, \%fs_spec_install ], ); plugin 'Test::Mock' => ( build => 1, ); =head2 gather plugin 'Test::Mock' => ( gather => \%runtime_prop, ); plugin 'Test::Mock' => ( gather => 1, ); This adds a gather hook (for both C<share> and C<system>) that adds the given runtime properties, or if a true non-hash value is provided, some reasonable runtime properties for testing. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Download.pod 0000444 00000003100 14711220257 0013364 0 ustar 00 # PODNAME: Alien::Build::Plugin::Download # ABSTRACT: Download Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Download - Download Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile share { start_url 'http://ftp.gnu.org/gnu/make'; plugin 'Download'; }; =head1 DESCRIPTION Download plugins download packages from the internet. =over 4 =item L<Alien::Build::Plugin::Download::Negotiate> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Gather/IsolateDynamic.pm 0000444 00000006463 14711220257 0015605 0 ustar 00 package Alien::Build::Plugin::Gather::IsolateDynamic; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use Path::Tiny (); use Alien::Build::Util qw( _destdir_prefix ); use File::Copy (); # ABSTRACT: Plugin to gather dynamic libraries into a separate directory our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; # plugin was introduced in 0.42, but had a bug which was fixed in 0.48 $meta->add_requires('share' => 'Alien::Build::Plugin::Gather::IsolateDynamic' => '0.48' ); $meta->after_hook( gather_share => sub { my($build) = @_; $build->log("Isolating dynamic libraries ..."); my $install_root; if($build->meta_prop->{destdir}) { my $destdir = $ENV{DESTDIR}; $install_root = Path::Tiny->new(_destdir_prefix($ENV{DESTDIR}, $build->install_prop->{prefix})); } else { $install_root = Path::Tiny->new($build->install_prop->{stage}); } foreach my $dir (map { $install_root->child($_) } qw( bin lib )) { next unless -d $dir; foreach my $from ($dir->children) { next unless $from->basename =~ /\.so/ || $from->basename =~ /\.(dylib|bundle|la|dll|dll\.a)$/; my $to = $install_root->child('dynamic', $from->basename); $to->parent->mkpath; unlink "$to" if -e $to; $build->log("move @{[ $from->parent->basename ]}/@{[ $from->basename ]} => dynamic/@{[ $to->basename ]}"); File::Copy::move("$from", "$to") || die "unable to move $from => $to $!"; } } $build->log(" Done!"); }, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Gather::IsolateDynamic - Plugin to gather dynamic libraries into a separate directory =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Gather::IsolateDynamic'; =head1 DESCRIPTION This plugin moves dynamic libraries from the C<lib> and C<bin> directories and puts them in their own C<dynamic> directory. This allows them to be used by FFI modules, but to be ignored by XS modules. This plugin provides the equivalent functionality of the C<alien_isolate_dynamic> attribute from L<Alien::Base::ModuleBuild>. =head1 SEE ALSO L<Alien::Build>, L<alienfile> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Decode.pod 0000444 00000003427 14711220257 0013014 0 ustar 00 # PODNAME: Alien::Build::Plugin::Decode # ABSTRACT: Decode Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Decode - Decode Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Decode::HTML'; plugin 'Decode::DirListing'; =head1 DESCRIPTION Decode plugins decode HTML and FTP file listings. Normally you will want to use the L<Alien::Build::Plugin::Download::Negotiate> plugin which will automatically load the appropriate Decode plugins. =over 4 =item L<Alien::Build::Plugin::Decode::HTML> =item L<Alien::Build::Plugin::Decode::DirListing> =item L<Alien::Build::Plugin::Decode::DirListingFtpcopy> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Prefer.pod 0000444 00000003341 14711220260 0013041 0 ustar 00 # PODNAME: Alien::Build::Plugin::Prefer # ABSTRACT: Prefer Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Prefer - Prefer Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; share { start_url 'http://ftp.gnu.org/gnu/make'; plugin 'Download'; }; =head1 DESCRIPTION Prefer plugins sort Decode plugins decode HTML and FTP file listings. Normally you will want to use the L<Alien::Build::Plugin::Download::Negotiate> plugin which will automatically load the appropriate Prefer plugins. =over 4 =item L<Alien::Build::Plugin::Prefer::SortVersions> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Decode/DirListingFtpcopy.pm 0000444 00000006411 14711220260 0016251 0 ustar 00 package Alien::Build::Plugin::Decode::DirListingFtpcopy; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Basename (); # ABSTRACT: Plugin to extract links from a directory listing using ftpcopy our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'File::Listing::Ftpcopy' => 0); $meta->add_requires('share' => 'URI' => 0); $meta->register_hook( decode => sub { my(undef, $res) = @_; die "do not know how to decode @{[ $res->{type} ]}" unless $res->{type} eq 'dir_listing'; my $base = URI->new($res->{base}); return { type => 'list', list => [ map { my($name) = @$_; my $basename = $name; $basename =~ s{/$}{}; my %h = ( filename => File::Basename::basename($basename), url => URI->new_abs($name, $base)->as_string, ); \%h; } File::Listing::Ftpcopy::parse_dir($res->{content}) ], }; }); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Decode::DirListingFtpcopy - Plugin to extract links from a directory listing using ftpcopy =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Decode::DirListingFtpcopy'; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate decode plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin decodes a ftp file listing into a list of candidates for your Prefer plugin. It is useful when fetching from an FTP server via L<Alien::Build::Plugin::Fetch::LWP>. It is different from the similarly named L<Alien::Build::Plugin::Decode::DirListingFtpcopy> in that it uses L<File::Listing::Ftpcopy> instead of L<File::Listing>. The rationale for the C<Ftpcopy> version is that it supports a different set of FTP servers, including OpenVMS. In most cases, however, you probably want to use the non C<Ftpcopy> version since it is pure perl. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build::Plugin::Decode::DirListing>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Decode/DirListing.pm 0000444 00000005525 14711220261 0014712 0 ustar 00 package Alien::Build::Plugin::Decode::DirListing; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Basename (); # ABSTRACT: Plugin to extract links from a directory listing our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'File::Listing' => 0); $meta->add_requires('share' => 'URI' => 0); $meta->register_hook( decode => sub { my(undef, $res) = @_; die "do not know how to decode @{[ $res->{type} ]}" unless $res->{type} eq 'dir_listing'; my $base = URI->new($res->{base}); return { type => 'list', list => [ map { my($name) = @$_; my $basename = $name; $basename =~ s{/$}{}; my %h = ( filename => File::Basename::basename($basename), url => URI->new_abs($name, $base)->as_string, ); \%h; } File::Listing::parse_dir($res->{content}) ], }; }); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Decode::DirListing - Plugin to extract links from a directory listing =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Decode::DirListing'; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate decode plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin decodes a ftp file listing into a list of candidates for your Prefer plugin. It is useful when fetching from an FTP server via L<Alien::Build::Plugin::Fetch::LWP>. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build::Plugin::Decode::DirListingFtpcopy>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Decode/HTML.pm 0000444 00000006041 14711220262 0013401 0 ustar 00 package Alien::Build::Plugin::Decode::HTML; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; use File::Basename (); # ABSTRACT: Plugin to extract links from HTML our $VERSION = '2.41'; # VERSION sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'HTML::LinkExtor' => 0); $meta->add_requires('share' => 'URI' => 0); $meta->add_requires('share' => 'URI::Escape' => 0); $meta->register_hook( decode => sub { my(undef, $res) = @_; die "do not know how to decode @{[ $res->{type} ]}" unless $res->{type} eq 'html'; my $base = URI->new($res->{base}); my @list; my $p = HTML::LinkExtor->new(sub { my($tag, %links) = @_; if($tag eq 'base' && $links{href}) { $base = URI->new($links{href}); } elsif($tag eq 'a' && $links{href}) { my $href = $links{href}; return if $href =~ m!^\.\.?/?$!; my $url = URI->new_abs($href, $base); my $path = $url->path; $path =~ s{/$}{}; # work around for Perl 5.8.7- gh#8 push @list, { filename => URI::Escape::uri_unescape(File::Basename::basename($path)), url => URI::Escape::uri_unescape($url->as_string), }; } }); $p->parse($res->{content}); return { type => 'list', list => \@list, }; }); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Decode::HTML - Plugin to extract links from HTML =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Decode::HTML'; =head1 DESCRIPTION Note: in most case you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate decode plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin decodes an HTML file listing into a list of candidates for your Prefer plugin. =head1 SEE ALSO L<Alien::Build::Plugin::Download::Negotiate>, L<Alien::Build>, L<alienfile>, L<Alien::Build::MM>, L<Alien> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Decode/Mojo.pm 0000444 00000010416 14711220262 0013542 0 ustar 00 package Alien::Build::Plugin::Decode::Mojo; use strict; use warnings; use 5.008004; use Alien::Build::Plugin; # ABSTRACT: Plugin to extract links from HTML using Mojo::DOM or Mojo::DOM58 our $VERSION = '2.41'; # VERSION sub _load ($;$) { my($class, $version) = @_; my $pm = "$class.pm"; $pm =~ s/::/\//g; eval { require $pm }; return 0 if $@; if(defined $version) { eval { $class->VERSION($version) }; return 0 if $@; } return 1; } has _class => sub { return 'Mojo::DOM58' if _load 'Mojo::DOM58'; return 'Mojo::DOM' if _load 'Mojo::DOM' and _load 'Mojolicious', 7.00; return 'Mojo::DOM58'; }; sub init { my($self, $meta) = @_; $meta->add_requires('share' => 'URI' => 0); $meta->add_requires('share' => 'URI::Escape' => 0); my $class = $meta->prop->{plugin_decode_mojo_class} ||= $self->_class; if($class eq 'Mojo::DOM58') { $meta->add_requires('share' => 'Mojo::DOM58' => '1.00'); } elsif($class eq 'Mojo::DOM') { $meta->add_requires('share' => 'Mojolicious' => '7.00'); $meta->add_requires('share' => 'Mojo::DOM' => '0'); } else { die "bad class"; } $meta->register_hook( decode => sub { my(undef, $res) = @_; die "do not know how to decode @{[ $res->{type} ]}" unless $res->{type} eq 'html'; my $dom = $class->new($res->{content}); my $base = URI->new($res->{base}); if(my $base_element = $dom->find('head base')->first) { my $href = $base_element->attr('href'); $base = URI->new($href) if defined $href; } my @list = map { my $url = URI->new_abs($_, $base); my $path = $url->path; $path =~ s{/$}{}; # work around for Perl 5.8.7- gh#8 { filename => URI::Escape::uri_unescape(File::Basename::basename($path)), url => URI::Escape::uri_unescape($url->as_string), } } grep !/^\.\.?\/?$/, map { $_->attr('href') || () } @{ $dom->find('a')->to_array }; return { type => 'list', list => \@list, }; }) } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Decode::Mojo - Plugin to extract links from HTML using Mojo::DOM or Mojo::DOM58 =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; plugin 'Decode::Mojo'; Force using C<Decode::Mojo> via the download negotiator: use alienfile 1.68; configure { requires 'Alien::Build::Plugin::Decode::Mojo'; }; plugin 'Download' => ( ... decoder => 'Decode::Mojo', ); =head1 DESCRIPTION Note: in most cases you will want to use L<Alien::Build::Plugin::Download::Negotiate> instead. It picks the appropriate decode plugin based on your platform and environment. In some cases you may need to use this plugin directly instead. This plugin decodes an HTML file listing into a list of candidates for your Prefer plugin. It works just like L<Alien::Build::Plugin::Decode::HTML> except it uses either L<Mojo::DOM> or L<Mojo::DOM58> to do its job. This plugin is much lighter than The C<Decode::HTML> plugin, and doesn't require XS. It is the default decode plugin used by L<Alien::Build::Plugin::Download::Negotiate> if it detects that you need to parse an HTML index. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Probe.pod 0000444 00000003764 14711220263 0012701 0 ustar 00 # PODNAME: Alien::Build::Plugin::Probe # ABSTRACT: Probe Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Probe - Probe Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS look for libraries in known location: use alienfile; plugin 'Probe::CBuilder' => ( cflags => '-I/opt/libfoo/include', libs => '-L/opt/libfoo/lib -lfoo', ); look for tools in the path: use alienfile; plugin 'Probe::CommandLine' => ( command => 'gzip', args => [ '--version' ], match => qr/gzip/, version => qr/gzip ([0-9\.]+)/, ); =head1 DESCRIPTION Probe plugins try to find existing libraries and tools I<already> installed on the system. If found they can be used instead of downloading the source from the internet and building. =over 4 =item L<Alien::Build::Plugin::Probe::CBuilder> =item L<Alien::Build::Plugin::Probe::CommandLine> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Core.pod 0000444 00000003164 14711220263 0012514 0 ustar 00 # PODNAME: Alien::Build::Plugin::Core # ABSTRACT: Core Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Core - Core Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile; # core plugins are already loaded =head1 DESCRIPTION Core plugins are special plugins that are always loaded, usually first. =over 4 =item L<Alien::Build::Plugin::Core::Gather> =item L<Alien::Build::Plugin::Core::Legacy> Add interoperability with L<Alien::Base::ModuleBuild> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Plugin/Extract.pod 0000444 00000003653 14711220264 0013242 0 ustar 00 # PODNAME: Alien::Build::Plugin::Extract # ABSTRACT: Extract Alien::Build plugins # VERSION __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Plugin::Extract - Extract Alien::Build plugins =head1 VERSION version 2.41 =head1 SYNOPSIS use alienfile share { plugin 'Extract' => 'tar.gz'; }; =head1 DESCRIPTION Extract plugins extract packages that have been downloaded from the internet. Unless you are doing something unusual you will likely want to use the L<Alien::Build::Plugin::Extract::Negotiate> plugin to select the best Extract plugin available. =over 4 =item L<Alien::Build::Plugin::Extract::ArchiveTar> =item L<Alien::Build::Plugin::Extract::ArchiveZip> =item L<Alien::Build::Plugin::Extract::CommandLine> =item L<Alien::Build::Plugin::Extract::Directory> =item L<Alien::Build::Plugin::Extract::Negotiate> =back =head1 SEE ALSO L<Alien::Build>, L<Alien::Build::Plugin> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/CommandSequence.pm 0000444 00000011655 14711220264 0013274 0 ustar 00 package Alien::Build::CommandSequence; use strict; use warnings; use 5.008004; use Text::ParseWords qw( shellwords ); use Capture::Tiny qw( capture ); # ABSTRACT: Alien::Build command sequence our $VERSION = '2.41'; # VERSION sub new { my($class, @commands) = @_; my $self = bless { commands => \@commands, }, $class; $self; } sub apply_requirements { my($self, $meta, $phase) = @_; my $intr = $meta->interpolator; foreach my $command (@{ $self->{commands} }) { next if ref $command eq 'CODE'; if(ref $command eq 'ARRAY') { foreach my $arg (@$command) { next if ref $arg eq 'CODE'; $meta->add_requires($phase, $intr->requires($arg)) } } else { $meta->add_requires($phase, $intr->requires($command)); } } $self; } my %built_in = ( cd => sub { my(undef, $dir) = @_; if(!defined $dir) { die "undef passed to cd"; } elsif(-d $dir) { chdir($dir) || die "unable to cd $dir $!"; } else { die "unable to cd $dir, does not exist"; } }, ); sub _run_list { my($build, @cmd) = @_; $build->log("+ @cmd"); return $built_in{$cmd[0]}->(@cmd) if $built_in{$cmd[0]}; system @cmd; die "external command failed" if $?; } sub _run_string { my($build, $cmd) = @_; $build->log("+ $cmd"); { my $cmd = $cmd; $cmd =~ s{\\}{\\\\}g if $^O eq 'MSWin32'; my @cmd = shellwords($cmd); return $built_in{$cmd[0]}->(@cmd) if $built_in{$cmd[0]}; } system $cmd; die "external command failed" if $?; } sub _run_with_code { my($build, @cmd) = @_; my $code = pop @cmd; $build->log("+ @cmd"); my %args = ( command => \@cmd ); if($built_in{$cmd[0]}) { my $error; ($args{out}, $args{err}, $error) = capture { eval { $built_in{$cmd[0]}->(@cmd) }; $@; }; $args{exit} = $error eq '' ? 0 : 2; $args{builtin} = 1; } else { ($args{out}, $args{err}, $args{exit}) = capture { system @cmd; $? }; } $build->log("[output consumed by Alien::Build recipe]"); $code->($build, \%args); } sub _apply { my($where, $prop, $value) = @_; if($where =~ /^(.*?)\.(.*?)$/) { _apply($2, $prop->{$1}, $value); } else { $prop->{$where} = $value; } } sub execute { my($self, $build) = @_; my $intr = $build->meta->interpolator; my $prop = $build->_command_prop; foreach my $command (@{ $self->{commands} }) { if(ref($command) eq 'CODE') { $command->($build); } elsif(ref($command) eq 'ARRAY') { my($command, @args) = @$command; my $code; $code = pop @args if $args[-1] && ref($args[-1]) eq 'CODE'; if($args[-1] && ref($args[-1]) eq 'SCALAR') { my $dest = ${ pop @args }; if($dest =~ /^\%\{((?:alien|)\.(?:install|runtime|hook)\.[a-z\.0-9_]+)\}$/) { $dest = $1; $dest =~ s/^\./alien./; $code = sub { my($build, $args) = @_; die "external command failed" if $args->{exit}; my $out = $args->{out}; chomp $out; _apply($dest, $prop, $out); }; } else { die "illegal destination: $dest"; } } ($command, @args) = map { $intr->interpolate($_, $prop) } ($command, @args); if($code) { _run_with_code $build, $command, @args, $code; } else { _run_list $build, $command, @args; } } else { my $command = $intr->interpolate($command,$prop); _run_string $build, $command; } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::CommandSequence - Alien::Build command sequence =head1 VERSION version 2.41 =head1 CONSTRUCTOR =head2 new my $seq = Alien::Build::CommandSequence->new(@commands); =head1 METHODS =head2 apply_requirements $seq->apply_requirements($meta, $phase); =head2 execute $seq->execute($build); =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Temp.pm 0000444 00000005242 14711220265 0011126 0 ustar 00 package Alien::Build::Temp; use strict; use warnings; use 5.008004; use Carp (); use Path::Tiny (); use File::Temp (); use File::Spec (); # ABSTRACT: Temp Dir support for Alien::Build our $VERSION = '2.41'; # VERSION # problem with vanilla File::Temp is that is often uses # as /tmp that has noexec turned on. Workaround is to # create a temp directory in the build directory, but # we have to be careful about cleanup. This puts all that # (attempted) carefulness in one place so that when we # later discover it isn't so careful we can fix it in # one place rather thabn alllll the places that we need # temp directories. my %root; sub _root { return File::Spec->tmpdir if $^O eq 'MSWin32'; my $root = Path::Tiny->new(-d "_alien" ? "_alien/tmp" : ".tmp")->absolute; unless(-d $root) { mkdir $root or die "unable to create temp root $!"; } # TODO: doesn't account for fork... my $lock = $root->child("l$$"); unless(-f $lock) { open my $fh, '>', $lock; close $fh; } $root{"$root"} = 1; $root; } END { foreach my $root (keys %root) { my $lock = Path::Tiny->new($root)->child("l$$"); unlink $lock; # try to delete if possible. # if not possible then punt rmdir $root if -d $root; } } sub newdir { my $class = shift; Carp::croak "uneven" if @_ % 2; File::Temp->newdir(DIR => _root, @_); } sub new { my $class = shift; Carp::croak "uneven" if @_ % 2; File::Temp->new(DIR => _root, @_); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Temp - Temp Dir support for Alien::Build =head1 VERSION version 2.41 =head1 DESCRIPTION This class is private to L<Alien::Build>. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Interpolate.pm 0000444 00000013146 14711220265 0012511 0 ustar 00 package Alien::Build::Interpolate; use strict; use warnings; use 5.008004; # ABSTRACT: Advanced interpolation engine for Alien builds our $VERSION = '2.41'; # VERSION sub new { my($class) = @_; my $self = bless { helper => {}, classes => {}, }, $class; $self; } sub add_helper { my $self = shift; my $name = shift; my $code = shift; if(defined $self->{helper}->{$name}) { require Carp; Carp::croak("duplicate implementation for interpolated key $name"); } my $require; if(ref $_[0] eq 'CODE') { $require = shift; } else { $require = []; while(@_) { my $module = shift; my $version = shift; $version ||= 0; push @$require, $module => $version; } } $self->{helper}->{$name} = Alien::Build::Helper->new( $name, $code, $require, ); } sub replace_helper { my $self = shift; my($name) = @_; delete $self->{helper}->{$name}; $self->add_helper(@_); } sub has_helper { my($self, $name) = @_; return unless defined $self->{helper}->{$name}; my @require = $self->{helper}->{$name}->require; while(@require) { my $module = shift @require; my $version = shift @require; { my $pm = "$module.pm"; $pm =~ s/::/\//g; require $pm; $module->VERSION($version) if $version; } unless($self->{classes}->{$module}) { if($module->can('alien_helper')) { my $helpers = $module->alien_helper; foreach my $k (keys %$helpers) { $self->{helper}->{$k}->code($helpers->{$k}); } } $self->{classes}->{$module} = 1; } } my $code = $self->{helper}->{$name}->code; return unless defined $code; if(ref($code) ne 'CODE') { my $perl = $code; package Alien::Build::Interpolate::Helper; $code = sub { ## no critic my $value = eval $perl; ## use critic die $@ if $@; $value; }; } $code; } sub execute_helper { my($self, $name) = @_; my $code = $self->has_helper($name); die "no helper defined for $name" unless defined $code; $code->(); } sub _get_prop { my($name, $prop, $orig) = @_; $name =~ s/^\./alien./; if($name =~ /^(.*?)\.(.*)$/) { my($key,$rest) = ($1,$2); return _get_prop($rest, $prop->{$key}, $orig); } elsif(exists $prop->{$name}) { return $prop->{$name}; } else { require Carp; Carp::croak("No property $orig is defined"); } } sub interpolate { my($self, $string, $prop) = @_; $prop ||= {}; $string =~ s{(?<!\%)\%\{([a-zA-Z_][a-zA-Z_0-9]+)\}}{$self->execute_helper($1)}eg; $string =~ s{(?<!\%)\%\{([a-zA-Z_\.][a-zA-Z_0-9\.]+)\}}{_get_prop($1,$prop,$1)}eg; $string =~ s/\%(?=\%)//g; $string; } sub requires { my($self, $string) = @_; map { my $helper = $self->{helper}->{$_}; $helper ? $helper->require : (); } $string =~ m{(?<!\%)\%\{([a-zA-Z_][a-zA-Z_0-9]+)\}}g; } sub clone { my($self) = @_; require Storable; my %helper; foreach my $name (keys %{ $self->{helper} }) { $helper{$name} = $self->{helper}->{$name}->clone; } my $new = bless { helper => \%helper, classes => Storable::dclone($self->{classes}), }, ref $self; } package Alien::Build::Helper; sub new { my($class, $name, $code, $require) = @_; bless { name => $name, code => $code, require => $require, }, $class; } sub name { shift->{name} } sub code { my($self, $code) = @_; $self->{code} = $code if $code; $self->{code}; } sub require { my($self) = @_; if(ref $self->{require} eq 'CODE') { $self->{require} = [ $self->{require}->($self) ]; } @{ $self->{require} }; } sub clone { my($self) = @_; my $class = ref $self; $class->new( $self->name, $self->code, [ $self->require ], ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Interpolate - Advanced interpolation engine for Alien builds =head1 VERSION version 2.41 =head1 CONSTRUCTOR =head2 new my $intr = Alien::Build::Interpolate->new; =head2 add_helper $intr->add_helper($name => $code); $intr->add_helper($name => $code, %requirements); =head2 replace_helper $intr->replace_helper($name => $code); $intr->replace_helper($name => $code, %requirements); =head2 has_helper my $coderef = $intr->has_helper($name); Used to discover if a helper exists with the given name. Returns the code reference. =head2 execute_helper my $value = $intr->execute_helper($name); =head2 interpolate my $string = $intr->interpolate($template); =head2 requires my %requires = $intr->requires($template); =head2 clone my $intr2 = $intr->clone; =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Interpolate/Default.pm 0000444 00000020160 14711220266 0014070 0 ustar 00 package Alien::Build::Interpolate::Default; use strict; use warnings; use 5.008004; use parent qw( Alien::Build::Interpolate ); use File::chdir; use File::Which qw( which ); use Capture::Tiny qw( capture ); # ABSTRACT: Default interpolator for Alien::Build our $VERSION = '2.41'; # VERSION sub _config { $Config::Config{$_[0]}; } sub new { my($class) = @_; my $self = $class->SUPER::new(@_); $self->add_helper( ar => sub { _config 'ar' }, 'Config' ); $self->add_helper( bison => undef, sub { my $helper = shift; if(which 'bison') { $helper->code(sub { 'bison' }); return (); } else { return 'Alien::bison' => '0.17'; } }); $self->add_helper( bzip2 => undef, sub { my $helper = shift; if(which 'bzip2') { $helper->code( sub { 'bzip2' }); return (); } else { return 'Alien::Libbz2' => '0.04'; } }); $self->add_helper( cc => sub { _config 'cc' }, 'Config' ); $self->add_helper( cmake => sub { 'cmake' }, sub { if(which 'cmake') { return (); } else { return 'Alien::CMake' => '0.07'; } }); $self->add_helper( cp => sub { _config 'cp' }, 'Config' ); $self->add_helper( devnull => sub { $^O eq 'MSWin32' ? 'NUL' : '/dev/null' }); $self->add_helper( flex => undef, sub { my $helper = shift; if(which 'flex') { $helper->code(sub { 'flex' }); return (); } else { return 'Alien::flex' => '0.08'; } }); $self->add_helper( gmake => undef, 'Alien::gmake' => '0.11' ); $self->add_helper( install => sub { 'install' }); $self->add_helper( ld => sub { _config 'ld' }, 'Config' ); $self->add_helper( m4 => undef, 'Alien::m4' => '0.08' ); if($^O eq 'MSWin32') { # TL;DR: dmake is bad, and shouldn't be used to build anything but older # versions of Windows Perl that don't support gmake. my $perl_make = _config 'make'; my $my_make; $self->add_helper( make => sub { return $my_make if defined $my_make; if( $perl_make ne 'dmake' && which $perl_make ) { # assume if it is called nmake or gmake that it really is what it # says it is. if( $perl_make eq 'nmake' || $perl_make eq 'gmake' ) { return $my_make = $perl_make; } my $out = capture { system $perl_make, '--version' }; if( $out =~ /GNU make/i || $out =~ /Microsoft \(R\) Program Maintenance/ ) { return $my_make = $perl_make; } } # if we see something that looks like it might be gmake, use that. foreach my $try (qw( gmake mingw32-make )) { return $my_make = $try if which $try; } if( which 'make' ) { my $out = capture { system 'make', '--version' }; if( $out =~ /GNU make/i || $out =~ /Microsoft \(R\) Program Maintenance/ ) { return $my_make = 'make'; } } # if we see something that looks like it might be nmake, use that. foreach my $try (qw( nmake )) { return $my_make = $try if which $try; } $my_make = $perl_make; }); } else { $self->add_helper( make => sub { _config 'make' }, 'Config' ); } $self->add_helper( mkdir_deep => sub { $^O eq 'MSWin32' ? 'md' : 'mkdir -p'}, 'Alien::Build' => '1.04' ); $self->add_helper( make_path => sub { $^O eq 'MSWin32' ? 'md' : 'mkdir -p'}, 'Alien::Build' => '1.05' ); $self->add_helper( nasm => undef, sub { my $helper = shift; if(which 'nasm') { $helper->code(sub { 'nasm' }); return (); } else { return 'Alien::nasm' => '0.11'; } }); $self->add_helper( patch => undef, sub { my $helper = shift; if(which 'patch') { if($^O eq 'MSWin32') { $helper->code(sub { 'patch --binary' }); } else { $helper->code(sub { 'patch' }); } return (); } else { return 'Alien::patch' => '0.09'; } }); $self->add_helper( perl => sub { my $perl = Devel::FindPerl::find_perl_interpreter(); $perl =~ s{\\}{/}g if $^O eq 'MSWin32'; $perl; }, 'Devel::FindPerl' ); $self->add_helper( pkgconf => undef, 'Alien::pkgconf' => 0.06 ); $self->add_helper( cwd => sub { my $cwd = "$CWD"; $cwd =~ s{\\}{/}g if $^O eq 'MSWin32'; $cwd; } ); $self->add_helper( sh => sub { 'sh' }, 'Alien::MSYS' => '0.07' ); $self->add_helper( rm => sub { _config 'rm' }, 'Config' ); $self->add_helper( xz => undef, sub { my $helper = shift; if(which 'xz') { $helper->code(sub { 'xz' }); return (); } else { return 'Alien::xz' => '0.02'; } }); $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Interpolate::Default - Default interpolator for Alien::Build =head1 VERSION version 2.41 =head1 CONSTRUCTOR =head2 new my $intr = Alien::Build::Interpolate::Default->new; =head1 HELPERS =head2 ar %{ar} The ar command. =head2 bison %{bison} Requires: L<Alien::bison> 0.17 if not already in C<PATH>. =head2 bzip2 %{bzip2} Requires: L<Alien::Libbz2> 0.04 if not already in C<PATH>. =head2 cc %{cc} The C Compiler used to build Perl =head2 cmake %{cmake} Requires: L<Alien::CMake> 0.07 if cmake is not already in C<PATH>. Deprecated: Use the L<Alien::Build::Plugin::Build::CMake> plugin instead (which will replace this helper with one that works with L<Alien::cmake3> that works better). =head2 cp %{cp} The copy command. =head2 devnull %{devnull} The null device, if available. On Unix style operating systems this will be C</dev/null> on Windows it is C<NUL>. =head2 flex %{flex} Requires: L<Alien::flex> 0.08 if not already in C<PATH>. =head2 gmake %{gmake} Requires: L<Alien::gmake> 0.11 Deprecated: use L<Alien::Build::Plugin::Build::Make> instead. =head2 install %{install} The Unix C<install> command. Not normally available on Windows. =head2 ld %{ld} The linker used to build Perl =head2 m4 %{m4} Requires: L<Alien::m4> 0.08 L<Alien::m4> should pull in a version of C<m4> that will work with Autotools. =head2 make %{make} Make. On Unix this will be the same make used by Perl. On Windows this will be C<gmake> or C<nmake> if those are available, and only C<dmake> if the first two are not available. =head2 make_path %{make_path} Make directory, including all parent directories as needed. This is usually C<mkdir -p> on Unix and simply C<md> on windows. =head2 nasm %{nasm} Requires: L<Alien::nasm> 0.11 if not already in the C<PATH>. =head2 patch %{patch} Requires: L<Alien::patch> 0.09 if not already in the C<PATH>. On Windows this will normally render C<patch --binary>, which makes patch work like it does on Unix. =head2 perl %{perl} Requires: L<Devel::FindPerl> =head2 pkgconf %{pkgconf} Requires: L<Alien::pkgconf> 0.06. =head2 cwd %{cwd} =head2 sh %{sh} Unix style command interpreter (/bin/sh). Deprecated: use the L<Alien::Build::Plugin::Build::MSYS> plugin instead. =head2 rm %{rm} The remove command =head2 xz %{xz} Requires: L<Alien::xz> 0.02 if not already in the C<PATH>. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Version/Basic.pm 0000444 00000011351 14711220267 0012667 0 ustar 00 package Alien::Build::Version::Basic; use strict; use warnings; use 5.008004; use Carp (); use Exporter qw( import ); use overload '<=>' => sub { shift->cmp(@_) }, 'cmp' => sub { shift->cmp(@_) }, '""' => sub { shift->as_string }, bool => sub { 1 }, fallback => 1; our @EXPORT_OK = qw( version ); # ABSTRACT: Very basic version object for Alien::Build our $VERSION = '2.41'; # VERSION sub new { my($class, $value) = @_; $value =~ s/\.$//; # trim trailing dot Carp::croak("invalud version: $value") unless $value =~ /^[0-9]+(\.[0-9]+)*$/; bless \$value, $class; } sub version ($) { my($value) = @_; __PACKAGE__->new($value); } sub as_string { my($self) = @_; "@{[ $$self ]}"; } sub cmp { my @x = split /\./, ${$_[0]}; my @y = split /\./, ${ref($_[1]) ? $_[1] : version($_[1])}; while(@x or @y) { my $x = (shift @x) || 0; my $y = (shift @y) || 0; return $x <=> $y if $x <=> $y; } 0; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Version::Basic - Very basic version object for Alien::Build =head1 VERSION version 2.41 =head1 SYNOPSIS OO interface: use Alien::Build::Version::Basic; my $version = Alien::Build::Version::Basic->new('1.2.3'); if($version > '1.2.2') # true { ... } Function interface: use Alien::Build::Version::Basic qw( version ); if(version('1.2.3') > version('1.2.2')) # true { ... } my @sorted = sort map { version($_) } qw( 2.1 1.2.3 1.2.2 ); # will come out in the order 1.2.2, 1.2.3, 2.1 =head1 DESCRIPTION This module provides a very basic class for comparing versions. This is already a crowded space on CPAN. Parts of L<Alien::Build> already use L<Sort::Versions>, which is fine for sorting versions. Sometimes you need to compare to see if versions match exact I<values>, and the best candidates (such as L<Sort::Versions> on CPAN compare C<1.2.3.0> and C<1.2.3> as being different. This class compares those two as the same. This class is also quite limited, in that it only works with version schemes using a doted version numbers or real numbers with a fixed number of digits. Versions with: dashes, letters, hex digits, or anything else are not supported. This class overloads both C<E<lt>=E<gt>> and C<cmp> to compare the version in the way that you would expect for version numbers. This way you can compare versions like numbers, or sort them using sort. if(version($v1) > version($v2)) { ... } my @sorted = sort map { version($_) } @unsorted; it also overloads C<""> to stringify as whatever string value you passed to the constructor. =head1 CONSTRUCTOR =head2 new my $version = Alien::Build::Version::Basic->new($value); This is the long form of the constructor, if you don't want to import anything into your namespace. =head2 version my $version = version($value); This is the short form of the constructor, if you are sane. It is NOT exported by default so you will have to explicitly import it. =head1 METHODS =head2 as_string my $string = $version->as_string; my $string = "$version"; Returns the string representation of the version object. =head2 cmp my $bool = $version->cmp($other); my $bool = $version <=> $other; my $bool = $version cmp $other; Returns C<-1>, C<0> or C<1> just like the regular C<E<lt>=E<gt>> and C<cmp> operators. Although C<$version> must be a version object, C<$other> may be either a version object, or a string that could be used to create a valid version object. =head1 SEE ALSO =over 4 =item L<Sort::Versions> Good, especially if you have to support rpm style versions (like C<1.2.3-2-b>) or don't care if trailing zeros (C<1.2.3> vs C<1.2.3.0>) are treated as different values. =item L<version> Problematic for historical reasons. =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Log/Abbreviate.pm 0000444 00000005053 14711220267 0013010 0 ustar 00 package Alien::Build::Log::Abbreviate; use strict; use warnings; use 5.008004; use Term::ANSIColor (); use Path::Tiny qw( path ); use File::chdir; use parent qw( Alien::Build::Log ); # ABSTRACT: Log class for Alien::Build which is less verbose our $VERSION = '2.41'; # VERSION sub _colored { my($code, @out) = @_; -t STDOUT ? Term::ANSIColor::_colored($code, @out) : @out; } my $root = path("$CWD"); sub log { my(undef, %args) = @_; my($message) = $args{message}; my ($package, $filename, $line) = @{ $args{caller} }; my $source = $package; $source =~ s/^Alien::Build::Auto::[^:]+::Alienfile/alienfile/; my $expected = $package; $expected .= '.pm' unless $package eq 'alienfile'; $expected =~ s/::/\//g; if($filename !~ /\Q$expected\E$/) { $source = path($filename)->relative($root); } else { $source =~ s/^Alien::Build::Plugin/ABP/; $source =~ s/^Alien::Build/AB/; } print _colored([ "bold on_black" ], '['); print _colored([ "bright_green on_black" ], $source); print _colored([ "on_black" ], ' '); print _colored([ "bright_yellow on_black" ], $line); print _colored([ "bold on_black" ], ']'); print _colored([ "white on_black" ], ' ', $message); print "\n"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Log::Abbreviate - Log class for Alien::Build which is less verbose =head1 VERSION version 2.41 =head1 SYNOPSIS =head1 DESCRIPTION =head1 METHODS =head2 log $log->log(%opts); Send single log line to stdout. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Log/Default.pm 0000444 00000003773 14711220270 0012331 0 ustar 00 package Alien::Build::Log::Default; use strict; use warnings; use 5.008004; use parent qw( Alien::Build::Log ); # ABSTRACT: Default Alien::Build log class our $VERSION = '2.41'; # VERSION sub log { my(undef, %args) = @_; my($message) = $args{message}; my ($package, $filename, $line) = @{ $args{caller} }; print "$package> $message\n"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Log::Default - Default Alien::Build log class =head1 VERSION version 2.41 =head1 SYNOPSIS Alien::Build->log("message1"); $build->log("message2"); =head1 DESCRIPTION This is the default log class for L<Alien::Build>. It does the sensible thing of sending the message to stdout, along with the class that made the log call. For more details about logging with L<Alien::Build>, see L<Alien::Build::Log>. =head1 METHODS =head2 log $log->log(%opts); Send single log line to stdout. =head1 SEE ALSO =over 4 =item L<Alien::Build> =item L<Alien::Build::Log> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/MM.pm 0000444 00000035600 14711220270 0010527 0 ustar 00 package Alien::Build::MM; use strict; use warnings; use 5.008004; use Alien::Build; use Path::Tiny (); use Capture::Tiny qw( capture ); use Carp (); # ABSTRACT: Alien::Build installer code for ExtUtils::MakeMaker our $VERSION = '2.41'; # VERSION sub new { my($class, %prop) = @_; my $self = bless {}, $class; my %meta = map { $_ => $prop{$_} } grep /^my_/, keys %prop; my $build = $self->{build} = Alien::Build->load('alienfile', root => "_alien", (-d 'patch' ? (patch => 'patch') : ()), meta_prop => \%meta, ) ; if(%meta) { $build->meta->add_requires(configure => 'Alien::Build::MM' => '1.20'); $build->meta->add_requires(configure => 'Alien::Build' => '1.20'); } if(defined $prop{alienfile_meta}) { $self->{alienfile_meta} = $prop{alienfile_meta}; } else { $self->{alienfile_meta} = 1; } $self->{clean_install} = $prop{clean_install}; $self->build->load_requires('configure'); $self->build->root; $self->build->checkpoint; $self; } sub build { shift->{build}; } sub alienfile_meta { shift->{alienfile_meta}; } sub clean_install { shift->{clean_install}; } sub mm_args { my($self, %args) = @_; if($args{DISTNAME}) { $self->build->set_stage(Path::Tiny->new("blib/lib/auto/share/dist/$args{DISTNAME}")->absolute->stringify); $self->build->install_prop->{mm}->{distname} = $args{DISTNAME}; my $module = $args{DISTNAME}; $module =~ s/-/::/g; # See if there is an existing version installed, without pulling it into this process my($old_prefix, $err, $ret) = capture { system $^X, "-M$module", -e => "print $module->dist_dir"; $? }; if($ret == 0) { chomp $old_prefix; my $file = Path::Tiny->new($old_prefix, qw( _alien alien.json )); if(-r $file) { my $old_runtime = eval { require JSON::PP; JSON::PP::decode_json($file->slurp); }; unless($@) { $self->build->install_prop->{old}->{runtime} = $old_runtime; $self->build->install_prop->{old}->{prefix} = $old_prefix; } } } } else { Carp::croak "DISTNAME is required"; } my $ab_version = '0.25'; if($self->clean_install) { $ab_version = '1.74'; } $args{CONFIGURE_REQUIRES} = Alien::Build::_merge( 'Alien::Build::MM' => $ab_version, %{ $args{CONFIGURE_REQUIRES} || {} }, %{ $self->build->requires('configure') || {} }, ); if($self->build->install_type eq 'system') { $args{BUILD_REQUIRES} = Alien::Build::_merge( 'Alien::Build::MM' => $ab_version, %{ $args{BUILD_REQUIRES} || {} }, %{ $self->build->requires('system') || {} }, ); } elsif($self->build->install_type eq 'share') { $args{BUILD_REQUIRES} = Alien::Build::_merge( 'Alien::Build::MM' => $ab_version, %{ $args{BUILD_REQUIRES} || {} }, %{ $self->build->requires('share') || {} }, ); } else { die "unknown install type: @{[ $self->build->install_type ]}" } $args{PREREQ_PM} = Alien::Build::_merge( 'Alien::Build' => $ab_version, %{ $args{PREREQ_PM} || {} }, ); #$args{META_MERGE}->{'meta-spec'}->{version} = 2; $args{META_MERGE}->{dynamic_config} = 1; if($self->alienfile_meta) { $args{META_MERGE}->{x_alienfile} = { generated_by => "@{[ __PACKAGE__ ]} version @{[ __PACKAGE__->VERSION || 'dev' ]}", requires => { map { my %reqs = %{ $self->build->requires($_) }; $reqs{$_} = "$reqs{$_}" for keys %reqs; $_ => \%reqs; } qw( share system ) }, }; } $self->build->checkpoint; %args; } sub mm_postamble { # NOTE: older versions of the Alien::Build::MM documentation # didn't include $mm and @rest args, so anything that this # method uses them for has to be optional. # (as of this writing they are unused, but are being added # to match the way mm_install works). my($self, $mm, @rest) = @_; my $postamble = ''; # remove the _alien directory on a make realclean: $postamble .= "realclean :: alien_realclean\n" . "\n" . "alien_realclean:\n" . "\t\$(RM_RF) _alien\n\n"; # remove the _alien directory on a make clean: $postamble .= "clean :: alien_clean\n" . "\n" . "alien_clean:\n" . "\t\$(RM_RF) _alien\n\n"; my $dirs = $self->build->meta_prop->{arch} ? '$(INSTALLARCHLIB) $(INSTALLSITEARCH) $(INSTALLVENDORARCH)' : '$(INSTALLPRIVLIB) $(INSTALLSITELIB) $(INSTALLVENDORLIB)' ; # set prefix $postamble .= "alien_prefix : _alien/mm/prefix\n\n" . "_alien/mm/prefix :\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e prefix \$(INSTALLDIRS) $dirs\n\n"; # set verson $postamble .= "alien_version : _alien/mm/version\n\n" . "_alien/mm/version : _alien/mm/prefix\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e version \$(VERSION)\n\n"; # download $postamble .= "alien_download : _alien/mm/download\n\n" . "_alien/mm/download : _alien/mm/prefix _alien/mm/version\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e download\n\n"; # build $postamble .= "alien_build : _alien/mm/build\n\n" . "_alien/mm/build : _alien/mm/download\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e build\n\n"; # append to all $postamble .= "pure_all :: _alien/mm/build\n\n"; $postamble .= "subdirs-test_dynamic subdirs-test_static subdirs-test :: alien_test\n\n"; $postamble .= "alien_test :\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e test\n\n"; # prop $postamble .= "alien_prop :\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop\n\n"; $postamble .= "alien_prop_meta :\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop meta\n\n"; $postamble .= "alien_prop_install :\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop install\n\n"; $postamble .= "alien_prop_runtime :\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e dumpprop runtime\n\n"; # install $postamble .= "alien_clean_install : _alien/mm/prefix\n" . "\t\$(FULLPERL) -MAlien::Build::MM=cmd -e clean_install\n\n"; $postamble; } sub mm_install { # NOTE: older versions of the Alien::Build::MM documentation # didn't include this method, so anything that this method # does has to be optional my($self, $mm, @rest) = @_; my $section = do { package MY; $mm->SUPER::install(@rest); }; return ".NOTPARALLEL : \n\n" . ".NO_PARALLEL : \n\n" . "install :: alien_clean_install\n\n" . $section; } sub import { my(undef, @args) = @_; foreach my $arg (@args) { if($arg eq 'cmd') { package main; *_args = sub { my $build = Alien::Build->resume('alienfile', '_alien'); $build->load_requires('configure'); $build->load_requires($build->install_type); ($build, @ARGV) }; *_touch = sub { my($name) = @_; my $path = Path::Tiny->new("_alien/mm/$name"); $path->parent->mkpath; $path->touch; }; *prefix = sub { my($build, $type, $perl, $site, $vendor) = _args(); my $distname = $build->install_prop->{mm}->{distname}; my $prefix = $type eq 'perl' ? $perl : $type eq 'site' ? $site : $type eq 'vendor' ? $vendor : die "unknown INSTALLDIRS ($type)"; $prefix = Path::Tiny->new($prefix)->child("auto/share/dist/$distname")->absolute->stringify; $build->log("prefix $prefix"); $build->set_prefix($prefix); $build->checkpoint; _touch('prefix'); }; *version = sub { my($build, $version) = _args(); $build->runtime_prop->{perl_module_version} = $version; $build->checkpoint; _touch('version'); }; *download = sub { my($build) = _args(); $build->download; $build->checkpoint; _touch('download'); }; *build = sub { my($build) = _args(); $build->build; my $distname = $build->install_prop->{mm}->{distname}; if($build->meta_prop->{arch}) { my $archdir = Path::Tiny->new("blib/arch/auto/@{[ join '/', split /-/, $distname ]}"); $archdir->mkpath; my $archfile = $archdir->child($archdir->basename . '.txt'); $archfile->spew('Alien based distribution with architecture specific file in share'); } my $cflags = $build->runtime_prop->{cflags}; my $libs = $build->runtime_prop->{libs}; if(($cflags && $cflags !~ /^\s*$/) || ($libs && $libs !~ /^\s*$/)) { my $mod = join '::', split /-/, $distname; my $install_files_pm = Path::Tiny->new("blib/lib/@{[ join '/', split /-/, $distname ]}/Install/Files.pm"); $install_files_pm->parent->mkpath; $install_files_pm->spew( "package ${mod}::Install::Files;\n", "use strict;\n", "use warnings;\n", "require ${mod};\n", "sub Inline { shift; ${mod}->Inline(\@_) }\n", "1;\n", "\n", "=begin Pod::Coverage\n", "\n", " Inline\n", "\n", "=cut\n", ); } $build->checkpoint; _touch('build'); }; *test = sub { my($build) = _args(); $build->test; $build->checkpoint; }; *clean_install = sub { my($build) = _args(); $build->clean_install; $build->checkpoint; }; *dumpprop = sub { my($build, $type) = _args(); my %h = ( meta => $build->meta_prop, install => $build->install_prop, runtime => $build->runtime_prop, ); require Alien::Build::Util; print Alien::Build::Util::_dump($type ? $h{$type} : \%h); } } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::MM - Alien::Build installer code for ExtUtils::MakeMaker =head1 VERSION version 2.41 =head1 SYNOPSIS In your C<Makefile.PL>: use ExtUtils::MakeMaker; use Alien::Build::MM; my $abmm = Alien::Build::MM->new; WriteMakefile($abmm->mm_args( ABSTRACT => 'Discover or download and install libfoo', DISTNAME => 'Alien-Libfoo', NAME => 'Alien::Libfoo', VERSION_FROM => 'lib/Alien/Libfoo.pm', ... )); sub MY::postamble { $abmm->mm_postamble(@_); } sub MY::install { $abmm->mm_install(@_); } In your C<lib/Alien/Libfoo.pm>: package Alien::Libfoo; use parent qw( Alien::Base ); 1; In your alienfile (needs to be named C<alienfile> and should be in the root of your dist): use alienfile; plugin 'PkgConfig' => 'libfoo'; share { start_url 'http://libfoo.org'; ... }; =head1 DESCRIPTION This class allows you to use Alien::Build and Alien::Base with L<ExtUtils::MakeMaker>. It load the L<alienfile> recipe in the root of your L<Alien> dist, updates the prereqs passed into C<WriteMakefile> if any are specified by your L<alienfile> or its plugins, and adds a postamble to the C<Makefile> that will download/build/test the alienized package as appropriate. The L<alienfile> must be named C<alienfile>. If you are using L<Dist::Zilla> to author your L<Alien> dist, you should consider using the L<Dist::Zilla::Plugin::AlienBuild> plugin. I personally don't recommend it, but if you want to use L<Module::Build> instead, you can use L<Alien::Build::MB>. =head1 CONSTRUCTOR =head2 new my $abmm = Alien::Build::MM->new; Create a new instance of L<Alien::Build::MM>. =head1 PROPERTIES =head2 build my $build = $abmm->build; The L<Alien::Build> instance. =head2 alienfile_meta my $bool = $abmm->alienfile_meta Set to a false value, in order to turn off the x_alienfile meta =head2 clean_install my $bool = $abmm->clean_install; Set to a true value, in order to clean the share directory prior to installing. If you use this you have to make sure that you install the install handler in your C<Makefile.PL>: $abmm = Alien::Build::MM->new( clean_install => 1, ); ... sub MY::install { $abmm->mm_install(@_); } =head1 METHODS =head2 mm_args my %args = $abmm->mm_args(%args); Adjust the arguments passed into C<WriteMakefile> as needed by L<Alien::Build>. =head2 mm_postamble my $postamble $abmm->mm_postamble; my $postamble $abmm->mm_postamble($mm); Returns the postamble for the C<Makefile> needed for L<Alien::Build>. This adds the following C<make> targets which are normally called when you run C<make all>, but can be run individually if needed for debugging. =over 4 =item alien_prefix Determines the final install prefix (C<%{.install.prefix}>). =item alien_version Determine the perl_module_version (C<%{.runtime.perl_module_version}>) =item alien_download Downloads the source from the internet. Does nothing for a system install. =item alien_build Build from source (if a share install). Gather configuration (for either system or share install). =item alien_prop, alien_prop_meta, alien_prop_install, alien_prop_runtime Prints the meta, install and runtime properties for the Alien. =item alien_realclean, alien_clean Removes the alien specific files. These targets are executed when you call the C<realclean> and C<clean> targets respectively. =item alien_clean_install Cleans out the Alien's share directory. Caution should be used in invoking this target directly, as if you do not understand what you are doing you are likely to break your already installed Alien. =back =head2 mm_install sub MY::install { $abmm->mm_install(@_); } B<EXPERIMENTAL> Adds an install rule to clean the final install dist directory prior to installing. =head1 SEE ALSO L<Alien::Build>, L<Alien::Base>, L<Alien>, L<Dist::Zilla::Plugin::AlienBuild>, L<Alien::Build::MB> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build/Log.pm 0000444 00000006200 14711220271 0010732 0 ustar 00 package Alien::Build::Log; use strict; use warnings; use 5.008004; use Carp (); # ABSTRACT: Alien::Build logging our $VERSION = '2.41'; # VERSION my $log_class; my $self; sub new { my($class) = @_; Carp::croak("Cannot instantiate base class") if $class eq 'Alien::Build::Log'; return bless {}, $class; } sub default { $self || do { my $class = $log_class || $ENV{ALIEN_BUILD_LOG} || 'Alien::Build::Log::Default'; unless(eval { $class->can('new') }) { my $pm = "$class.pm"; $pm =~ s/::/\//g; require $pm; } $class->new; } } sub set_log_class { my(undef, $class) = @_; return if defined $class && ($class eq ($log_class || '')); $log_class = $class; undef $self; } sub log { Carp::croak("AB Log base class"); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build::Log - Alien::Build logging =head1 VERSION version 2.41 =head1 SYNOPSIS Create your custom log class: package Alien::Build::Log::MyLog; use parent qw( Alien::Build::Log ); sub log { my(undef, %opt) = @_; my($package, $filename, $line) = @{ $opt{caller} }; my $message = $opt{message}; ...; } override log class: % env ALIEN_BUILD_LOG=Alien::Build::Log::MyLog cpanm Alien::libfoo =head1 DESCRIPTION =head1 CONSTRUCTORS =head2 new my $log = Alien::Build::Log->new; Create an instance of the log class. =head2 default my $log = Alien::Build::Log->default; Return singleton instance of log class used by L<Alien::Build>. =head1 METHODS =head2 set_log_class Alien::Build::Log->set_log_class($class); Set the default log class used by L<Alien::Build>. This method will also reset the default instance used by L<Alien::Build>. If not specified, L<Alien::Build::Log::Default> will be used. =head2 log $log->log(%options); Overridable method which does the actual work of the log class. Options: =over 4 =item caller Array references containing the package, file and line number of where the log was called. =item message The message to log. =back =head1 ENVIRONMENT =over 4 =item ALIEN_BUILD_LOG The default log class used by L<Alien::Build>. =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Base.pm 0000444 00000067152 14711220271 0010041 0 ustar 00 package Alien::Base; use strict; use warnings; use 5.008004; use Carp; use Path::Tiny (); use Scalar::Util qw/blessed/; use Capture::Tiny 0.17 qw/capture_stdout/; use Text::ParseWords qw/shellwords/; # ABSTRACT: Base classes for Alien:: modules our $VERSION = '2.41'; # VERSION sub import { my $class = shift; return if $class eq __PACKAGE__; return if $class->runtime_prop; return if $class->install_type('system'); require DynaLoader; # Sanity check in order to ensure that dist_dir can be found. # This will throw an exception otherwise. $class->dist_dir; # get a reference to %Alien::MyLibrary::AlienLoaded # which contains names of already loaded libraries # this logic may be replaced by investigating the DynaLoader arrays my $loaded = do { no strict 'refs'; no warnings 'once'; \%{ $class . "::AlienLoaded" }; }; my @libs = $class->split_flags( $class->libs ); my @L = grep { s/^-L// } map { "$_" } @libs; ## no critic (ControlStructures::ProhibitMutatingListFunctions) my @l = grep { /^-l/ } @libs; unshift @DynaLoader::dl_library_path, @L; my @libpaths; foreach my $l (@l) { next if $loaded->{$l}; my $path = DynaLoader::dl_findfile( $l ); unless ($path) { carp "Could not resolve $l"; next; } push @libpaths, $path; $loaded->{$l} = $path; } push @DynaLoader::dl_resolve_using, @libpaths; my @librefs = map { DynaLoader::dl_load_file( $_, 0x01 ) } grep !/\.(a|lib)$/, @libpaths; push @DynaLoader::dl_librefs, @librefs; } sub _dist_dir ($) { my($dist_name) = @_; my @pm = split /-/, $dist_name; $pm[-1] .= ".pm"; foreach my $inc (@INC) { my $pm = Path::Tiny->new($inc, @pm); if(-f $pm) { my $share = Path::Tiny->new($inc, qw( auto share dist ), $dist_name ); if(-d $share) { return $share->absolute->stringify; } last; } } Carp::croak("unable to find dist share directory for $dist_name"); } sub dist_dir { my $class = shift; my $dist = blessed $class || $class; $dist =~ s/::/-/g; my $dist_dir = $class->config('finished_installing') ? _dist_dir $dist : $class->config('working_directory'); croak "Failed to find share dir for dist '$dist'" unless defined $dist_dir && -d $dist_dir; return $dist_dir; } sub new { return bless {}, $_[0] } sub _flags { my($class, $key) = @_; my $config = $class->runtime_prop; my $flags = $config->{$key}; my $prefix = $config->{prefix}; $prefix =~ s{\\}{/}g if $^O =~ /^(MSWin32|msys)$/; my $distdir = $config->{distdir}; $distdir =~ s{\\}{/}g if $^O =~ /^(MSWin32|msys)$/; if($prefix ne $distdir) { $flags = join ' ', map { my $flag = $_; $flag =~ s/^(-I|-L|-LIBPATH:)?\Q$prefix\E/$1$distdir/; $flag =~ s/(\s)/\\$1/g; $flag; } $class->split_flags($flags); } $flags; } sub cflags { my $class = shift; return $class->runtime_prop ? $class->_flags('cflags') : $class->_pkgconfig_keyword('Cflags'); } sub cflags_static { my $class = shift; return $class->runtime_prop ? $class->_flags('cflags_static') : $class->_pkgconfig_keyword('Cflags', 'static'); } sub libs { my $class = shift; return $class->runtime_prop ? $class->_flags('libs') : $class->_pkgconfig_keyword('Libs'); } sub libs_static { my $class = shift; return $class->runtime_prop ? $class->_flags('libs_static') : $class->_pkgconfig_keyword('Libs', 'static'); } sub version { my $self = shift; return $self->runtime_prop ? $self->runtime_prop->{version} : do { my $version = $self->config('version'); chomp $version; $version; }; } sub atleast_version { my $self = shift; my ($wantver) = @_; defined(my $version = $self->version) or croak "$self has no defined ->version"; return $self->version_cmp($version, $wantver) >= 0; } sub exact_version { my $self = shift; my ($wantver) = @_; defined(my $version = $self->version) or croak "$self has no defined ->version"; return $self->version_cmp($version, $wantver) == 0; } sub max_version { my $self = shift; my ($wantver) = @_; defined(my $version = $self->version) or croak "$self has no defined ->version"; return $self->version_cmp($version, $wantver) <= 0; } # Sort::Versions isn't quite the same algorithm because it differs in # behaviour with leading zeroes. # See also https://dev.gentoo.org/~mgorny/pkg-config-spec.html#version-comparison sub version_cmp { shift; my @x = (shift =~ m/([0-9]+|[a-z]+)/ig); my @y = (shift =~ m/([0-9]+|[a-z]+)/ig); while(@x and @y) { my $x = shift @x; my $x_isnum = $x =~ m/[0-9]/; my $y = shift @y; my $y_isnum = $y =~ m/[0-9]/; if($x_isnum and $y_isnum) { # Numerical comparison return $x <=> $y if $x != $y; } elsif(!$x_isnum && !$y_isnum) { # Alphabetic comparison return $x cmp $y if $x ne $y; } else { # Of differing types, the numeric one is newer return $x_isnum - $y_isnum; } } # Equal so far; the longer is newer return @x <=> @y; } sub install_type { my $self = shift; my $type = $self->config('install_type'); return @_ ? $type eq $_[0] : $type; } sub _pkgconfig_keyword { my $self = shift; my $keyword = shift; my $static = shift; # use pkg-config if installed system-wide if ($self->install_type('system')) { my $name = $self->config('name'); require Alien::Base::PkgConfig; my $command = Alien::Base::PkgConfig->pkg_config_command . " @{[ $static ? '--static' : '' ]} --\L$keyword\E $name"; $! = 0; chomp ( my $pcdata = capture_stdout { system( $command ) } ); # if pkg-config fails for whatever reason, then we try to # fallback on alien_provides_* $pcdata = '' if $! || $?; $pcdata =~ s/\s*$//; if($self->config('system_provides')) { if(my $system_provides = $self->config('system_provides')->{$keyword}) { $pcdata = length $pcdata ? "$pcdata $system_provides" : $system_provides; } } return $pcdata; } # use parsed info from build .pc file my $dist_dir = $self->dist_dir; my @pc = $self->_pkgconfig(@_); my @strings = grep defined, map { $_->keyword($keyword, #{ pcfiledir => $dist_dir } ) } @pc; if(defined $self->config('original_prefix') && $self->config('original_prefix') ne $self->dist_dir) { my $dist_dir = $self->dist_dir; $dist_dir =~ s{\\}{/}g if $^O eq 'MSWin32'; my $old = quotemeta $self->config('original_prefix'); @strings = map { my $flag = $_; $flag =~ s{^(-I|-L|-LIBPATH:)?($old)}{$1.$dist_dir}e; $flag =~ s/(\s)/\\$1/g; $flag; } map { $self->split_flags($_) } @strings; } return join( ' ', @strings ); } sub _pkgconfig { my $self = shift; my %all = %{ $self->config('pkgconfig') }; # merge in found pc files require File::Find; my $wanted = sub { return if ( -d or not /\.pc$/ ); require Alien::Base::PkgConfig; my $pkg = Alien::Base::PkgConfig->new($_); $all{$pkg->{package}} = $pkg; }; File::Find::find( $wanted, $self->dist_dir ); croak "No Alien::Base::PkgConfig objects are stored!" unless keys %all; # Run through all pkgconfig objects and ensure that their modules are loaded: for my $pkg_obj (values %all) { my $perl_module_name = blessed $pkg_obj; my $pm = "$perl_module_name.pm"; $pm =~ s/::/\//g; eval { require $pm }; } return @all{@_} if @_; my $manual = delete $all{_manual}; if (keys %all) { return values %all; } else { return $manual; } } # helper method to call Alien::MyLib::ConfigData->config(@_) sub config { my $class = shift; $class = blessed $class || $class; if(my $ab_config = $class->runtime_prop) { my $key = shift; return $ab_config->{legacy}->{$key}; } my $config = $class . '::ConfigData'; my $pm = "$class/ConfigData.pm"; $pm =~ s{::}{/}g; eval { require $pm }; if($@) { warn "Cannot find either a share directory or a ConfigData module for $class.\n"; my $pm = "$class.pm"; $pm =~ s{::}{/}g; warn "($class loaded from $INC{$pm})\n" if $INC{$pm}; warn "Please see https://metacpan.org/pod/distribution/Alien-Build/lib/Alien/Build/Manual/FAQ.pod#Cannot-find-either-a-share-directory-or-a-ConfigData-module\n"; die $@; } return $config->config(@_); } # helper method to split flags based on the OS sub split_flags { my ($class, $line) = @_; if( $^O eq 'MSWin32' ) { $class->split_flags_windows($line); } else { # $os eq 'Unix' $class->split_flags_unix($line); } } sub split_flags_unix { my ($class, $line) = @_; shellwords($line); } sub split_flags_windows { # NOTE a better approach would be to write a function that understands cmd.exe metacharacters. my ($class, $line) = @_; # Double the backslashes so that when they are unescaped by shellwords(), # they become a single backslash. This should be fine on Windows since # backslashes are not used to escape metacharacters in cmd.exe. $line =~ s,\\,\\\\,g; shellwords($line); } sub dynamic_libs { my ($class) = @_; require FFI::CheckLib; my @find_lib_flags; if($class->install_type('system')) { if(my $prop = $class->runtime_prop) { if($prop->{ffi_checklib}->{system}) { push @find_lib_flags, @{ $prop->{ffi_checklib}->{system} }; } return FFI::CheckLib::find_lib( lib => $prop->{ffi_name}, @find_lib_flags ) if defined $prop->{ffi_name}; } my $name = $class->config('ffi_name'); unless(defined $name) { $name = $class->config('name'); $name = '' unless defined $name; # strip leading lib from things like libarchive or libffi $name =~ s/^lib//; # strip trailing version numbers $name =~ s/-[0-9\.]+$//; } my @libpath; foreach my $flag ($class->split_flags($class->libs)) { if($flag =~ /^-L(.*)$/) { push @libpath, $1; } } return FFI::CheckLib::find_lib(lib => $name, libpath => \@libpath, @find_lib_flags ); } else { my $dir = $class->dist_dir; my $dynamic = Path::Tiny->new($class->dist_dir, 'dynamic'); if(my $prop = $class->runtime_prop) { if($prop->{ffi_checklib}->{share}) { push @find_lib_flags, @{ $prop->{ffi_checklib}->{share_flags} }; } } if(-d $dynamic) { return FFI::CheckLib::find_lib( lib => '*', libpath => "$dynamic", systempath => [], ); } return FFI::CheckLib::find_lib( lib => '*', libpath => $dir, systempath => [], recursive => 1, ); } } sub bin_dir { my ($class) = @_; if($class->install_type('system')) { my $prop = $class->runtime_prop; return () unless defined $prop; return () unless defined $prop->{system_bin_dir}; return ref $prop->{system_bin_dir} ? @{ $prop->{system_bin_dir} } : ($prop->{system_bin_dir}); } else { my $dir = Path::Tiny->new($class->dist_dir, 'bin'); return -d $dir ? ("$dir") : (); } } sub dynamic_dir { my ($class) = @_; if($class->install_type('system')) { return (); } else { my $dir = Path::Tiny->new($class->dist_dir, 'dynamic'); return -d $dir ? ("$dir") : (); } } sub alien_helper { {}; } sub inline_auto_include { my ($class) = @_; return [] unless $class->config('inline_auto_include'); $class->config('inline_auto_include') } sub Inline { my ($class, $language) = @_; return unless defined $language; return if $language !~ /^(C|CPP)$/; my $config = { # INC should arguably be for -I flags only, but # this improves compat with ExtUtils::Depends. # see gh#107, gh#108 INC => $class->cflags, LIBS => $class->libs, }; if (@{ $class->inline_auto_include } > 0) { $config->{AUTO_INCLUDE} = join "\n", map { "#include \"$_\"" } @{ $class->inline_auto_include }; } $config; } { my %alien_build_config_cache; sub runtime_prop { my($class) = @_; if(ref($class)) { # called as an instance method. my $self = $class; $class = ref $self; return $self->{_alt}->{runtime_prop} if defined $self->{_alt}; } return $alien_build_config_cache{$class} if exists $alien_build_config_cache{$class}; $alien_build_config_cache{$class} ||= do { my $dist = ref $class ? ref $class : $class; $dist =~ s/::/-/g; my $dist_dir = eval { _dist_dir $dist }; return if $@; my $alien_json = Path::Tiny->new($dist_dir, '_alien', 'alien.json'); return unless -r $alien_json; my $json = $alien_json->slurp; require JSON::PP; my $config = JSON::PP::decode_json($json); $config->{distdir} = $dist_dir; $config; }; } } sub alt { my($old, $name) = @_; my $new = ref $old ? (ref $old)->new : $old->new; my $orig; if(ref($old) && defined $old->{_alt}) { $orig = $old->{_alt}->{orig} } else { $orig = $old->runtime_prop } require Storable; my $runtime_prop = Storable::dclone($orig); if($runtime_prop->{alt}->{$name}) { foreach my $key (keys %{ $runtime_prop->{alt}->{$name} }) { $runtime_prop->{$key} = $runtime_prop->{alt}->{$name}->{$key}; } } else { Carp::croak("no such alt: $name"); } $new->{_alt} = { runtime_prop => $runtime_prop, orig => $orig, }; $new; } sub alt_names { my($class) = @_; my $alts = $class->runtime_prop->{alt}; defined $alts ? sort keys %$alts : (); } sub alt_exists { my($class, $alt_name) = @_; my $alts = $class->runtime_prop->{alt}; defined $alts ? exists $alts->{$alt_name} && defined $alts->{$alt_name} : 0; } 1; =pod =encoding UTF-8 =head1 NAME Alien::Base - Base classes for Alien:: modules =head1 VERSION version 2.41 =head1 SYNOPSIS package Alien::MyLibrary; use strict; use warnings; use parent 'Alien::Base'; 1; (for details on the C<Makefile.PL> or C<Build.PL> and L<alienfile> that should be bundled with your L<Alien::Base> subclass, please see L<Alien::Build::Manual::AlienAuthor>). Then a C<MyLibrary::XS> can use C<Alien::MyLibrary> in its C<Makefile.PL>: use Alien::MyLibrary use ExtUtils::MakeMaker; use Alien::Base::Wrapper qw( Alien::MyLibrary !export ); use Config; WriteMakefile( ... Alien::Base::Wrapper->mm_args, ... ); Or if you prefer L<Module::Build>, in its C<Build.PL>: use Alien::MyLibrary; use Module::Build 0.28; # need at least 0.28 use Alien::Base::Wrapper qw( Alien::MyLibrary !export ); my $builder = Module::Build->new( ... Alien::Base::Wrapper->mb_args, ... ); $builder->create_build_script; Or if you are using L<ExtUtils::Depends>: use ExtUtils::MakeMaker; use ExtUtils::Depends; my $eud = ExtUtils::Depends->new(qw( MyLibrary::XS Alien::MyLibrary )); WriteMakefile( ... $eud->get_makefile_vars ); If you are using L<Alien::Base::ModuleBuild> instead of the recommended L<Alien::Build> and L<alienfile>, then in your C<MyLibrary::XS> module, you may need something like this in your main C<.pm> file IF your library uses dynamic libraries: package MyLibrary::XS; use Alien::MyLibrary; # may only be needed if you are using Alien::Base::ModuleBuild ... Or you can use it from an FFI module: package MyLibrary::FFI; use Alien::MyLibrary; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(Alien::MyLibrary->dynamic_libs); $ffi->attach( 'my_library_function' => [] => 'void' ); You can even use it with L<Inline> (C and C++ languages are supported): package MyLibrary::Inline; use Alien::MyLibrary; # Inline 0.56 or better is required use Inline 0.56 with => 'Alien::MyLibrary'; ... =head1 DESCRIPTION B<NOTE>: L<Alien::Base::ModuleBuild> is no longer bundled with L<Alien::Base> and has been spun off into a separate distribution. L<Alien::Build::ModuleBuild> will be a prerequisite for L<Alien::Base> until October 1, 2017. If you are using L<Alien::Base::ModuleBuild> you need to make sure it is declared as a C<configure_requires> in your C<Build.PL>. You may want to also consider using L<Alien::Base> and L<alienfile> as a more modern alternative. L<Alien::Base> comprises base classes to help in the construction of C<Alien::> modules. Modules in the L<Alien> namespace are used to locate and install (if necessary) external libraries needed by other Perl modules. This is the documentation for the L<Alien::Base> module itself. If you are starting out you probably want to do so from one of these documents: =over 4 =item L<Alien::Build::Manual::AlienUser> For users of an C<Alien::libfoo> that is implemented using L<Alien::Base>. (The developer of C<Alien::libfoo> I<should> provide the documentation necessary, but if not, this is the place to start). =item L<Alien::Build::Manual::AlienAuthor> If you are writing your own L<Alien> based on L<Alien::Build> and L<Alien::Base>. =item L<Alien::Build::Manual::FAQ> If you have a common question that has already been answered, like "How do I use L<alienfile> with some build system". =item L<Alien::Build::Manual::PluginAuthor> This is for the brave souls who want to write plugins that will work with L<Alien::Build> + L<alienfile>. =back =head1 METHODS In the example snippets here, C<Alien::MyLibrary> represents any subclass of L<Alien::Base>. =head2 dist_dir my $dir = Alien::MyLibrary->dist_dir; Returns the directory that contains the install root for the packaged software, if it was built from install (i.e., if C<install_type> is C<share>). =head2 new my $alien = Alien::MyLibrary->new; Creates an instance of an L<Alien::Base> object. This is typically unnecessary. =head2 cflags my $cflags = Alien::MyLibrary->cflags; use Text::ParseWords qw( shellwords ); my @cflags = shellwords( Alien::MyLibrary->cflags ); Returns the C compiler flags necessary to compile an XS module using the alien software. If you need this in list form (for example if you are calling system with a list argument) you can pass this value into C<shellwords> from the Perl core L<Text::ParseWords> module. =head2 cflags_static my $cflags = Alien::MyLibrary->cflags_static; Same as C<cflags> above, but gets the static compiler flags, if they are different. =head2 libs my $libs = Alien::MyLibrary->libs; use Text::ParseWords qw( shellwords ); my @cflags = shellwords( Alien::MyLibrary->libs ); Returns the library linker flags necessary to link an XS module against the alien software. If you need this in list form (for example if you are calling system with a list argument) you can pass this value into C<shellwords> from the Perl core L<Text::ParseWords> module. =head2 libs_static my $libs = Alien::MyLibrary->libs_static; Same as C<libs> above, but gets the static linker flags, if they are different. =head2 version my $version = Alien::MyLibrary->version; Returns the version of the alienized library or tool that was determined at install time. =head2 atleast_version =head2 exact_version =head2 max_version my $ok = Alien::MyLibrary->atleast_version($wanted_version); my $ok = Alien::MyLibrary->exact_version($wanted_version); my $ok = Alien::MyLibrary->max_version($wanted_version); Returns true if the version of the alienized library or tool is at least, exactly, or at most the version specified, respectively. =head2 version_cmp $cmp = Alien::MyLibrary->version_cmp($x, $y) Comparison method used by L<atleast_version>, L<exact_version> and L<max_version>. May be useful to implement custom comparisons, or for subclasses to overload to get different version comparison semantics than the default rules, for packages that have some other rules than the F<pkg-config> behaviour. Should return a number less than, equal to, or greater than zero; similar in behaviour to the C<< <=> >> and C<cmp> operators. =head2 install_type my $install_type = Alien::MyLibrary->install_type; my $bool = Alien::MyLibrary->install_type($install_type); Returns the install type that was used when C<Alien::MyLibrary> was installed. If a type is provided (the second form in the synopsis) returns true if the actual install type matches. Types include: =over 4 =item system The library was provided by the operating system =item share The library was not available when C<Alien::MyLibrary> was installed, so it was built from source code, either downloaded from the Internet or bundled with C<Alien::MyLibrary>. =back =head2 config my $value = Alien::MyLibrary->config($key); Returns the configuration data as determined during the install of L<Alien::MyLibrary>. For the appropriate config keys, see L<Alien::Base::ModuleBuild::API#CONFIG-DATA>. This is not typically used by L<Alien::Base> and L<alienfile>, but a compatible interface will be provided. =head2 dynamic_libs my @dlls = Alien::MyLibrary->dynamic_libs; my($dll) = Alien::MyLibrary->dynamic_libs; Returns a list of the dynamic library or shared object files for the alien software. =head2 bin_dir my(@dir) = Alien::MyLibrary->bin_dir Returns a list of directories with executables in them. For a C<system> install this will be an empty list. For a C<share> install this will be a directory under C<dist_dir> named C<bin> if it exists. You may wish to override the default behavior if you have executables or scripts that get installed into non-standard locations. Example usage: use Env qw( @PATH ); unshift @PATH, Alien::MyLibrary->bin_dir; =head2 dynamic_dir my(@dir) = Alien::MyLibrary->dynamic_dir Returns the dynamic dir for a dynamic build (if the main build is static). For a C<share> install this will be a directory under C<dist_dir> named C<dynamic> if it exists. System builds return an empty list. Example usage: use Env qw( @PATH ); unshift @PATH, Alien::MyLibrary->dynamic_dir; =head2 alien_helper my $helpers = Alien::MyLibrary->alien_helper; Returns a hash reference of helpers provided by the Alien module. The keys are helper names and the values are code references. The code references will be executed at command time and the return value will be interpolated into the command before execution. The default implementation returns an empty hash reference, and you are expected to override the method to create your own helpers. For use with commands specified in and L<alienfile> or in your C<Build.Pl> when used with L<Alien::Base::ModuleBuild>. Helpers allow users of your Alien module to use platform or environment determined logic to compute command names or arguments in your installer logic. Helpers allow you to do this without making your Alien module a requirement when a build from source code is not necessary. As a concrete example, consider L<Alien::gmake>, which provides the helper C<gmake>: package Alien::gmake; ... sub alien_helper { my($class) = @_; return { gmake => sub { # return the executable name for GNU make, # usually either make or gmake depending on # the platform and environment $class->exe; } }, } Now consider L<Alien::nasm>. C<nasm> requires GNU Make to build from source code, but if the system C<nasm> package is installed we don't need it. From the L<alienfile> of C<Alien::nasm>: use alienfile; plugin 'Probe::CommandLine' => ( command => 'nasm', args => ['-v'], match => qr/NASM version/, ); share { ... plugin 'Extract' => 'tar.gz'; plugin 'Build::MSYS'; build [ 'sh configure --prefix=%{alien.install.prefix}', '%{gmake}', '%{gmake} install', ]; }; ... =head2 inline_auto_include my(@headers) = Alien::MyLibrary->inline_auto_include; List of header files to automatically include in inline C and C++ code when using L<Inline::C> or L<Inline::CPP>. This is provided as a public interface primarily so that it can be overridden at run time. This can also be specified in your C<Build.PL> with L<Alien::Base::ModuleBuild> using the C<alien_inline_auto_include> property. =head2 runtime_prop my $hashref = Alien::MyLibrary->runtime_prop; Returns a hash reference of the runtime properties computed by L<Alien::Build> during its install process. If the L<Alien::Base> based L<Alien> was not built using L<Alien::Build>, then this will return undef. =head2 alt my $new_alien = Alien::MyLibrary->alt($alt_name); my $new_alien = $old_alien->alt($alt_name); Returns an L<Alien::Base> instance with the alternate configuration. Some packages come with multiple libraries, and multiple C<.pc> files to use with them. This method can be used with C<pkg-config> plugins to access different configurations. (It could also be used with non-pkg-config based packages too, though there are not as of this writing any build time plugins that take advantage of this feature). From your L<alienfile> use alienfile; plugin 'PkgConfig' => ( pkg_name => [ 'libfoo', 'libbar', ], ); Then in your base class: package Alien::MyLibrary; use parent qw( Alien::Base ); use Role::Tiny::With qw( with ); with 'Alien::Role::Alt'; 1; Then you can use it: use Alien::MyLibrary; my $cflags = Alien::MyLibrary->alt('foo1')->cflags; my $libs = Alien::MyLibrary->alt('foo1')->libs; =head2 alt_names my @alt_names = Alien::MyLibrary->alt_names Returns the list of all available alternative configuration names. =head2 alt_exists my $bool = Alien::MyLibrary->alt_exists($alt_name) Returns true if the given alternative configuration exists. =head1 SUPPORT AND CONTRIBUTING First check the L<Alien::Build::Manual::FAQ> for questions that have already been answered. IRC: #native on irc.perl.org L<(click for instant chatroom login)|http://chat.mibbit.com/#native@irc.perl.org> If you find a bug, please report it on the projects issue tracker on GitHub: =over 4 =item L<https://github.com/PerlAlien/Alien-Base/issues> =back Development is discussed on the projects google groups. This is also a reasonable place to post a question if you don't want to open an issue in GitHub. =over 4 =item L<https://groups.google.com/forum/#!forum/perl5-alien> =back If you have implemented a new feature or fixed a bug, please open a pull request. =over 4 =item L<https://github.com/PerlAlien/Alien-Base/pulls> =back =head1 SEE ALSO =over =item * L<Alien::Build> =item * L<alienfile> =item * L<Alien> =item * L<Alien::Build::Manual::FAQ> =back =head1 THANKS C<Alien::Base> was originally written by Joel Berger, and that code is still Copyright (C) 2012-2017 Joel Berger. It has the same license as the rest of the L<Alien::Build>. Special thanks for the early development of C<Alien::Base> go to: =over =item Christian Walde (Mithaldu) For productive conversations about component interoperability. =item kmx For writing Alien::Tidyp from which I drew many of my initial ideas. =item David Mertens (run4flat) For productive conversations about implementation. =item Mark Nunberg (mordy, mnunberg) For graciously teaching me about rpath and dynamic loading, =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ __POD__ perl5/Alien/Base/PkgConfig.pm 0000444 00000011426 14711220271 0011701 0 ustar 00 package Alien::Base::PkgConfig; use strict; use warnings; use 5.008004; use Carp; use Config; use Path::Tiny qw( path ); use Capture::Tiny qw( capture_stderr ); # ABSTRACT: Private legacy pkg-config class for Alien::Base our $VERSION = '2.41'; # VERSION sub new { my $class = shift; # allow creation of an object from a full spec. if (ref $_[0] eq 'HASH') { return bless $_[0], $class; } my ($path) = @_; croak "Must specify a file" unless defined $path; $path = path( $path )->absolute; my($name) = $path->basename =~ /^(.*)\.pc$/; my $self = { package => $name, vars => { pcfiledir => $path->parent->stringify }, keywords => {}, }; bless $self, $class; $self->read($path); return $self; } sub read { my $self = shift; my ($path) = @_; open my $fh, '<', $path or croak "Cannot open .pc file $path: $!"; while (my $line = <$fh>) { if ($line =~ /^([^=:]+?)=([^\n\r]*)/) { $self->{vars}{$1} = $2; } elsif ($line =~ /^([^=:]+?):\s*([^\n\r]*)/) { $self->{keywords}{$1} = $2; } } } # getter/setter for vars sub var { my $self = shift; my ($var, $newval) = @_; if (defined $newval) { $self->{vars}{$var} = $newval; } return $self->{vars}{$var}; } # abstract keywords and other vars in terms of "pure" vars sub make_abstract { my $self = shift; die "make_abstract needs a key (and possibly a value)" unless @_; my ($var, $value) = @_; $value = defined $value ? $value : $self->{vars}{$var}; # convert other vars foreach my $key (keys %{ $self->{vars} }) { next if $key eq $var; # don't overwrite the current var $self->{vars}{$key} =~ s/\Q$value\E/\$\{$var\}/g; } # convert keywords foreach my $key (keys %{ $self->{keywords} }) { $self->{keywords}{$key} =~ s/\Q$value\E/\$\{$var\}/g; } } sub _interpolate_vars { my $self = shift; my ($string, $override) = @_; $override ||= {}; foreach my $key (keys %$override) { carp "Overriden pkg-config variable $key, contains no data" unless $override->{$key}; } if (defined $string) { 1 while $string =~ s/\$\{(.*?)\}/$override->{$1} || $self->{vars}{$1}/e; } return $string; } sub keyword { my $self = shift; my ($keyword, $override) = @_; { no warnings 'uninitialized'; croak "overrides passed to 'keyword' must be a hashref" if defined $override and ref $override ne 'HASH'; } return $self->_interpolate_vars( $self->{keywords}{$keyword}, $override ); } my $pkg_config_command; sub pkg_config_command { unless (defined $pkg_config_command) { capture_stderr { # For now we prefer PkgConfig.pm over pkg-config on # Solaris 64 bit Perls. We may need to do this on # other platforms, in which case this logic should # be abstracted so that it can be shared here and # in Build.PL if (`pkg-config --version` && $? == 0 && !($^O eq 'solaris' && $Config{ptrsize} == 8)) { $pkg_config_command = 'pkg-config'; } else { require PkgConfig; $pkg_config_command = "$^X $INC{'PkgConfig.pm'}"; } } } $pkg_config_command; } sub TO_JSON { my($self) = @_; my %hash = %$self; $hash{'__CLASS__'} = ref($self); \%hash; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Base::PkgConfig - Private legacy pkg-config class for Alien::Base =head1 VERSION version 2.41 =head1 DESCRIPTION This class is used internally by L<Alien::Base> and L<Alien::Base::ModuleBuild> to store information from pkg-config about installed Aliens. It is not used internally by the newer L<alienfile> and L<Alien::Build>. It should never be used externally, should not be used for code new inside of C<Alien-Build>. =head1 SEE ALSO =over =item L<Alien::Base> =item L<alienfile> =item L<Alien::Build> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Base/Authoring.pod 0000444 00000003346 14711220272 0012143 0 ustar 00 # ABSTRACT: Authoring an Alien distribution using Alien::Base # PODNAME: Alien::Base::Authoring __END__ =pod =encoding UTF-8 =head1 NAME Alien::Base::Authoring - Authoring an Alien distribution using Alien::Base =head1 VERSION version 2.41 =head1 SYNOPSIS % perldoc Alien::Build::Manual::AlienAuthor % perldoc Alien::Base::ModuleBuild::Authoring =head1 DESCRIPTION This used to document the only way to author an L<Alien> distribution, which was with L<Alien::Base::ModuleBuild>. You should now seriously consider using the newer more reliable method which is via L<Alien::Build> and L<alienfile>. Read all about it in L<Alien::Build::Manual::AlienAuthor> and L<Alien::Base::ModuleBuild::Authoring> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Base/Wrapper.pm 0000444 00000032223 14711220272 0011451 0 ustar 00 package Alien::Base::Wrapper; use strict; use warnings; use 5.006; use Config; use Text::ParseWords qw( shellwords ); # NOTE: Although this module is now distributed with Alien-Build, # it should have NO non-perl-core dependencies for all Perls # 5.6.0-5.30.1 (as of this writing, and any Perl more recent). # You should be able to extract this module from the rest of # Alien-Build and use it by itself. (There is a dzil plugin # for this [AlienBase::Wrapper::Bundle] # ABSTRACT: Compiler and linker wrapper for Alien our $VERSION = '2.41'; # VERSION sub _join { join ' ', map { s/(\s)/\\$1/g; $_ } map { "$_" } @_; ## no critic (ControlStructures::ProhibitMutatingListFunctions) } sub new { my($class, @aliens) = @_; my $export = 1; my $writemakefile = 0; my @cflags_I; my @cflags_other; my @ldflags_L; my @ldflags_l; my @ldflags_other; my %requires = ( 'ExtUtils::MakeMaker' => '6.52', 'Alien::Base::Wrapper' => '1.97', ); foreach my $alien (@aliens) { if($alien eq '!export') { $export = 0; next; } if($alien eq 'WriteMakefile') { $writemakefile = 1; next; } my $version = 0; if($alien =~ s/=(.*)$//) { $version = $1; } $alien = "Alien::$alien" unless $alien =~ /::/; $requires{$alien} = $version; my $alien_pm = $alien . '.pm'; $alien_pm =~ s/::/\//g; require $alien_pm unless eval { $alien->can('cflags') } && eval { $alien->can('libs') }; my $cflags; my $libs; if($alien->install_type eq 'share' && $alien->can('cflags_static')) { $cflags = $alien->cflags_static; $libs = $alien->libs_static; } else { $cflags = $alien->cflags; $libs = $alien->libs; } push @cflags_I, grep /^-I/, shellwords $cflags; push @cflags_other, grep !/^-I/, shellwords $cflags; push @ldflags_L, grep /^-L/, shellwords $libs; push @ldflags_l, grep /^-l/, shellwords $libs; push @ldflags_other, grep !/^-[Ll]/, shellwords $libs; } my @cflags_define = grep /^-D/, @cflags_other; my @cflags_other2 = grep !/^-D/, @cflags_other; my @mm; push @mm, INC => _join @cflags_I if @cflags_I; push @mm, CCFLAGS => _join(@cflags_other2) . " $Config{ccflags}" if @cflags_other2; push @mm, DEFINE => _join(@cflags_define) if @cflags_define; # TODO: handle spaces in -L paths push @mm, LIBS => ["@ldflags_L @ldflags_l"]; my @ldflags = (@ldflags_L, @ldflags_other); push @mm, LDDLFLAGS => _join(@ldflags) . " $Config{lddlflags}" if @ldflags; push @mm, LDFLAGS => _join(@ldflags) . " $Config{ldflags}" if @ldflags; my @mb; push @mb, extra_compiler_flags => _join(@cflags_I, @cflags_other); push @mb, extra_linker_flags => _join(@ldflags_l); if(@ldflags) { push @mb, config => { lddlflags => _join(@ldflags) . " $Config{lddlflags}", ldflags => _join(@ldflags) . " $Config{ldflags}", }, } bless { cflags_I => \@cflags_I, cflags_other => \@cflags_other, ldflags_L => \@ldflags_L, ldflags_l => \@ldflags_l, ldflags_other => \@ldflags_other, mm => \@mm, mb => \@mb, _export => $export, _writemakefile => $writemakefile, requires => \%requires, }, $class; } my $default_abw = __PACKAGE__->new; # for testing only sub _reset { __PACKAGE__->new } sub _myexec { my @command = @_; if($^O eq 'MSWin32') { # To handle weird quoting on MSWin32 # this logic needs to be improved. my $command = "@command"; $command =~ s{"}{\\"}g; system $command; if($? == -1 ) { die "failed to execute: $!\n"; } elsif($? & 127) { die "child died with signal @{[ $? & 128 ]}"; } else { exit($? >> 8); } } else { exec @command; } } sub cc { my @command = ( shellwords($Config{cc}), @{ $default_abw->{cflags_I} }, @{ $default_abw->{cflags_other} }, @ARGV, ); print "@command\n" unless $ENV{ALIEN_BASE_WRAPPER_QUIET}; _myexec @command; } sub ld { my @command = ( shellwords($Config{ld}), @{ $default_abw->{ldflags_L} }, @{ $default_abw->{ldflags_other} }, @ARGV, @{ $default_abw->{ldflags_l} }, ); print "@command\n" unless $ENV{ALIEN_BASE_WRAPPER_QUIET}; _myexec @command; } sub mm_args { my $self = ref $_[0] ? shift : $default_abw; @{ $self->{mm} }; } sub mm_args2 { my $self = shift; $self = $default_abw unless ref $self; my %args = @_; my @mm = @{ $self->{mm} }; while(@mm) { my $key = shift @mm; my $value = shift @mm; if(defined $args{$key}) { if($args{$key} eq 'LIBS') { require Carp; # Todo: support this maybe? Carp::croak("please do not specify your own LIBS key with mm_args2"); } else { $args{$key} = join ' ', $value, $args{$key}; } } else { $args{$key} = $value; } } foreach my $module (keys %{ $self->{requires} }) { $args{CONFIGURE_REQUIRES}->{$module} = $self->{requires}->{$module}; } %args; } sub mb_args { my $self = ref $_[0] ? shift : $default_abw; @{ $self->{mb} }; } sub import { shift; my $abw = $default_abw = __PACKAGE__->new(@_); if($abw->_export) { my $caller = caller; no strict 'refs'; *{"${caller}::cc"} = \&cc; *{"${caller}::ld"} = \&ld; } if($abw->_writemakefile) { my $caller = caller; no strict 'refs'; *{"${caller}::WriteMakefile"} = \&WriteMakefile; } } sub WriteMakefile { my %args = @_; require ExtUtils::MakeMaker; ExtUtils::MakeMaker->VERSION('6.52'); my @aliens; if(my $reqs = delete $args{alien_requires}) { if(ref $reqs eq 'HASH') { @aliens = map { my $module = $_; my $version = $reqs->{$module}; $version ? "$module=$version" : "$module"; } sort keys %$reqs; } elsif(ref $reqs eq 'ARRAY') { @aliens = @$reqs; } else { require Carp; Carp::croak("aliens_require must be either a hash or array reference"); } } else { require Carp; Carp::croak("You are using Alien::Base::Wrapper::WriteMakefile, but didn't specify any alien requirements"); } ExtUtils::MakeMaker::WriteMakefile( Alien::Base::Wrapper->new(@aliens)->mm_args2(%args), ); } sub _export { shift->{_export} } sub _writemakefile { shift->{_writemakefile} } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Base::Wrapper - Compiler and linker wrapper for Alien =head1 VERSION version 2.41 =head1 SYNOPSIS From the command line: % perl -MAlien::Base::Wrapper=Alien::Foo,Alien::Bar -e cc -- -o foo.o -c foo.c % perl -MAlien::Base::Wrapper=Alien::Foo,Alien::Bar -e ld -- -o foo foo.o From Makefile.PL (static): use ExtUtils::MakeMaker; use Alien::Base::Wrapper (); WriteMakefile( Alien::Base::Wrapper->new( 'Alien::Foo', 'Alien::Bar')->mm_args2( 'NAME' => 'Foo::XS', 'VERSION_FROM' => 'lib/Foo/XS.pm', ), ); From Makefile.PL (static with wrapper) use Alien::Base::Wrapper qw( WriteMakefile); WriteMakefile( 'NAME' => 'Foo::XS', 'VERSION_FROM' => 'lib/Foo/XS.pm', 'alien_requires' => { 'Alien::Foo' => 0, 'Alien::Bar' => 0, }, ); From Makefile.PL (dynamic): use Devel::CheckLib qw( check_lib ); use ExtUtils::MakeMaker 6.52; my @mm_args; my @libs; if(check_lib( lib => [ 'foo' ] ) { push @mm_args, LIBS => [ '-lfoo' ]; } else { push @mm_args, CC => '$(FULLPERL) -MAlien::Base::Wrapper=Alien::Foo -e cc --', LD => '$(FULLPERL) -MAlien::Base::Wrapper=Alien::Foo -e ld --', BUILD_REQUIRES => { 'Alien::Foo' => 0, 'Alien::Base::Wrapper' => 0, } ; } WriteMakefile( 'NAME' => 'Foo::XS', 'VERSION_FROM' => 'lib/Foo/XS.pm', 'CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 6.52, }, @mm_args, ); =head1 DESCRIPTION This module acts as a wrapper around one or more L<Alien> modules. It is designed to work with L<Alien::Base> based aliens, but it should work with any L<Alien> which uses the same essential API. In the first example (from the command line), this class acts as a wrapper around the compiler and linker that Perl is configured to use. It takes the normal compiler and linker flags and adds the flags provided by the Aliens specified, and then executes the command. It will print the command to the console so that you can see exactly what is happening. In the second example (from Makefile.PL non-dynamic), this class is used to generate the appropriate L<ExtUtils::MakeMaker> (EUMM) arguments needed to C<WriteMakefile>. In the third example (from Makefile.PL dynamic), we do a quick check to see if the simple linker flag C<-lfoo> will work, if so we use that. If not, we use a wrapper around the compiler and linker that will use the alien flags that are known at build time. The problem that this form attempts to solve is that compiler and linker flags typically need to be determined at I<configure> time, when a distribution is installed, meaning if you are going to use an L<Alien> module then it needs to be a configure prerequisite, even if the library is already installed and easily detected on the operating system. The author of this module believes that the third (from Makefile.PL dynamic) form is somewhat unnecessary. L<Alien> modules based on L<Alien::Base> have a few prerequisites, but they are well maintained and reliable, so while there is a small cost in terms of extra dependencies, the overall reliability thanks to reduced overall complexity. =head1 CONSTRUCTOR =head2 new my $abw = Alien::Base::Wrapper->new(@aliens); Instead of passing the aliens you want to use into this modules import you can create a non-global instance of C<Alien::Base::Wrapper> using the OO interface. =head1 FUNCTIONS =head2 cc % perl -MAlien::Base::Wrapper=Alien::Foo -e cc -- cflags Invoke the C compiler with the appropriate flags from C<Alien::Foo> and what is provided on the command line. =head2 ld % perl -MAlien::Base::Wrapper=Alien::Foo -e ld -- ldflags Invoke the linker with the appropriate flags from C<Alien::Foo> and what is provided on the command line. =head2 mm_args my %args = $abw->mm_args; my %args = Alien::Base::Wrapper->mm_args; Returns arguments that you can pass into C<WriteMakefile> to compile/link against the specified Aliens. Note that this does not set C<CONFIGURE_REQUIRES>. You probably want to use C<mm_args2> below instead for that reason. =head2 mm_args2 my %args = $abw->mm_args2(%args); my %args = Alien::Base::Wrapper->mm_args2(%args); Returns arguments that you can pass into C<WriteMakefile> to compile/link against. It works a little differently from C<mm_args> above in that you can pass in arguments. It also adds the appropriate C<CONFIGURE_REQUIRES> for you so you do not have to do that explicitly. =head2 mb_args my %args = $abw->mb_args; my %args = Alien::Base::Wrapper->mb_args; Returns arguments that you can pass into the constructor to L<Module::Build>. =head2 WriteMakefile use Alien::Base::Wrapper qw( WriteMakefile ); WriteMakefile(%args, alien_requires => %aliens); WriteMakefile(%args, alien_requires => @aliens); This is a thin wrapper around C<WriteMakefile> from L<ExtUtils::MakeMaker>, which adds the given aliens to the configure requirements and sets the appropriate compiler and linker flags. If the aliens are specified as a hash reference, then the keys are the module names and the values are the versions. For a list it is just the name of the aliens. For the list form you can specify a version by appending C<=version> to the name of the Aliens, that is: WriteMakefile( alien_requires => [ 'Alien::libfoo=1.23', 'Alien::libbar=4.56' ], ); The list form is recommended if the ordering of the aliens matter. The aliens are sorted in the hash form to make it consistent, but it may not be the order that you want. =head1 ENVIRONMENT Alien::Base::Wrapper responds to these environment variables: =over 4 =item ALIEN_BASE_WRAPPER_QUIET If set to true, do not print the command before executing =back =head1 SEE ALSO L<Alien::Base>, L<Alien::Base> =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Base/FAQ.pod 0000444 00000003262 14711220273 0010610 0 ustar 00 # ABSTRACT: Frequently asked questions # VERSION # PODNAME: Alien::Base::FAQ __END__ =pod =encoding UTF-8 =head1 NAME Alien::Base::FAQ - Frequently asked questions =head1 VERSION version 2.41 =head1 SYNOPSIS % perldoc Alien::Build::Manual::FAQ % perldoc Alien::Base::ModuleBuild::FAQ =head1 DESCRIPTION This used to answer FAQs regarding the only way to author an L<Alien::Build> distribution, which was with L<Aien::Base::ModuleBuild>. You should now seriously consider using the newer more reliable method which is via L<Alien::Build> and L<alienfile>. =over 4 =item L<Alien::Build::Manual::FAQ> =item L<Alien::Base::ModuleBuild::FAQ> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Build.pm 0000444 00000147341 14711220273 0010227 0 ustar 00 package Alien::Build; use strict; use warnings; use 5.008004; use Path::Tiny (); use Carp (); use File::chdir; use JSON::PP (); use Env qw( @PATH @PKG_CONFIG_PATH ); use Config (); use Alien::Build::Log; # ABSTRACT: Build external dependencies for use in CPAN our $VERSION = '2.41'; # VERSION sub _path { goto \&Path::Tiny::path } sub new { my($class, %args) = @_; my $self = bless { install_prop => { root => _path($args{root} || "_alien")->absolute->stringify, patch => (defined $args{patch}) ? _path($args{patch})->absolute->stringify : undef, }, runtime_prop => { alien_build_version => $Alien::Build::VERSION || 'dev', }, plugin_instance_prop => {}, bin_dir => [], pkg_config_path => [], aclocal_path => [], }, $class; $self->meta->filename( $args{filename} || do { my(undef, $filename) = caller; _path($filename)->absolute->stringify; } ); if($args{meta_prop}) { $self->meta->prop->{$_} = $args{meta_prop}->{$_} for keys %{ $args{meta_prop} }; } $self; } my $count = 0; sub load { my(undef, $alienfile, @args) = @_; my $rcfile = Path::Tiny->new($ENV{ALIEN_BUILD_RC} || '~/.alienbuild/rc.pl')->absolute; if(-r $rcfile) { require Alien::Build::rc; package Alien::Build::rc; require $rcfile; } unless(-r $alienfile) { Carp::croak "Unable to read alienfile: $alienfile"; } my $file = _path $alienfile; my $name = $file->parent->basename; $name =~ s/^alien-//i; $name =~ s/[^a-z]//g; $name = 'x' if $name eq ''; $name = ucfirst $name; my $class = "Alien::Build::Auto::$name@{[ $count++ ]}"; { no strict 'refs'; @{ "${class}::ISA" } = ('Alien::Build'); *{ "${class}::Alienfile::meta" } = sub { $class =~ s{::Alienfile$}{}; $class->meta; }}; my @preload = qw( Core::Setup Core::Download Core::FFI Core::Override Core::CleanInstall ); push @preload, @Alien::Build::rc::PRELOAD; push @preload, split /;/, $ENV{ALIEN_BUILD_PRELOAD} if defined $ENV{ALIEN_BUILD_PRELOAD}; my @postload = qw( Core::Legacy Core::Gather Core::Tail ); push @postload, @Alien::Build::rc::POSTLOAD; push @postload, split /;/, $ENV{ALIEN_BUILD_POSTLOAD} if defined $ENV{ALIEN_BUILD_POSTLOAD}; my $self = $class->new( filename => $file->absolute->stringify, @args, ); require alienfile; foreach my $preload (@preload) { ref $preload eq 'CODE' ? $preload->($self->meta) : $self->meta->apply_plugin($preload); } # TODO: do this without a string eval ? ## no critic eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{ package ${class}::Alienfile; do '@{[ $file->absolute->stringify ]}'; die \$\@ if \$\@; }; die $@ if $@; ## use critic foreach my $postload (@postload) { ref $postload eq 'CODE' ? $postload->($self->meta) : $self->meta->apply_plugin($postload); } $self->{args} = \@args; unless(defined $self->meta->prop->{arch}) { $self->meta->prop->{arch} = 1; } unless(defined $self->meta->prop->{network}) { $self->meta->prop->{network} = 1; ## https://github.com/PerlAlien/Alien-Build/issues/23#issuecomment-341114414 #$self->meta->prop->{network} = 0 if $ENV{NO_NETWORK_TESTING}; $self->meta->prop->{network} = 0 if (defined $ENV{ALIEN_INSTALL_NETWORK}) && ! $ENV{ALIEN_INSTALL_NETWORK}; } unless(defined $self->meta->prop->{local_source}) { if(! defined $self->meta->prop->{start_url}) { $self->meta->prop->{local_source} = 0; } # we assume URL schemes are at least two characters, that # way Windows absolute paths can be used as local start_url elsif($self->meta->prop->{start_url} =~ /^([a-z]{2,}):/i) { my $scheme = $1; $self->meta->prop->{local_source} = $scheme eq 'file'; } else { $self->meta->prop->{local_source} = 1; } } return $self; } sub resume { my(undef, $alienfile, $root) = @_; my $h = JSON::PP::decode_json(_path("$root/state.json")->slurp); my $self = Alien::Build->load("$alienfile", @{ $h->{args} }); $self->{install_prop} = $h->{install}; $self->{plugin_instance_prop} = $h->{plugin_instance}; $self->{runtime_prop} = $h->{runtime}; $self; } sub meta_prop { my($class) = @_; $class->meta->prop; } sub install_prop { shift->{install_prop}; } sub plugin_instance_prop { my($self, $plugin) = @_; my $instance_id = $plugin->instance_id; $self->{plugin_instance_prop}->{$instance_id} ||= {}; } sub runtime_prop { shift->{runtime_prop}; } sub hook_prop { shift->{hook_prop}; } sub _command_prop { my($self) = @_; return { alien => { install => $self->install_prop, runtime => $self->runtime_prop, hook => $self->hook_prop, meta => $self->meta_prop, }, perl => { config => \%Config::Config, }, env => \%ENV, }; } sub checkpoint { my($self) = @_; my $root = $self->root; _path("$root/state.json")->spew( JSON::PP->new->pretty->canonical(1)->ascii->encode({ install => $self->install_prop, runtime => $self->runtime_prop, plugin_instance => $self->{plugin_instance_prop}, args => $self->{args}, }) ); $self; } sub root { my($self) = @_; my $root = $self->install_prop->{root}; _path($root)->mkpath unless -d $root; $root; } sub install_type { my($self) = @_; $self->{runtime_prop}->{install_type} ||= $self->probe; } sub set_prefix { my($self, $prefix) = @_; if($self->meta_prop->{destdir}) { $self->runtime_prop->{prefix} = $self->install_prop->{prefix} = $prefix; } else { $self->runtime_prop->{prefix} = $prefix; $self->install_prop->{prefix} = $self->install_prop->{stage}; } } sub set_stage { my($self, $dir) = @_; $self->install_prop->{stage} = $dir; } sub _merge { my %h; while(@_) { my $mod = shift; my $ver = shift; if((!defined $h{$mod}) || $ver > $h{$mod}) { $h{$mod} = $ver } } \%h; } sub requires { my($self, $phase) = @_; $phase ||= 'any'; my $meta = $self->meta; $phase =~ /^(?:any|configure)$/ ? $meta->{require}->{$phase} || {} : _merge %{ $meta->{require}->{any} }, %{ $meta->{require}->{$phase} }; } sub load_requires { my($self, $phase, $eval) = @_; my $reqs = $self->requires($phase); foreach my $mod (keys %$reqs) { my $ver = $reqs->{$mod}; my $check = sub { my $pm = "$mod.pm"; $pm =~ s{::}{/}g; require $pm; }; if($eval) { eval { $check->() }; die "Required $mod @{[ $ver || 'undef' ]}, missing" if $@; } else { $check->(); } # note Test::Alien::Build#alienfile_skip_if_missing_prereqs does a regex # on this diagnostic, so if you change it here, change it there too. die "Required $mod $ver, have @{[ $mod->VERSION || 0 ]}" if $ver && ! $mod->VERSION($ver); # allow for requires on Alien::Build or Alien::Base next if $mod eq 'Alien::Build'; next if $mod eq 'Alien::Base'; if($mod->can('bin_dir')) { push @{ $self->{bin_dir} }, $mod->bin_dir; } if(($mod->can('runtime_prop') && $mod->runtime_prop) || ($mod->isa('Alien::Base') && $mod->install_type('share'))) { for my $dir (qw(lib share)) { my $path = _path($mod->dist_dir)->child("$dir/pkgconfig"); if(-d $path) { push @{ $self->{pkg_config_path} }, $path->stringify; } } my $path = _path($mod->dist_dir)->child('share/aclocal'); if(-d $path) { $path = "$path"; if($^O eq 'MSWin32') { # convert to MSYS path $path =~ s{^([a-z]):}{/$1/}i; } push @{ $self->{aclocal_path} }, $path; } } # sufficiently new Autotools have a aclocal_dir which will # give us the directories we need. if($mod eq 'Alien::Autotools' && $mod->can('aclocal_dir')) { push @{ $self->{aclocal_path} }, $mod->aclocal_dir; } if($mod->can('alien_helper')) { my $helpers = $mod->alien_helper; foreach my $name (sort keys %$helpers) { my $code = $helpers->{$name}; $self->meta->interpolator->replace_helper($name => $code); } } } 1; } sub _call_hook { my $self = shift; local $ENV{PATH} = $ENV{PATH}; unshift @PATH, @{ $self->{bin_dir} }; local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH}; unshift @PKG_CONFIG_PATH, @{ $self->{pkg_config_path} }; local $ENV{ACLOCAL_PATH} = $ENV{ACLOCAL_PATH}; # autoconf uses MSYS paths, even for the ACLOCAL_PATH environment variable, so we can't use Env for this. { my @path; @path = split /:/, $ENV{ACLOCAL_PATH} if defined $ENV{ACLOCAL_PATH}; unshift @path, @{ $self->{aclocal_path} }; $ENV{ACLOCAL_PATH} = join ':', @path; } my $config = ref($_[0]) eq 'HASH' ? shift : {}; my($name, @args) = @_; local $self->{hook_prop} = {}; $self->meta->call_hook( $config, $name => $self, @args ); } sub probe { my($self) = @_; local $CWD = $self->root; my $dir; my $env = $self->_call_hook('override'); my $type; my $error; $env = '' if $env eq 'default'; if($env eq 'share') { $type = 'share'; } else { $type = eval { $self->_call_hook( { before => sub { $dir = Alien::Build::TempDir->new($self, "probe"); $CWD = "$dir"; }, after => sub { $CWD = $self->root; }, ok => 'system', continue => sub { if($_[0] eq 'system') { foreach my $name (qw( probe_class probe_instance_id )) { if(exists $self->hook_prop->{$name} && defined $self->hook_prop->{$name}) { $self->install_prop->{"system_$name"} = $self->hook_prop->{$name}; } } return undef; } else { return 1; } }, }, 'probe', ); }; $error = $@; $type = 'share' unless defined $type; } if($error) { if($env eq 'system') { die $error; } $self->log("error in probe (will do a share install): $@"); $self->log("Don't panic, we will attempt a share build from source if possible."); $self->log("Do not file a bug unless you expected a system install to succeed."); $type = 'share'; } if($env && $env ne $type) { die "requested $env install not available"; } if($type !~ /^(system|share)$/) { Carp::croak "probe hook returned something other than system or share: $type"; } if($type eq 'share' && (!$self->meta_prop->{network}) && (!$self->meta_prop->{local_source})) { $self->log("install type share requested or detected, but network fetch is turned off"); $self->log("see https://metacpan.org/pod/Alien::Build::Manual::FAQ#Network-fetch-is-turned-off"); Carp::croak "network fetch is turned off"; } $self->runtime_prop->{install_type} = $type; $type; } sub download { my($self) = @_; return $self unless $self->install_type eq 'share'; return $self if $self->install_prop->{complete}->{download}; if($self->meta->has_hook('download')) { my $tmp; local $CWD; my $valid = 0; $self->_call_hook( { before => sub { $tmp = Alien::Build::TempDir->new($self, "download"); $CWD = "$tmp"; }, verify => sub { my @list = grep { $_->basename !~ /^\./, } _path('.')->children; my $count = scalar @list; if($count == 0) { die "no files downloaded"; } elsif($count == 1) { my($archive) = $list[0]; if(-d $archive) { $self->log("single dir, assuming directory"); } else { $self->log("single file, assuming archive"); } $self->install_prop->{download} = $archive->absolute->stringify; $self->install_prop->{complete}->{download} = 1; $valid = 1; } else { $self->log("multiple files, assuming directory"); $self->install_prop->{complete}->{download} = 1; $self->install_prop->{download} = _path('.')->absolute->stringify; $valid = 1; } }, after => sub { $CWD = $self->root; }, }, 'download', ); return $self if $valid; } else { # This will call the default download hook # defined in Core::Download since the recipe # does not provide a download hook return $self->_call_hook('download'); } die "download failed"; } sub fetch { my $self = shift; $self->_call_hook( 'fetch' => @_ ); } sub decode { my($self, $res) = @_; $self->_call_hook( decode => $res ); } sub prefer { my($self, $res) = @_; $self->_call_hook( prefer => $res ); } sub extract { my($self, $archive) = @_; $archive ||= $self->install_prop->{download}; unless(defined $archive) { die "tried to call extract before download"; } my $nick_name = 'build'; if($self->meta_prop->{out_of_source}) { $nick_name = 'extract'; my $extract = $self->install_prop->{extract}; return $extract if defined $extract && -d $extract; } my $tmp; local $CWD; my $ret; $self->_call_hook({ before => sub { # called build instead of extract, because this # will be used for the build step, and technically # extract is a substage of build anyway. $tmp = Alien::Build::TempDir->new($self, $nick_name); $CWD = "$tmp"; }, verify => sub { my $path = '.'; if($self->meta_prop->{out_of_source} && $self->install_prop->{extract}) { $path = $self->install_prop->{extract}; } my @list = grep { $_->basename !~ /^\./ && $_->basename ne 'pax_global_header' } _path($path)->children; my $count = scalar @list; if($count == 0) { die "no files extracted"; } elsif($count == 1 && -d $list[0]) { $ret = $list[0]->absolute->stringify; } else { $ret = "$tmp"; } }, after => sub { $CWD = $self->root; }, }, 'extract', $archive); $self->install_prop->{extract} ||= $ret; $ret ? $ret : (); } sub build { my($self) = @_; # save the evironment, in case some plugins decide # to alter it. Or us! See just a few lines below. local %ENV = %ENV; my $stage = _path($self->install_prop->{stage}); $stage->mkpath; my $tmp; if($self->install_type eq 'share') { foreach my $suffix ('', '_ffi') { local $CWD; delete $ENV{DESTDIR} unless $self->meta_prop->{destdir}; my %env_meta = %{ $self->meta_prop ->{env} || {} }; my %env_inst = %{ $self->install_prop->{env} || {} }; if($self->meta_prop->{env_interpolate}) { foreach my $key (keys %env_meta) { $env_meta{$key} = $self->meta->interpolator->interpolate($env_meta{$key}); } } %ENV = (%ENV, %env_meta); %ENV = (%ENV, %env_inst); my $destdir; $self->_call_hook( { before => sub { if($self->meta_prop->{out_of_source}) { $self->extract; $CWD = $tmp = Alien::Build::TempDir->new($self, 'build'); } else { $CWD = $tmp = $self->extract; } if($self->meta_prop->{destdir}) { $destdir = Alien::Build::TempDir->new($self, 'destdir'); $ENV{DESTDIR} = "$destdir"; } $self->_call_hook({ all => 1 }, "patch${suffix}"); }, after => sub { $destdir = "$destdir" if $destdir; }, }, "build${suffix}"); $self->install_prop->{"_ab_build@{[ $suffix || '_share' ]}"} = "$CWD"; $self->_call_hook("gather@{[ $suffix || '_share' ]}"); } } elsif($self->install_type eq 'system') { local $CWD = $self->root; my $dir; $self->_call_hook( { before => sub { $dir = Alien::Build::TempDir->new($self, "gather"); $CWD = "$dir"; }, after => sub { $CWD = $self->root; }, }, 'gather_system', ); $self->install_prop->{finished} = 1; $self->install_prop->{complete}->{gather_system} = 1; } $self; } sub test { my($self) = @_; if($self->install_type eq 'share') { foreach my $suffix ('_share', '_ffi') { if($self->meta->has_hook("test$suffix")) { my $dir = $self->install_prop->{"_ab_build$suffix"}; Carp::croak("no build directory to run tests") unless $dir && -d $dir; local $CWD = $dir; $self->_call_hook("test$suffix"); } } } else { if($self->meta->has_hook("test_system")) { my $dir = Alien::Build::TempDir->new($self, "test"); local $CWD = "$dir"; $self->_call_hook("test_system"); } } } sub clean_install { my($self) = @_; if($self->install_type eq 'share') { $self->_call_hook("clean_install"); } } sub system { my($self, $command, @args) = @_; my $prop = $self->_command_prop; ($command, @args) = map { $self->meta->interpolator->interpolate($_, $prop) } ($command, @args); $self->log("+ $command @args"); scalar @args ? system $command, @args : system $command; } sub log { my(undef, $message) = @_; my $caller = [caller]; chomp $message; foreach my $line (split /\n/, $message) { Alien::Build::Log->default->log( caller => $caller, message => $line, ); } } { my %meta; sub meta { my($class) = @_; $class = ref $class if ref $class; $meta{$class} ||= Alien::Build::Meta->new( class => $class ); } } package Alien::Build::Meta; our @CARP_NOT = qw( alienfile ); sub new { my($class, %args) = @_; my $self = bless { phase => 'any', build_suffix => '', require => { any => {}, share => {}, system => {}, }, around => {}, prop => {}, %args, }, $class; $self; } sub prop { shift->{prop}; } sub filename { my($self, $new) = @_; $self->{filename} = $new if defined $new; $self->{filename}; } sub add_requires { my $self = shift; my $phase = shift; while(@_) { my $module = shift; my $version = shift; my $old = $self->{require}->{$phase}->{$module}; if((!defined $old) || $version > $old) { $self->{require}->{$phase}->{$module} = $version } } $self; } sub interpolator { my($self, $new) = @_; if(defined $new) { if(defined $self->{intr}) { Carp::croak "tried to set interpolator twice"; } if(ref $new) { $self->{intr} = $new; } else { $self->{intr} = $new->new; } } elsif(!defined $self->{intr}) { require Alien::Build::Interpolate::Default; $self->{intr} = Alien::Build::Interpolate::Default->new; } $self->{intr}; } sub has_hook { my($self, $name) = @_; defined $self->{hook}->{$name}; } sub _instr { my($self, $name, $instr) = @_; if(ref($instr) eq 'CODE') { return $instr; } elsif(ref($instr) eq 'ARRAY') { my %phase = ( download => 'share', fetch => 'share', decode => 'share', prefer => 'share', extract => 'share', patch => 'share', patch_ffi => 'share', build => 'share', build_ffi => 'share', stage => 'share', gather_ffi => 'share', gather_share => 'share', gather_system => 'system', test_ffi => 'share', test_share => 'share', test_system => 'system', ); require Alien::Build::CommandSequence; my $seq = Alien::Build::CommandSequence->new(@$instr); $seq->apply_requirements($self, $phase{$name} || 'any'); return $seq; } else { Carp::croak "type not supported as a hook"; } } sub register_hook { my($self, $name, $instr) = @_; push @{ $self->{hook}->{$name} }, _instr $self, $name, $instr; $self; } sub default_hook { my($self, $name, $instr) = @_; $self->{default_hook}->{$name} = _instr $self, $name, $instr; $self; } sub around_hook { my($self, $name, $code) = @_; if(my $old = $self->{around}->{$name}) { # this is the craziest shit I have ever # come up with. $self->{around}->{$name} = sub { my $orig = shift; $code->(sub { $old->($orig, @_) }, @_); }; } else { $self->{around}->{$name} = $code; } } sub after_hook { my($self, $name, $code) = @_; $self->around_hook( $name => sub { my $orig = shift; my $ret = $orig->(@_); $code->(@_); $ret; } ); } sub before_hook { my($self, $name, $code) = @_; $self->around_hook( $name => sub { my $orig = shift; $code->(@_); my $ret = $orig->(@_); $ret; } ); } sub call_hook { my $self = shift; my %args = ref $_[0] ? %{ shift() } : (); my($name, @args) = @_; my $error; my @hooks = @{ $self->{hook}->{$name} || []}; if(@hooks == 0) { if(defined $self->{default_hook}->{$name}) { @hooks = ($self->{default_hook}->{$name}) } elsif(!$args{all}) { Carp::croak "No hooks registered for $name"; } } my $value; foreach my $hook (@hooks) { if(eval { $args[0]->isa('Alien::Build') }) { %{ $args[0]->{hook_prop} } = ( name => $name, ); } my $wrapper = $self->{around}->{$name} || sub { my $code = shift; $code->(@_) }; my $value; $args{before}->() if $args{before}; if(ref($hook) eq 'CODE') { $value = eval { my $value = $wrapper->(sub { $hook->(@_) }, @args); $args{verify}->('code') if $args{verify}; $value; }; } else { $value = $wrapper->(sub { eval { $hook->execute(@_); $args{verify}->('command') if $args{verify}; }; defined $args{ok} ? $args{ok} : 1; }, @args); } $error = $@; $args{after}->() if $args{after}; if($args{all}) { die if $error; } else { next if $error; next if $args{continue} && $args{continue}->($value); return $value; } } die $error if $error && ! $args{all}; $value; } sub apply_plugin { my($self, $name, @args) = @_; my $class; my $pm; my $found; if($name =~ /^=(.*)$/) { $class = $1; $pm = "$class.pm"; $pm =~ s!::!/!g; $found = 1; } if($name !~ /::/ && !$found) { foreach my $inc (@INC) { # TODO: allow negotiators to work with @INC hooks next if ref $inc; my $file = Path::Tiny->new("$inc/Alien/Build/Plugin/$name/Negotiate.pm"); if(-r $file) { $class = "Alien::Build::Plugin::${name}::Negotiate"; $pm = "Alien/Build/Plugin/$name/Negotiate.pm"; $found = 1; last; } } } unless($found) { $class = "Alien::Build::Plugin::$name"; $pm = "Alien/Build/Plugin/$name.pm"; $pm =~ s{::}{/}g; } require $pm unless $class->can('new'); my $plugin = $class->new(@args); $plugin->init($self); $self; } package Alien::Build::TempDir; # TODO: it's confusing that there is both a AB::TempDir and AB::Temp # although they do different things. there could maybe be a better # name for AB::TempDir (maybe AB::TempBuildDir, though that is a little # redundant). Happily both are private classes, and either are able to # rename, if a good name can be thought of. use overload '""' => sub { shift->as_string }, bool => sub { 1 }, fallback => 1; use File::Temp qw( tempdir ); sub new { my($class, $build, $name) = @_; my $root = $build->install_prop->{root}; Path::Tiny->new($root)->mkpath unless -d $root; bless { dir => Path::Tiny->new(tempdir( "${name}_XXXX", DIR => $root)), }, $class; } sub as_string { shift->{dir}->stringify; } sub DESTROY { my($self) = @_; if(-d $self->{dir} && $self->{dir}->children == 0) { rmdir($self->{dir}) || warn "unable to remove @{[ $self->{dir} ]} $!"; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Build - Build external dependencies for use in CPAN =head1 VERSION version 2.41 =head1 SYNOPSIS my $build = Alien::Build->load('./alienfile'); $build->load_requires('configure'); $build->set_prefix('/usr/local'); $build->set_stage('/foo/mystage'); # needs to be absolute $build->load_requires($build->install_type); $build->download; $build->build; # files are now in /foo/mystage, it is your job (or # ExtUtils::MakeMaker, Module::Build, etc) to copy # those files into /usr/local =head1 DESCRIPTION This module provides tools for building external (non-CPAN) dependencies for CPAN. It is mainly designed to be used at install time of a CPAN client, and work closely with L<Alien::Base> which is used at runtime. This is the detailed documentation for the L<Alien::Build> class. If you are starting out you probably want to do so from one of these documents: =over 4 =item L<Alien::Build::Manual::Alien> A broad overview of C<Alien-Build> and its ecosystem. =item L<Alien::Build::Manual::AlienUser> For users of an C<Alien::libfoo> that is implemented using L<Alien::Base>. (The developer of C<Alien::libfoo> I<should> provide the documentation necessary, but if not, this is the place to start). =item L<Alien::Build::Manual::AlienAuthor> If you are writing your own L<Alien> based on L<Alien::Build> and L<Alien::Base>. =item L<Alien::Build::Manual::FAQ> If you have a common question that has already been answered, like "How do I use L<alienfile> with some build system". =item L<Alien::Build::Manual::PluginAuthor> This is for the brave souls who want to write plugins that will work with L<Alien::Build> + L<alienfile>. =back Note that you will not usually create a L<Alien::Build> instance directly, but rather be using a thin installer layer, such as L<Alien::Build::MM> (for use with L<ExtUtils::MakeMaker>) or L<Alien::Build::MB> (for use with L<Module::Build>). One of the goals of this project is to remain installer agnostic. =head1 CONSTRUCTORS =head2 new my $build = Alien::Build->new; This creates a new empty instance of L<Alien::Build>. Normally you will want to use C<load> below to create an instance of L<Alien::Build> from an L<alienfile> recipe. =head2 load my $build = Alien::Build->load($alienfile); This creates an L<Alien::Build> instance with the given L<alienfile> recipe. =head2 resume my $build = Alien::Build->resume($alienfile, $root); Load a checkpointed L<Alien::Build> instance. You will need the original L<alienfile> and the build root (usually C<_alien>), and a build that had been properly checkpointed using the C<checkpoint> method below. =head1 PROPERTIES There are three main properties for L<Alien::Build>. There are a number of properties documented here with a specific usage. Note that these properties may need to be serialized into something primitive like JSON that does not support: regular expressions, code references of blessed objects. If you are writing a plugin (L<Alien::Build::Plugin>) you should use a prefix like "plugin_I<name>" (where I<name> is the name of your plugin) so that it does not interfere with other plugin or future versions of L<Alien::Build>. For example, if you were writing C<Alien::Build::Plugin::Fetch::NewProtocol>, please use the prefix C<plugin_fetch_newprotocol>: sub init { my($self, $meta) = @_; $meta->prop( plugin_fetch_newprotocol_foo => 'some value' ); $meta->register_hook( some_hook => sub { my($build) = @_; $build->install_prop->{plugin_fetch_newprotocol_bar} = 'some other value'; $build->runtime_prop->{plugin_fetch_newprotocol_baz} = 'and another value'; } ); } If you are writing a L<alienfile> recipe please use the prefix C<my_>: use alienfile; meta_prop->{my_foo} = 'some value'; probe sub { my($build) = @_; $build->install_prop->{my_bar} = 'some other value'; $build->install_prop->{my_baz} = 'and another value'; }; Any property may be used from a command: probe [ 'some command %{.meta.plugin_fetch_newprotocol_foo}' ]; probe [ 'some command %{.install.plugin_fetch_newprotocol_bar}' ]; probe [ 'some command %{.runtime.plugin_fetch_newprotocol_baz}' ]; probe [ 'some command %{.meta.my_foo}' ]; probe [ 'some command %{.install.my_bar}' ]; probe [ 'some command %{.runtime.my_baz}' ]; =head2 meta_prop my $href = $build->meta_prop; my $href = Alien::Build->meta_prop; Meta properties have to do with the recipe itself, and not any particular instance that probes or builds that recipe. Meta properties can be changed from within an L<alienfile> using the C<meta_prop> directive, or from a plugin from its C<init> method (though should NOT be modified from any hooks registered within that C<init> method). This is not strictly enforced, but if you do not follow this rule your recipe will likely be broken. =over =item arch This is a hint to an installer like L<Alien::Build::MM> or L<Alien::Build::MB>, that the library or tool contains architecture dependent files and so should be stored in an architecture dependent location. If not specified by your L<alienfile> then it will be set to true. =item destdir Use the C<DESTDIR> environment variable to stage your install before copying the files into C<blib>. This is the preferred method of installing libraries because it improves reliability. This technique is supported by C<autoconf> and others. =item destdir_filter Regular expression for the files that should be copied from the C<DESTDIR> into the stage directory. If not defined, then all files will be copied. =item destdir_ffi_filter Same as C<destdir_filter> except applies to C<build_ffi> instead of C<build>. =item env Environment variables to override during the build stage. =item env_interpolate Environment variable values will be interpolated with helpers. Example: meta->prop->{env_interpolate} = 1; meta->prop->{env}->{PERL} = '%{perl}'; =item local_source Set to true if source code package is available locally. (that is not fetched over the internet). This is computed by default based on the C<start_url> property. Can be set by an L<alienfile> or plugin. =item platform Hash reference. Contains information about the platform beyond just C<$^O>. =over 4 =item compiler_type Refers to the type of flags that the compiler accepts. May be expanded in the future, but for now, will be one of: =over 4 =item microsoft On Windows when using Microsoft Visual C++ =item unix Virtually everything else, including gcc on windows. =back The main difference is that with Visual C++ C<-LIBPATH> should be used instead of C<-L>, and static libraries should have the C<.LIB> suffix instead of C<.a>. =item system_type C<$^O> is frequently good enough to make platform specific logic in your L<alienfile>, this handles the case when $^O can cover platforms that provide multiple environments that Perl might run under. The main example is windows, but others may be added in the future. =over 4 =item unix =item vms =item windows-activestate =item windows-microsoft =item windows-mingw =item windows-strawberry =item windows-unknown =back Note that C<cygwin> and C<msys> are considered C<unix> even though they run on windows! =back =item out_of_source Build in a different directory from the where the source code is stored. In autoconf this is referred to as a "VPATH" build. Everyone else calls this an "out-of-source" build. When this property is true, instead of extracting to the source build root, the downloaded source will be extracted to an source extraction directory and the source build root will be empty. You can use the C<extract> install property to get the location of the extracted source. =item network True if a network fetch is available. This should NOT be set by an L<alienfile> or plugin. This is computed based on the C<ALIEN_INSTALL_NETWORK> environment variables. =item start_url The default or start URL used by fetch plugins. =back =head2 install_prop my $href = $build->install_prop; Install properties are used during the install phase (either under C<share> or C<system> install). They are remembered for the entire install phase, but not kept around during the runtime phase. Thus they cannot be accessed from your L<Alien::Base> based module. =over =item autoconf_prefix The prefix as understood by autoconf. This is only different on Windows Where MSYS is used and paths like C<C:/foo> are represented as C</C/foo> which are understood by the MSYS tools, but not by Perl. You should only use this if you are using L<Alien::Build::Plugin::Autoconf> in your L<alienfile>. =item download The location of the downloaded archive (tar.gz, or similar) or directory. =item env Environment variables to override during the build stage. =item extract The location of the last source extraction. For a "out-of-source" build (see the C<out_of_source> meta property above), this will only be set once. For other types of builds, the source code may be extracted multiple times, and thus this property may change. =item old Hash containing information on a previously installed Alien of the same name, if available. This may be useful in cases where you want to reuse the previous install if it is still sufficient. =over 4 =item prefix The prefix for the previous install. Versions prior to 1.42 unfortunately had this in typo form of C<preifx>. =item runtime The runtime properties from the previous install. =back =item patch Directory with patches. =item prefix The install time prefix. Under a C<destdir> install this is the same as the runtime or final install location. Under a non-C<destdir> install this is the C<stage> directory (usually the appropriate share directory under C<blib>). =item root The build root directory. This will be an absolute path. It is the absolute form of C<./_alien> by default. =item stage The stage directory where files will be copied. This is usually the root of the blib share directory. =item system_probe_class After the probe step this property may contain the plugin class that performed the system probe. It shouldn't be filled in directly by the plugin (instead if should use the hook property C<probe_class>, see below). This is optional, and not all probe plugins will provide this information. =item system_probe_instance_id After the probe step this property may contain the plugin instance id that performed the system probe. It shouldn't be filled in directly by the plugin (instead if should use the hook property C<probe_instance_id>, see below). This is optional, and not all probe plugins will provide this information. =back =head2 plugin_instance_prop my $href = $build->plugin_instance_prop($plugin); This returns the private plugin instance properties for a given plugin. This method should usually only be called internally by plugins themselves to keep track of internal state. Because the content can be used arbitrarily by the owning plugin because it is private to the plugin, and thus is not part of the L<Alien::Build> spec. =head2 runtime_prop my $href = $build->runtime_prop; Runtime properties are used during the install and runtime phases (either under C<share> or C<system> install). This should include anything that you will need to know to use the library or tool during runtime, and shouldn't include anything that is no longer relevant once the install process is complete. =over 4 =item alien_build_version The version of L<Alien::Build> used to install the library or tool. =item alt Alternate configurations. If the alienized package has multiple libraries this could be used to store the different compiler or linker flags for each library. =item cflags The compiler flags =item cflags_static The static compiler flags =item command The command name for tools where the name my differ from platform to platform. For example, the GNU version of make is usually C<make> in Linux and C<gmake> on FreeBSD. =item ffi_name The name DLL or shared object "name" to use when searching for dynamic libraries at runtime. This is passed into L<FFI::CheckLib>, so if your library is something like C<libarchive.so> or C<archive.dll> you would set this to C<archive>. This may be a string or an array of strings. =item ffi_checklib This property contains two sub properties: =over 4 =item share $build->runtime_prop->{ffi_checklib}->{share} = [ ... ]; Array of additional L<FFI::CheckLib> flags to pass in to C<find_lib> for a C<share> install. =item system Array of additional L<FFI::CheckLib> flags to pass in to C<find_lib> for a C<system> install. Among other things, useful for specifying the C<try_linker_script> flag: $build->runtime_prop->{ffi_checklib}->{system} = [ try_linker_script => 1 ]; =back =item install_type The install type. Is one of: =over 4 =item system For when the library or tool is provided by the operating system, can be detected by L<Alien::Build>, and is considered satisfactory by the C<alienfile> recipe. =item share For when a system install is not possible, the library source will be downloaded from the internet or retrieved in another appropriate fashion and built. =back =item libs The library flags =item libs_static The static library flags =item perl_module_version The version of the Perl module used to install the alien (if available). For example if L<Alien::curl> is installing C<libcurl> this would be the version of L<Alien::curl> used during the install step. =item prefix The final install root. This is usually they share directory. =item version The version of the library or tool =back =head2 hook_prop my $href = $build->hook_prop; Hook properties are for the currently running (if any) hook. They are used only during the execution of each hook and are discarded after. If no hook is currently running then C<hook_prop> will return C<undef>. =over 4 =item name The name of the currently running hook. =item version (probe) Probe and PkgConfig plugins I<may> set this property indicating the version of the alienized package. Not all plugins and configurations may be able to provide this. =item probe_class (probe) Probe and PkgConfig plugins I<may> set this property indicating the plugin class that made the probe. If the probe results in a system install this will be propagated to C<system_probe_class> for later use. =item probe_instance_id (probe) Probe and PkgConfig plugins I<may> set this property indicating the plugin instance id that made the probe. If the probe results in a system install this will be propagated to C<system_probe_instance_id> for later use. =back =head1 METHODS =head2 checkpoint $build->checkpoint; Save any install or runtime properties so that they can be reloaded on a subsequent run in a separate process. This is useful if your build needs to be done in multiple stages from a C<Makefile>, such as with L<ExtUtils::MakeMaker>. Once checkpointed you can use the C<resume> constructor (documented above) to resume the probe/build/install] process. =head2 root my $dir = $build->root; This is just a shortcut for: my $root = $build->install_prop->{root}; Except that it will be created if it does not already exist. =head2 install_type my $type = $build->install_type; This will return the install type. (See the like named install property above for details). This method will call C<probe> if it has not already been called. =head2 set_prefix $build->set_prefix($prefix); Set the final (unstaged) prefix. This is normally only called by L<Alien::Build::MM> and similar modules. It is not intended for use from plugins or from an L<alienfile>. =head2 set_stage $build->set_stage($dir); Sets the stage directory. This is normally only called by L<Alien::Build::MM> and similar modules. It is not intended for use from plugins or from an L<alienfile>. =head2 requires my $hash = $build->requires($phase); Returns a hash reference of the modules required for the given phase. Phases include: =over 4 =item configure These modules must already be available when the L<alienfile> is read. =item any These modules are used during either a C<system> or C<share> install. =item share These modules are used during the build phase of a C<share> install. =item system These modules are used during the build phase of a C<system> install. =back =head2 load_requires $build->load_requires($phase); This loads the appropriate modules for the given phase (see C<requires> above for a description of the phases). =head2 probe my $install_type = $build->probe; Attempts to determine if the operating system has the library or tool already installed. If so, then the string C<system> will be returned and a system install will be performed. If not, then the string C<share> will be installed and the tool or library will be downloaded and built from source. If the environment variable C<ALIEN_INSTALL_TYPE> is set, then that will force a specific type of install. If the detection logic cannot accommodate the install type requested then it will fail with an exception. =head2 download $build->download; Download the source, usually as a tarball, usually from the internet. Under a C<system> install this does not do anything. =head2 fetch my $res = $build->fetch; my $res = $build->fetch($url, %options); Fetch a resource using the fetch hook. Returns the same hash structure described below in the hook documentation. [version 2.39] As of L<Alien::Build> 2.39, these options are supported: =over 4 =item http_headers my $res = $build->fetch($url, http_headers => [ $key1 => $value1, $key2 => $value 2, ... ]); Set the HTTP request headers on all outgoing HTTP requests. Note that not all protocols or fetch plugins support setting request headers, but the ones that do not I<should> issue a warning if you try to set request headers and they are not supported. =back =head2 decode my $decoded_res = $build->decode($res); Decode the HTML or file listing returned by C<fetch>. Returns the same hash structure described below in the hook documentation. =head2 prefer my $sorted_res = $build->prefer($res); Filter and sort candidates. The preferred candidate will be returned first in the list. The worst candidate will be returned last. Returns the same hash structure described below in the hook documentation. =head2 extract my $dir = $build->extract; my $dir = $build->extract($archive); Extracts the given archive into a fresh directory. This is normally called internally to L<Alien::Build>, and for normal usage is not needed from a plugin or L<alienfile>. =head2 build $build->build; Run the build step. It is expected that C<probe> and C<download> have already been performed. What it actually does depends on the type of install: =over 4 =item share The source is extracted, and built as determined by the L<alienfile> recipe. If there is a C<gather_share> that will be executed last. =item system The C<gather_system> hook will be executed. =back =head2 test $build->test; Run the test phase =head2 clean_install $build->clean_install Clean files from the final install location. The default implementation removes all files recursively except for the C<_alien> directory. This is helpful when you have an old install with files that may break the new build. For a non-share install this doesn't do anything. =head2 system $build->system($command); $build->system($command, @args); Interpolates the command and arguments and run the results using the Perl C<system> command. =head2 log $build->log($message); Send a message to the log. By default this prints to C<STDOUT>. =head2 meta my $meta = Alien::Build->meta; my $meta = $build->meta; Returns the meta object for your L<Alien::Build> class or instance. The meta object is a way to manipulate the recipe, and so any changes to the meta object should be made before the C<probe>, C<download> or C<build> steps. =head1 META METHODS =head2 prop my $href = $build->meta->prop; Meta properties. This is the same as calling C<meta_prop> on the class or L<Alien::Build> instance. =head2 add_requires Alien::Build->meta->add_requires($phase, $module => $version, ...); Add the requirement to the given phase. Phase should be one of: =over 4 =item configure =item any =item share =item system =back =head2 interpolator my $interpolator = $build->meta->interpolator; my $interpolator = Alien::Build->interpolator; Returns the L<Alien::Build::Interpolate> instance for the L<Alien::Build> class. =head2 has_hook my $bool = $build->meta->has_hook($name); my $bool = Alien::Build->has_hook($name); Returns if there is a usable hook registered with the given name. =head2 register_hook $build->meta->register_hook($name, $instructions); Alien::Build->meta->register_hook($name, $instructions); Register a hook with the given name. C<$instruction> should be either a code reference, or a command sequence, which is an array reference. =head2 default_hook $build->meta->default_hook($name, $instructions); Alien::Build->meta->default_hook($name, $instructions); Register a default hook, which will be used if the L<alienfile> does not register its own hook with that name. =head2 around_hook $build->meta->around_hook($hook, $code); Alien::Build->meta->around_hook($name, $code); Wrap the given hook with a code reference. This is similar to a L<Moose> method modifier, except that it wraps around the given hook instead of a method. For example, this will add a probe system requirement: $build->meta->around_hook( probe => sub { my $orig = shift; my $build = shift; my $type = $orig->($build, @_); return $type unless $type eq 'system'; # also require a configuration file if(-f '/etc/foo.conf') { return 'system'; } else { return 'share'; } }, ); =head2 apply_plugin Alien::Build->meta->apply_plugin($name); Alien::Build->meta->apply_plugin($name, @args); Apply the given plugin with the given arguments. =head1 ENVIRONMENT L<Alien::Build> responds to these environment variables: =over 4 =item ALIEN_INSTALL_NETWORK If set to true (the default), then network fetch will be allowed. If set to false, then network fetch will not be allowed. What constitutes a local vs. network fetch is determined based on the C<start_url> and C<local_source> meta properties. An L<alienfile> or plugin C<could> override this detection (possibly inappropriately), so this variable is not a substitute for properly auditing of Perl modules for environments that require that. =item ALIEN_INSTALL_TYPE If set to C<share> or C<system>, it will override the system detection logic. If set to C<default>, it will use the default setting for the L<alienfile>. The behavior of other values is undefined. Although the recommended way for a consumer to use an L<Alien::Base> based L<Alien> is to declare it as a static configure and build-time dependency, some consumers may prefer to fallback on using an L<Alien> only when the consumer itself cannot detect the necessary package. In some cases the consumer may want the user to opt-in to using an L<Alien> before requiring it. To keep the interface consistent among Aliens, the consumer of the fallback opt-in L<Alien> may fallback on the L<Alien> if the environment variable C<ALIEN_INSTALL_TYPE> is set to any value. The rationale is that by setting this environment variable the user is aware that L<Alien> modules may be installed and have indicated consent. The actual implementation of this, by its nature would have to be in the consuming CPAN module. =item ALIEN_BUILD_LOG The default log class used. See L<Alien::Build::Log> and L<Alien::Build::Log::Default>. =item ALIEN_BUILD_RC Perl source file which can override some global defaults for L<Alien::Build>, by, for example, setting preload and postload plugins. =item ALIEN_BUILD_PKG_CONFIG Override the logic in L<Alien::Build::Plugin::PkgConfig::Negotiate> which chooses the best C<pkg-config> plugin. =item ALIEN_BUILD_PRELOAD semicolon separated list of plugins to automatically load before parsing your L<alienfile>. =item ALIEN_BUILD_POSTLOAD semicolon separated list of plugins to automatically load after parsing your L<alienfile>. =item DESTDIR This environment variable will be manipulated during a destdir install. =item PKG_CONFIG This environment variable can be used to override the program name for C<pkg-config> when using the command line plugin: L<Alien::Build::Plugin::PkgConfig::CommandLine>. =item ftp_proxy, all_proxy If these environment variables are set, it may influence the Download negotiation plugin L<Alien::Build::Plugin::Downaload::Negotiate>. Other proxy variables may be used by some Fetch plugins, if they support it. =back =head1 SUPPORT The intent of the C<Alien-Build> team is to support as best as possible all Perls from 5.8.4 to the latest production version. So long as they are also supported by the Perl toolchain. Please feel encouraged to report issues that you encounter to the project GitHub Issue tracker: =over 4 =item L<https://github.com/PerlAlien/Alien-Build/issues> =back Better if you can fix the issue yourself, please feel encouraged to open pull-request on the project GitHub: =over 4 =item L<https://github.com/PerlAlien/Alien-Build/pulls> =back If you are confounded and have questions, join us on the C<#native> channel on irc.perl.org. The C<Alien-Build> developers frequent this channel and can probably help point you in the right direction. If you don't have an IRC client handy, you can use this web interface: =over 4 =item L<https://chat.mibbit.com/?channel=%23native&server=irc.perl.org> =back =head1 SEE ALSO L<Alien::Build::Manual::AlienAuthor>, L<Alien::Build::Manual::AlienUser>, L<Alien::Build::Manual::Contributing>, L<Alien::Build::Manual::FAQ>, L<Alien::Build::Manual::PluginAuthor> L<alienfile>, L<Alien::Build::MM>, L<Alien::Build::Plugin>, L<Alien::Base>, L<Alien> =head1 THANKS L<Alien::Base> was originally written by Joel Berger, the rest of this project would not have been possible without him getting the project started. Thanks to his support I have been able to augment the original L<Alien::Base> system with a reliable set of tools (L<Alien::Build>, L<alienfile>, L<Test::Alien>), which make up this toolset. The original L<Alien::Base> is still copyright (c) 2012-2020 Joel Berger. It has the same license as the rest of the Alien::Build and related tools distributed as C<Alien-Build>. Joel Berger thanked a number of people who helped in in the development of L<Alien::Base>, in the documentation for that module. I would also like to acknowledge the other members of the PerlAlien github organization, Zakariyya Mughal (sivoais, ZMUGHAL) and mohawk (ETJ). Also important in the early development of L<Alien::Build> were the early adopters Chase Whitener (genio, CAPOEIRAB, author of L<Alien::libuv>), William N. Braswell, Jr (willthechill, WBRASWELL, author of L<Alien::JPCRE2> and L<Alien::PCRE2>) and Ahmad Fatoum (a3f, ATHREEF, author of L<Alien::libudev> and L<Alien::LibUSB>). The Alien ecosystem owes a debt to Dan Book, who goes by Grinnz on IRC, for answering question about how to use L<Alien::Build> and friends. =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Alien/Role.pm 0000444 00000004511 14711220300 0010047 0 ustar 00 package Alien::Role; use strict; use warnings; use 5.008004; # ABSTRACT: Extend Alien::Base with roles! our $VERSION = '2.41'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Role - Extend Alien::Base with roles! =head1 VERSION version 2.41 =head1 SYNOPSIS package Alien::libfoo; use parent qw( Alien::Base ); use Role::Tiny::With qw( with ); with 'Alien::Role::Dino'; with 'Alien::Role::Alt'; 1; =head1 DESCRIPTION The C<Alien::Role> namespace is intended for writing roles that can be applied to L<Alien::Base> to extend its functionality. You could of course write subclasses that extend L<Alien::Base>, but then you have to either stick with just one subclass or deal with multiple inheritance! It is recommended that you use L<Role::Tiny> since it can be used on plain old Perl classes which is good since L<Alien::Base> doesn't use anything fancy like L<Moose> or L<Moo>. There are two working examples that use this technique that are worth checking out in the event you are interested: L<Alien::Role::Dino> and L<Alien::Role::Alt>. This class itself doesn't do anything, it just documents the technique. =head1 SEE ALSO =over 4 =item L<Alien> =item L<Alien::Base> =item L<alienfile> =item L<Alien::Build> =item L<Alien::Role::Dino> =item L<Alien::Role::Alt> =back =head1 AUTHOR Author: Graham Ollis E<lt>plicease@cpan.orgE<gt> Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) Håkon Hægland (hakonhagland, HAKONH) nick nauwelaerts (INPHOBIA) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 by Graham Ollis. 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 perl5/Test2.pm 0000444 00000014371 14711220300 0007124 0 ustar 00 package Test2; use strict; use warnings; our $VERSION = '1.302186'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2 - Framework for writing test tools that all work together. =head1 DESCRIPTION Test2 is a new testing framework produced by forking L<Test::Builder>, completely refactoring it, adding many new features and capabilities. =head2 WHAT IS NEW? =over 4 =item Easier to test new testing tools. From the beginning Test2 was built with introspection capabilities. With Test::Builder it was difficult at best to capture test tool output for verification. Test2 Makes it easy with C<Test2::API::intercept()>. =item Better diagnostics capabilities. Test2 uses an L<Test2::API::Context> object to track filename, line number, and tool details. This object greatly simplifies tracking for where errors should be reported. =item Event driven. Test2 based tools produce events which get passed through a processing system before being output by a formatter. This event system allows for rich plugin and extension support. =item More complete API. Test::Builder only provided a handful of methods for generating lines of TAP. Test2 took inventory of everything people were doing with Test::Builder that required hacking it up. Test2 made public API functions for nearly all the desired functionality people didn't previously have. =item Support for output other than TAP. Test::Builder assumed everything would end up as TAP. Test2 makes no such assumption. Test2 provides ways for you to specify alternative and custom formatters. =item Subtest implementation is more sane. The Test::Builder implementation of subtests was certifiably insane. Test2 uses a stacked event hub system that greatly improves how subtests are implemented. =item Support for threading/forking. Test2 support for forking and threading can be turned on using L<Test2::IPC>. Once turned on threading and forking operate sanely and work as one would expect. =back =head1 GETTING STARTED If you are interested in writing tests using new tools then you should look at L<Test2::Suite>. L<Test2::Suite> is a separate cpan distribution that contains many tools implemented on Test2. If you are interested in writing new tools you should take a look at L<Test2::API> first. =head1 NAMESPACE LAYOUT This describes the namespace layout for the Test2 ecosystem. Not all the namespaces listed here are part of the Test2 distribution, some are implemented in L<Test2::Suite>. =head2 Test2::Tools:: This namespace is for sets of tools. Modules in this namespace should export tools like C<ok()> and C<is()>. Most things written for Test2 should go here. Modules in this namespace B<MUST NOT> export subs from other tools. See the L</Test2::Bundle::> namespace if you want to do that. =head2 Test2::Plugin:: This namespace is for plugins. Plugins are modules that change or enhance the behavior of Test2. An example of a plugin is a module that sets the encoding to utf8 globally. Another example is a module that causes a bail-out event after the first test failure. =head2 Test2::Bundle:: This namespace is for bundles of tools and plugins. Loading one of these may load multiple tools and plugins. Modules in this namespace should not implement tools directly. In general modules in this namespace should load tools and plugins, then re-export things into the consumers namespace. =head2 Test2::Require:: This namespace is for modules that cause a test to be skipped when conditions do not allow it to run. Examples would be modules that skip the test on older perls, or when non-essential modules have not been installed. =head2 Test2::Formatter:: Formatters live under this namespace. L<Test2::Formatter::TAP> is the only formatter currently. It is acceptable for third party distributions to create new formatters under this namespace. =head2 Test2::Event:: Events live under this namespace. It is considered acceptable for third party distributions to add new event types in this namespace. =head2 Test2::Hub:: Hub subclasses (and some hub utility objects) live under this namespace. It is perfectly reasonable for third party distributions to add new hub subclasses in this namespace. =head2 Test2::IPC:: The IPC subsystem lives in this namespace. There are not many good reasons to add anything to this namespace, with exception of IPC drivers. =head3 Test2::IPC::Driver:: IPC drivers live in this namespace. It is fine to create new IPC drivers and to put them in this namespace. =head2 Test2::Util:: This namespace is for general utilities used by testing tools. Please be considerate when adding new modules to this namespace. =head2 Test2::API:: This is for Test2 API and related packages. =head2 Test2:: The Test2:: namespace is intended for extensions and frameworks. Tools, Plugins, etc should not go directly into this namespace. However extensions that are used to build tools and plugins may go here. In short: If the module exports anything that should be run directly by a test script it should probably NOT go directly into C<Test2::XXX>. =head1 SEE ALSO L<Test2::API> - Primary API functions. L<Test2::API::Context> - Detailed documentation of the context object. L<Test2::IPC> - The IPC system used for threading/fork support. L<Test2::Formatter> - Formatters such as TAP live here. L<Test2::Event> - Events live in this namespace. L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how C<intercept()> and C<run_subtest()> are implemented. =head1 CONTACTING US Many Test2 developers and users lurk on L<irc://irc.perl.org/#perl-qa> and L<irc://irc.perl.org/#toolchain>. We also have a slack team that can be joined by anyone with an C<@cpan.org> email address L<https://perl-test2.slack.com/> If you do not have an C<@cpan.org> email you can ask for a slack invite by emailing Chad Granum E<lt>exodist@cpan.orgE<gt>. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =head1 MAINTAINERS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 AUTHORS =over 4 =item Chad Granum E<lt>exodist@cpan.orgE<gt> =back =head1 COPYRIGHT Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut perl5/IO/AtomicFile.pm 0000444 00000012372 14711220300 0010445 0 ustar 00 package IO::AtomicFile; use strict; use warnings; use parent 'IO::File'; our $VERSION = '2.113'; #------------------------------ # new ARGS... #------------------------------ # Class method, constructor. # Any arguments are sent to open(). # sub new { my $class = shift; my $self = $class->SUPER::new(); ${*$self}{'io_atomicfile_suffix'} = ''; $self->open(@_) if @_; $self; } #------------------------------ # DESTROY #------------------------------ # Destructor. # sub DESTROY { shift->close(1); ### like close, but raises fatal exception on failure } #------------------------------ # open PATH, MODE #------------------------------ # Class/instance method. # sub open { my ($self, $path, $mode) = @_; ref($self) or $self = $self->new; ### now we have an instance! ### Create tmp path, and remember this info: my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'}; ${*$self}{'io_atomicfile_temp'} = $temp; ${*$self}{'io_atomicfile_path'} = $path; ### Open the file! Returns filehandle on success, for use as a constructor: $self->SUPER::open($temp, $mode) ? $self : undef; } #------------------------------ # _closed [YESNO] #------------------------------ # Instance method, private. # Are we already closed? Argument sets new value, returns previous one. # sub _closed { my $self = shift; my $oldval = ${*$self}{'io_atomicfile_closed'}; ${*$self}{'io_atomicfile_closed'} = shift if @_; $oldval; } #------------------------------ # close #------------------------------ # Instance method. # Close the handle, and rename the temp file to its final name. # sub close { my ($self, $die) = @_; unless ($self->_closed(1)) { ### sentinel... if ($self->SUPER::close()) { rename(${*$self}{'io_atomicfile_temp'}, ${*$self}{'io_atomicfile_path'}) or ($die ? die "close (rename) atomic file: $!\n" : return undef); } else { ($die ? die "close atomic file: $!\n" : return undef); } } 1; } #------------------------------ # delete #------------------------------ # Instance method. # Close the handle, and delete the temp file. # sub delete { my $self = shift; unless ($self->_closed(1)) { ### sentinel... $self->SUPER::close(); return unlink(${*$self}{'io_atomicfile_temp'}); } 1; } #------------------------------ # detach #------------------------------ # Instance method. # Close the handle, but DO NOT delete the temp file. # sub detach { my $self = shift; $self->SUPER::close() unless ($self->_closed(1)); 1; } #------------------------------ 1; __END__ =head1 NAME IO::AtomicFile - write a file which is updated atomically =head1 SYNOPSIS use strict; use warnings; use feature 'say'; use IO::AtomicFile; # Write a temp file, and have it install itself when closed: my $fh = IO::AtomicFile->open("bar.dat", "w"); $fh->say("Hello!"); $fh->close || die "couldn't install atomic file: $!"; # Write a temp file, but delete it before it gets installed: my $fh = IO::AtomicFile->open("bar.dat", "w"); $fh->say("Hello!"); $fh->delete; # Write a temp file, but neither install it nor delete it: my $fh = IO::AtomicFile->open("bar.dat", "w"); $fh->say("Hello!"); $fh->detach; =head1 DESCRIPTION This module is intended for people who need to update files reliably in the face of unexpected program termination. For example, you generally don't want to be halfway in the middle of writing I</etc/passwd> and have your program terminate! Even the act of writing a single scalar to a filehandle is I<not> atomic. But this module gives you true atomic updates, via C<rename>. When you open a file I</foo/bar.dat> via this module, you are I<actually> opening a temporary file I</foo/bar.dat..TMP>, and writing your output there. The act of closing this file (either explicitly via C<close>, or implicitly via the destruction of the object) will cause C<rename> to be called... therefore, from the point of view of the outside world, the file's contents are updated in a single time quantum. To ensure that problems do not go undetected, the C<close> method done by the destructor will raise a fatal exception if the C<rename> fails. The explicit C<close> just returns C<undef>. You can also decide at any point to trash the file you've been building. =head1 METHODS L<IO::AtomicFile> inherits all methods from L<IO::File> and implements the following new ones. =head2 close $fh->close(); This method calls its parent L<IO::File/"close"> and then renames its temporary file as the original file name. =head2 delete $fh->delete(); This method calls its parent L<IO::File/"close"> and then deletes the temporary file. =head2 detach $fh->detach(); This method calls its parent L<IO::File/"close">. Unlike L<IO::AtomicFile/"delete"> it does not then delete the temporary file. =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/ScalarArray.pm 0000444 00000040077 14711220301 0010641 0 ustar 00 package IO::ScalarArray; use strict; use Carp; use IO::Handle; # The package version, both in 1.23 style *and* usable by MakeMaker: our $VERSION = '2.113'; # Inheritance: our @ISA = qw(IO::Handle); require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); =head1 NAME IO::ScalarArray - IO:: interface for reading/writing an array of scalars =head1 SYNOPSIS Perform I/O on strings, using the basic OO interface... use IO::ScalarArray; @data = ("My mes", "sage:\n"); ### Open a handle on an array, and append to it: $AH = new IO::ScalarArray \@data; $AH->print("Hello"); $AH->print(", world!\nBye now!\n"); print "The array is now: ", @data, "\n"; ### Open a handle on an array, read it line-by-line, then close it: $AH = new IO::ScalarArray \@data; while (defined($_ = $AH->getline)) { print "Got line: $_"; } $AH->close; ### Open a handle on an array, and slurp in all the lines: $AH = new IO::ScalarArray \@data; print "All lines:\n", $AH->getlines; ### Get the current position (either of two ways): $pos = $AH->getpos; $offset = $AH->tell; ### Set the current position (either of two ways): $AH->setpos($pos); $AH->seek($offset, 0); ### Open an anonymous temporary array: $AH = new IO::ScalarArray; $AH->print("Hi there!"); print "I printed: ", @{$AH->aref}, "\n"; ### get at value Don't like OO for your I/O? No problem. Thanks to the magic of an invisible tie(), the following now works out of the box, just as it does with IO::Handle: use IO::ScalarArray; @data = ("My mes", "sage:\n"); ### Open a handle on an array, and append to it: $AH = new IO::ScalarArray \@data; print $AH "Hello"; print $AH ", world!\nBye now!\n"; print "The array is now: ", @data, "\n"; ### Open a handle on a string, read it line-by-line, then close it: $AH = new IO::ScalarArray \@data; while (<$AH>) { print "Got line: $_"; } close $AH; ### Open a handle on a string, and slurp in all the lines: $AH = new IO::ScalarArray \@data; print "All lines:\n", <$AH>; ### Get the current position (WARNING: requires 5.6): $offset = tell $AH; ### Set the current position (WARNING: requires 5.6): seek $AH, $offset, 0; ### Open an anonymous temporary scalar: $AH = new IO::ScalarArray; print $AH "Hi there!"; print "I printed: ", @{$AH->aref}, "\n"; ### get at value And for you folks with 1.x code out there: the old tie() style still works, though this is I<unnecessary and deprecated>: use IO::ScalarArray; ### Writing to a scalar... my @a; tie *OUT, 'IO::ScalarArray', \@a; print OUT "line 1\nline 2\n", "line 3\n"; print "Array is now: ", @a, "\n" ### Reading and writing an anonymous scalar... tie *OUT, 'IO::ScalarArray'; print OUT "line 1\nline 2\n", "line 3\n"; tied(OUT)->seek(0,0); while (<OUT>) { print "Got line: ", $_; } =head1 DESCRIPTION This class is part of the IO::Stringy distribution; see L<IO::Stringy> for change log and general information. The IO::ScalarArray class implements objects which behave just like IO::Handle (or FileHandle) objects, except that you may use them to write to (or read from) arrays of scalars. Logically, an array of scalars defines an in-core "file" whose contents are the concatenation of the scalars in the array. The handles created by this class are automatically C<tiehandle>d (though please see L<"WARNINGS"> for information relevant to your Perl version). For writing large amounts of data with individual print() statements, this class is likely to be more efficient than IO::Scalar. Basically, this: my @a; $AH = new IO::ScalarArray \@a; $AH->print("Hel", "lo, "); ### OO style $AH->print("world!\n"); ### ditto Or this: my @a; $AH = new IO::ScalarArray \@a; print $AH "Hel", "lo, "; ### non-OO style print $AH "world!\n"; ### ditto Causes @a to be set to the following array of 3 strings: ( "Hel" , "lo, " , "world!\n" ) See L<IO::Scalar> and compare with this class. =head1 PUBLIC INTERFACE =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I<Class method.> Return a new, unattached array handle. If any arguments are given, they're sent to open(). =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = bless \do { local *FH }, $class; tie *$self, $class, $self; $self->open(@_); ### open on anonymous by default $self; } sub DESTROY { shift->close; } #------------------------------ =item open [ARRAYREF] I<Instance method.> Open the array handle on a new array, pointed to by ARRAYREF. If no ARRAYREF is given, a "private" array is created to hold the file data. Returns the self object on success, undefined on error. =cut sub open { my ($self, $aref) = @_; ### Sanity: defined($aref) or do {my @a; $aref = \@a}; (ref($aref) eq "ARRAY") or croak "open needs a ref to a array"; ### Setup: $self->setpos([0,0]); *$self->{AR} = $aref; $self; } #------------------------------ =item opened I<Instance method.> Is the array handle opened on something? =cut sub opened { *{shift()}->{AR}; } #------------------------------ =item close I<Instance method.> Disassociate the array handle from its underlying array. Done automatically on destroy. =cut sub close { my $self = shift; %{*$self} = (); 1; } =back =cut #============================== =head2 Input and output =over 4 =cut #------------------------------ =item flush I<Instance method.> No-op, provided for OO compatibility. =cut sub flush { "0 but true" } #------------------------------ =item fileno I<Instance method.> No-op, returns undef =cut sub fileno { } #------------------------------ =item getc I<Instance method.> Return the next character, or undef if none remain. This does a read(1), which is somewhat costly. =cut sub getc { my $buf = ''; ($_[0]->read($buf, 1) ? $buf : undef); } #------------------------------ =item getline I<Instance method.> Return the next line, or undef on end of data. Can safely be called in an array context. Currently, lines are delimited by "\n". =cut sub getline { my $self = shift; my ($str, $line) = (undef, ''); ### Minimal impact implementation! ### We do the fast thing (no regexps) if using the ### classic input record separator. ### Case 1: $/ is undef: slurp all... if (!defined($/)) { return undef if ($self->eof); ### Get the rest of the current string, followed by remaining strings: my $ar = *$self->{AR}; my @slurp = ( substr($ar->[*$self->{Str}], *$self->{Pos}), @$ar[(1 + *$self->{Str}) .. $#$ar ] ); ### Seek to end: $self->_setpos_to_eof; return join('', @slurp); } ### Case 2: $/ is "\n": elsif ($/ eq "\012") { ### Until we hit EOF (or exited because of a found line): until ($self->eof) { ### If at end of current string, go fwd to next one (won't be EOF): if ($self->_eos) {++*$self->{Str}, *$self->{Pos}=0}; ### Get ref to current string in array, and set internal pos mark: $str = \(*$self->{AR}[*$self->{Str}]); ### get current string pos($$str) = *$self->{Pos}; ### start matching from here ### Get from here to either \n or end of string, and add to line: $$str =~ m/\G(.*?)((\n)|\Z)/g; ### match to 1st \n or EOS $line .= $1.$2; ### add it *$self->{Pos} += length($1.$2); ### move fwd by len matched return $line if $3; ### done, got line with "\n" } return ($line eq '') ? undef : $line; ### return undef if EOF } ### Case 3: $/ is ref to int. Bail out. elsif (ref($/)) { croak '$/ given as a ref to int; currently unsupported'; } ### Case 4: $/ is either "" (paragraphs) or something weird... ### Bail for now. else { croak '$/ as given is currently unsupported'; } } #------------------------------ =item getlines I<Instance method.> Get all remaining lines. It will croak() if accidentally called in a scalar context. =cut sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); my ($line, @lines); push @lines, $line while (defined($line = $self->getline)); @lines; } #------------------------------ =item print ARGS... I<Instance method.> Print ARGS to the underlying array. Currently, this always causes a "seek to the end of the array" and generates a new array entry. This may change in the future. =cut sub print { my $self = shift; push @{*$self->{AR}}, join('', @_) . (defined($\) ? $\ : ""); ### add the data $self->_setpos_to_eof; 1; } #------------------------------ =item read BUF, NBYTES, [OFFSET]; I<Instance method.> Read some bytes from the array. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub read { my $self = $_[0]; ### we must use $_[1] as a ref my $n = $_[2]; my $off = $_[3] || 0; ### print "getline\n"; my $justread; my $len; ($off ? substr($_[1], $off) : $_[1]) = ''; ### Stop when we have zero bytes to go, or when we hit EOF: my @got; until (!$n or $self->eof) { ### If at end of current string, go forward to next one (won't be EOF): if ($self->_eos) { ++*$self->{Str}; *$self->{Pos} = 0; } ### Get longest possible desired substring of current string: $justread = substr(*$self->{AR}[*$self->{Str}], *$self->{Pos}, $n); $len = length($justread); push @got, $justread; $n -= $len; *$self->{Pos} += $len; } $_[1] .= join('', @got); return length($_[1])-$off; } #------------------------------ =item write BUF, NBYTES, [OFFSET]; I<Instance method.> Write some bytes into the array. =cut sub write { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $data = substr($_[1], $n, $off); $n = length($data); $self->print($data); return $n; } =back =cut #============================== =head2 Seeking/telling and other attributes =over 4 =cut #------------------------------ =item autoflush I<Instance method.> No-op, provided for OO compatibility. =cut sub autoflush {} #------------------------------ =item binmode I<Instance method.> No-op, provided for OO compatibility. =cut sub binmode {} #------------------------------ =item clearerr I<Instance method.> Clear the error and EOF flags. A no-op. =cut sub clearerr { 1 } #------------------------------ =item eof I<Instance method.> Are we at end of file? =cut sub eof { ### print "checking EOF [*$self->{Str}, *$self->{Pos}]\n"; ### print "SR = ", $#{*$self->{AR}}, "\n"; return 0 if (*{$_[0]}->{Str} < $#{*{$_[0]}->{AR}}); ### before EOA return 1 if (*{$_[0]}->{Str} > $#{*{$_[0]}->{AR}}); ### after EOA ### ### at EOA, past EOS: ((*{$_[0]}->{Str} == $#{*{$_[0]}->{AR}}) && ($_[0]->_eos)); } #------------------------------ # # _eos # # I<Instance method, private.> Are we at end of the CURRENT string? # sub _eos { (*{$_[0]}->{Pos} >= length(*{$_[0]}->{AR}[*{$_[0]}->{Str}])); ### past last char } #------------------------------ =item seek POS,WHENCE I<Instance method.> Seek to a given position in the stream. Only a WHENCE of 0 (SEEK_SET) is supported. =cut sub seek { my ($self, $pos, $whence) = @_; ### Seek: if ($whence == 0) { $self->_seek_set($pos); } elsif ($whence == 1) { $self->_seek_cur($pos); } elsif ($whence == 2) { $self->_seek_end($pos); } else { croak "bad seek whence ($whence)" } return 1; } #------------------------------ # # _seek_set POS # # Instance method, private. # Seek to $pos relative to start: # sub _seek_set { my ($self, $pos) = @_; ### Advance through array until done: my $istr = 0; while (($pos >= 0) && ($istr < scalar(@{*$self->{AR}}))) { if (length(*$self->{AR}[$istr]) > $pos) { ### it's in this string! return $self->setpos([$istr, $pos]); } else { ### it's in next string $pos -= length(*$self->{AR}[$istr++]); ### move forward one string } } ### If we reached this point, pos is at or past end; zoom to EOF: return $self->_setpos_to_eof; } #------------------------------ # # _seek_cur POS # # Instance method, private. # Seek to $pos relative to current position. # sub _seek_cur { my ($self, $pos) = @_; $self->_seek_set($self->tell + $pos); } #------------------------------ # # _seek_end POS # # Instance method, private. # Seek to $pos relative to end. # We actually seek relative to beginning, which is simple. # sub _seek_end { my ($self, $pos) = @_; $self->_seek_set($self->_tell_eof + $pos); } #------------------------------ =item tell I<Instance method.> Return the current position in the stream, as a numeric offset. =cut sub tell { my $self = shift; my $off = 0; my ($s, $str_s); for ($s = 0; $s < *$self->{Str}; $s++) { ### count all "whole" scalars defined($str_s = *$self->{AR}[$s]) or $str_s = ''; ###print STDERR "COUNTING STRING $s (". length($str_s) . ")\n"; $off += length($str_s); } ###print STDERR "COUNTING POS ($self->{Pos})\n"; return ($off += *$self->{Pos}); ### plus the final, partial one } #------------------------------ # # _tell_eof # # Instance method, private. # Get position of EOF, as a numeric offset. # This is identical to the size of the stream - 1. # sub _tell_eof { my $self = shift; my $len = 0; foreach (@{*$self->{AR}}) { $len += length($_) } $len; } #------------------------------ =item setpos POS I<Instance method.> Seek to a given position in the array, using the opaque getpos() value. Don't expect this to be a number. =cut sub setpos { my ($self, $pos) = @_; (ref($pos) eq 'ARRAY') or die "setpos: only use a value returned by getpos!\n"; (*$self->{Str}, *$self->{Pos}) = @$pos; } #------------------------------ # # _setpos_to_eof # # Fast-forward to EOF. # sub _setpos_to_eof { my $self = shift; $self->setpos([scalar(@{*$self->{AR}}), 0]); } #------------------------------ =item getpos I<Instance method.> Return the current position in the array, as an opaque value. Don't expect this to be a number. =cut sub getpos { [*{$_[0]}->{Str}, *{$_[0]}->{Pos}]; } #------------------------------ =item aref I<Instance method.> Return a reference to the underlying array. =cut sub aref { *{shift()}->{AR}; } =back =cut #------------------------------ # Tied handle methods... #------------------------------ ### Conventional tiehandle interface: sub TIEHANDLE { (defined($_[1]) && UNIVERSAL::isa($_[1],"IO::ScalarArray")) ? $_[1] : shift->new(@_) } sub GETC { shift->getc(@_) } sub PRINT { shift->print(@_) } sub PRINTF { shift->print(sprintf(shift, @_)) } sub READ { shift->read(@_) } sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } sub WRITE { shift->write(@_); } sub CLOSE { shift->close(@_); } sub SEEK { shift->seek(@_); } sub TELL { shift->tell(@_); } sub EOF { shift->eof(@_); } sub BINMODE { 1; } #------------------------------------------------------------ 1; __END__ # SOME PRIVATE NOTES: # # * The "current position" is the position before the next # character to be read/written. # # * Str gives the string index of the current position, 0-based # # * Pos gives the offset within AR[Str], 0-based. # # * Inital pos is [0,0]. After print("Hello"), it is [1,0]. =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/Lines.pm 0000444 00000010112 14711220302 0007473 0 ustar 00 package IO::Lines; use strict; use Carp; use IO::ScalarArray; # The package version, both in 1.23 style *and* usable by MakeMaker: our $VERSION = '2.113'; # Inheritance: our @ISA = qw(IO::ScalarArray); ### also gets us new_tie :-) =head1 NAME IO::Lines - IO:: interface for reading/writing an array of lines =head1 SYNOPSIS use IO::Lines; ### See IO::ScalarArray for details =head1 DESCRIPTION This class implements objects which behave just like FileHandle (or IO::Handle) objects, except that you may use them to write to (or read from) an array of lines. C<tiehandle> capable as well. This is a subclass of L<IO::ScalarArray|IO::ScalarArray> in which the underlying array has its data stored in a line-oriented-format: that is, every element ends in a C<"\n">, with the possible exception of the final element. This makes C<getline()> I<much> more efficient; if you plan to do line-oriented reading/printing, you want this class. The C<print()> method will enforce this rule, so you can print arbitrary data to the line-array: it will break the data at newlines appropriately. See L<IO::ScalarArray> for full usage and warnings. =cut #------------------------------ # # getline # # Instance method, override. # Return the next line, or undef on end of data. # Can safely be called in an array context. # Currently, lines are delimited by "\n". # sub getline { my $self = shift; if (!defined $/) { return join( '', $self->_getlines_for_newlines ); } elsif ($/ eq "\n") { if (!*$self->{Pos}) { ### full line... return *$self->{AR}[*$self->{Str}++]; } else { ### partial line... my $partial = substr(*$self->{AR}[*$self->{Str}++], *$self->{Pos}); *$self->{Pos} = 0; return $partial; } } else { croak 'unsupported $/: must be "\n" or undef'; } } #------------------------------ # # getlines # # Instance method, override. # Return an array comprised of the remaining lines, or () on end of data. # Must be called in an array context. # Currently, lines are delimited by "\n". # sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); if ((defined $/) and ($/ eq "\n")) { return $self->_getlines_for_newlines(@_); } else { ### slow but steady return $self->SUPER::getlines(@_); } } #------------------------------ # # _getlines_for_newlines # # Instance method, private. # If $/ is newline, do fast getlines. # This CAN NOT invoke getline! # sub _getlines_for_newlines { my $self = shift; my ($rArray, $Str, $Pos) = @{*$self}{ qw( AR Str Pos ) }; my @partial = (); if ($Pos) { ### partial line... @partial = (substr( $rArray->[ $Str++ ], $Pos )); *$self->{Pos} = 0; } *$self->{Str} = scalar @$rArray; ### about to exhaust @$rArray return (@partial, @$rArray[ $Str .. $#$rArray ]); ### remaining full lines... } #------------------------------ # # print ARGS... # # Instance method, override. # Print ARGS to the underlying line array. # sub print { if (defined $\ && $\ ne "\n") { croak 'unsupported $\: must be "\n" or undef'; } my $self = shift; ### print STDERR "\n[[ARRAY WAS...\n", @{*$self->{AR}}, "<<EOF>>\n"; my @lines = split /^/, join('', @_); @lines or return 1; ### Did the previous print not end with a newline? ### If so, append first line: if (@{*$self->{AR}} and (*$self->{AR}[-1] !~ /\n\Z/)) { *$self->{AR}[-1] .= shift @lines; } push @{*$self->{AR}}, @lines; ### add the remainder ### print STDERR "\n[[ARRAY IS NOW...\n", @{*$self->{AR}}, "<<EOF>>\n"; 1; } #------------------------------ 1; __END__ =head1 VERSION $Id: Lines.pm,v 1.3 2005/02/10 21:21:53 dfs Exp $ =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/Wrap.pm 0000444 00000021125 14711220302 0007340 0 ustar 00 package IO::Wrap; use strict; use Exporter; use FileHandle; use Carp; our $VERSION = '2.113'; our @ISA = qw(Exporter); our @EXPORT = qw(wraphandle); #------------------------------ # wraphandle RAW #------------------------------ sub wraphandle { my $raw = shift; new IO::Wrap $raw; } #------------------------------ # new STREAM #------------------------------ sub new { my ($class, $stream) = @_; no strict 'refs'; ### Convert raw scalar to globref: ref($stream) or $stream = \*$stream; ### Wrap globref and incomplete objects: if ((ref($stream) eq 'GLOB') or ### globref (ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) { return bless \$stream, $class; } $stream; ### already okay! } #------------------------------ # I/O methods... #------------------------------ sub close { my $self = shift; return close($$self); } sub fileno { my $self = shift; my $fh = $$self; return fileno($fh); } sub getline { my $self = shift; my $fh = $$self; return scalar(<$fh>); } sub getlines { my $self = shift; wantarray or croak("Can't call getlines in scalar context!"); my $fh = $$self; <$fh>; } sub print { my $self = shift; print { $$self } @_; } sub read { my $self = shift; return read($$self, $_[0], $_[1]); } sub seek { my $self = shift; return seek($$self, $_[0], $_[1]); } sub tell { my $self = shift; return tell($$self); } 1; __END__ =head1 NAME IO::Wrap - Wrap raw filehandles in the IO::Handle interface =head1 SYNOPSIS use strict; use warnings; use IO::Wrap; # this is a fairly senseless use case as IO::Handle already does this. my $wrap_fh = IO::Wrap->new(\*STDIN); my $line = $wrap_fh->getline(); # Do stuff with any kind of filehandle (including a bare globref), or # any kind of blessed object that responds to a print() message. # already have a globref? a FileHandle? a scalar filehandle name? $wrap_fh = IO::Wrap->new($some_unknown_thing); # At this point, we know we have an IO::Handle-like object! YAY $wrap_fh->print("Hey there!"); You can also do this using a convenience wrapper function use strict; use warnings; use IO::Wrap qw(wraphandle); # this is a fairly senseless use case as IO::Handle already does this. my $wrap_fh = wraphandle(\*STDIN); my $line = $wrap_fh->getline(); # Do stuff with any kind of filehandle (including a bare globref), or # any kind of blessed object that responds to a print() message. # already have a globref? a FileHandle? a scalar filehandle name? $wrap_fh = wraphandle($some_unknown_thing); # At this point, we know we have an IO::Handle-like object! YAY $wrap_fh->print("Hey there!"); =head1 DESCRIPTION Let's say you want to write some code which does I/O, but you don't want to force the caller to provide you with a L<FileHandle> or L<IO::Handle> object. You want them to be able to say: do_stuff(\*STDOUT); do_stuff('STDERR'); do_stuff($some_FileHandle_object); do_stuff($some_IO_Handle_object); And even: do_stuff($any_object_with_a_print_method); Sure, one way to do it is to force the caller to use C<tiehandle()>. But that puts the burden on them. Another way to do it is to use B<IO::Wrap>. Clearly, when wrapping a raw external filehandle (like C<\*STDOUT>), I didn't want to close the file descriptor when the wrapper object is destroyed; the user might not appreciate that! Hence, there's no C<DESTROY> method in this class. When wrapping a L<FileHandle> object, however, I believe that Perl will invoke the C<FileHandle::DESTROY> when the last reference goes away, so in that case, the filehandle is closed if the wrapped L<FileHandle> really was the last reference to it. =head1 FUNCTIONS L<IO::Wrap> makes the following functions available. =head2 wraphandle # wrap a filehandle glob my $fh = wraphandle(\*STDIN); # wrap a raw filehandle glob by name $fh = wraphandle('STDIN'); # wrap a handle in an object $fh = wraphandle('Class::HANDLE'); # wrap a blessed FileHandle object use FileHandle; my $fho = FileHandle->new("/tmp/foo.txt", "r"); $fh = wraphandle($fho); # wrap any other blessed object that shares IO::Handle's interface $fh = wraphandle($some_object); This function is simply a wrapper to the L<IO::Wrap/"new"> constructor method. =head1 METHODS L<IO::Wrap> implements the following methods. =head2 close $fh->close(); The C<close> method will attempt to close the system file descriptor. For a more complete description, read L<perlfunc/close>. =head2 fileno my $int = $fh->fileno(); The C<fileno> method returns the file descriptor for the wrapped filehandle. See L<perlfunc/fileno> for more information. =head2 getline my $data = $fh->getline(); The C<getline> method mimics the function by the same name in L<IO::Handle>. It's like calling C<< my $data = <$fh>; >> but only in scalar context. =head2 getlines my @data = $fh->getlines(); The C<getlines> method mimics the function by the same name in L<IO::Handle>. It's like calling C<< my @data = <$fh>; >> but only in list context. Calling this method in scalar context will result in a croak. =head2 new # wrap a filehandle glob my $fh = IO::Wrap->new(\*STDIN); # wrap a raw filehandle glob by name $fh = IO::Wrap->new('STDIN'); # wrap a handle in an object $fh = IO::Wrap->new('Class::HANDLE'); # wrap a blessed FileHandle object use FileHandle; my $fho = FileHandle->new("/tmp/foo.txt", "r"); $fh = IO::Wrap->new($fho); # wrap any other blessed object that shares IO::Handle's interface $fh = IO::Wrap->new($some_object); The C<new> constructor method takes in a single argument and decides to wrap it or not it based on what it seems to be. A raw scalar file handle name, like C<"STDOUT"> or C<"Class::HANDLE"> can be wrapped, returning an L<IO::Wrap> object instance. A raw filehandle glob, like C<\*STDOUT> can also be wrapped, returning an L<IO::Wrawp> object instance. A blessed L<FileHandle> object can also be wrapped. This is a special case where an L<IO::Wrap> object instance will only be returned in the case that your L<FileHandle> object doesn't support the C<read> method. Also, any other kind of blessed object that conforms to the L<IO::Handle> interface can be passed in. In this case, you just get back that object. In other words, we only wrap it into an L<IO::Wrap> object when what you've supplied doesn't already conform to the L<IO::Handle> interface. If you get back an L<IO::Wrap> object, it will obey a basic subset of the C<IO::> interface. It will do so with object B<methods>, not B<operators>. =head3 CAVEATS This module does not allow you to wrap filehandle names which are given as strings that lack the package they were opened in. That is, if a user opens FOO in package Foo, they must pass it to you either as C<\*FOO> or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine. =head2 print $fh->print("Some string"); $fh->print("more", " than one", " string"); The C<print> method will attempt to print a string or list of strings to the filehandle. For a more complete description, read L<perlfunc/print>. =head2 read my $buffer; # try to read 30 chars into the buffer starting at the # current cursor position. my $num_chars_read = $fh->read($buffer, 30); The L<read> method attempts to read a number of characters, starting at the filehandle's current cursor position. It returns the number of characters actually read. See L<perlfunc/read> for more information. =head2 seek use Fcntl qw(:seek); # import the SEEK_CUR, SEEK_SET, SEEK_END constants # seek to the position in bytes $fh->seek(0, SEEK_SET); # seek to the position in bytes from the current position $fh->seek(22, SEEK_CUR); # seek to the EOF plus bytes $fh->seek(0, SEEK_END); The C<seek> method will attempt to set the cursor to a given position in bytes for the wrapped file handle. See L<perlfunc/seek> for more information. =head2 tell my $bytes = $fh->tell(); The C<tell> method will attempt to return the current position of the cursor in bytes for the wrapped file handle. See L<perlfunc/tell> for more information. =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/WrapTie.pm 0000444 00000034574 14711220302 0010016 0 ustar 00 package IO::WrapTie; use strict; use Exporter; # Inheritance, exporting, and package version: our @ISA = qw(Exporter); our @EXPORT = qw(wraptie); our $VERSION = '2.113'; # Function, exported. sub wraptie { IO::WrapTie::Master->new(@_); } # Class method; BACKWARDS-COMPATIBILITY ONLY! sub new { shift; IO::WrapTie::Master->new(@_); } #------------------------------------------------------------ package # hide from pause IO::WrapTie::Master; #------------------------------------------------------------ use strict; use vars qw($AUTOLOAD); use IO::Handle; # We inherit from IO::Handle to get methods which invoke i/o operators, # like print(), on our tied handle: our @ISA = qw(IO::Handle); #------------------------------ # new SLAVE, TIEARGS... #------------------------------ # Create a new subclass of IO::Handle which... # # (1) Handles i/o OPERATORS because it is tied to an instance of # an i/o-like class, like IO::Scalar. # # (2) Handles i/o METHODS by delegating them to that same tied object!. # # Arguments are the slave class (e.g., IO::Scalar), followed by all # the arguments normally sent into that class's C<TIEHANDLE> method. # In other words, much like the arguments to tie(). :-) # # NOTE: # The thing $x we return must be a BLESSED REF, for ($x->print()). # The underlying symbol must be a FILEHANDLE, for (print $x "foo"). # It has to have a way of getting to the "real" back-end object... # sub new { my $master = shift; my $io = IO::Handle->new; ### create a new handle my $slave = shift; tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE bless $io, $master; ### return a master } #------------------------------ # AUTOLOAD #------------------------------ # Delegate method invocations on the master to the underlying slave. # sub AUTOLOAD { my $method = $AUTOLOAD; $method =~ s/.*:://; my $self = shift; tied(*$self)->$method(\@_); } #------------------------------ # PRELOAD #------------------------------ # Utility. # # Most methods like print(), getline(), etc. which work on the tied object # via Perl's i/o operators (like 'print') are inherited from IO::Handle. # # Other methods, like seek() and sref(), we must delegate ourselves. # AUTOLOAD takes care of these. # # However, it may be necessary to preload delegators into your # own class. PRELOAD will do this. # sub PRELOAD { my $class = shift; foreach (@_) { eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }"; } } # Preload delegators for some standard methods which we can't simply # inherit from IO::Handle... for example, some IO::Handle methods # assume that there is an underlying file descriptor. # PRELOAD IO::WrapTie::Master qw(open opened close read clearerr eof seek tell setpos getpos); #------------------------------------------------------------ package # hide from pause IO::WrapTie::Slave; #------------------------------------------------------------ # Teeny private class providing a new_tie constructor... # # HOW IT ALL WORKS: # # Slaves inherit from this class. # # When you send a new_tie() message to a tie-slave class (like IO::Scalar), # it first determines what class should provide its master, via TIE_MASTER. # In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master. # Then, we create a new master (an IO::Scalar::Master) with the same args # sent to new_tie. # # In general, the new() method of the master is inherited directly # from IO::WrapTie::Master. # sub new_tie { my $self = shift; $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_) } # Default class method for new_tie(). # All your tie-slave class (like IO::Scalar) has to do is override this # method with a method that returns the name of an appropriate "master" # class for tying that slave. # sub TIE_MASTER { 'IO::WrapTie::Master' } #------------------------------ 1; __END__ package IO::WrapTie; ### for doc generator =head1 NAME IO::WrapTie - wrap tieable objects in IO::Handle interface I<This is currently Alpha code, released for comments. Please give me your feedback!> =head1 SYNOPSIS First of all, you'll need tie(), so: require 5.004; I<Function interface (experimental).> Use this with any existing class... use IO::WrapTie; use FooHandle; ### implements TIEHANDLE interface ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)". ### We can instead say... $FH = wraptie('FooHandle', &FOO_RDWR, 2); ### Now we can use... print $FH "Hello, "; ### traditional operator syntax... $FH->print("world!\n"); ### ...and OO syntax as well! I<OO interface (preferred).> You can inherit from the L<IO::WrapTie/"Slave"> mixin to get a nifty C<new_tie()> constructor... #------------------------------ package FooHandle; ### a class which can TIEHANDLE use IO::WrapTie; @ISA = qw(IO::WrapTie::Slave); ### inherit new_tie() ... #------------------------------ package main; $FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master print $FH "Hello, "; ### traditional operator syntax $FH->print("world!\n"); ### OO syntax See IO::Scalar as an example. It also shows you how to create classes which work both with and without 5.004. =head1 DESCRIPTION Suppose you have a class C<FooHandle>, where... =over 4 =item * C<FooHandle> does not inherit from L<IO::Handle>. That is, it performs file handle-like I/O, but to something other than an underlying file descriptor. Good examples are L<IO::Scalar> (for printing to a string) and L<IO::Lines> (for printing to an array of lines). =item * C<FooHandle> implements the C<TIEHANDLE> interface (see L<perltie>). That is, it provides methods C<TIEHANDLE>, C<GETC>, C<PRINT>, C<PRINTF>, C<READ>, and C<READLINE>. =item * C<FooHandle> implements the traditional OO interface of L<FileHandle> and L<IO::Handle>. i.e., it contains methods like C<getline>, C<read>, C<print>, C<seek>, C<tell>, C<eof>, etc. =back Normally, users of your class would have two options: =over 4 =item * B<Use only OO syntax,> and forsake named I/O operators like C<print>. =item * B<Use with tie,> and forsake treating it as a first-class object (i.e., class-specific methods can only be invoked through the underlying object via C<tied>... giving the object a "split personality"). =back But now with L<IO::WrapTie>, you can say: $WT = wraptie('FooHandle', &FOO_RDWR, 2); $WT->print("Hello, world\n"); ### OO syntax print $WT "Yes!\n"; ### Named operator syntax too! $WT->weird_stuff; ### Other methods! And if you're authoring a class like C<FooHandle>, just have it inherit from C<IO::WrapTie::Slave> and that first line becomes even prettier: $WT = FooHandle->new_tie(&FOO_RDWR, 2); B<The bottom line:> now, almost any class can look and work exactly like an L<IO::Handle> and be used both with OO and non-OO file handle syntax. =head1 HOW IT ALL WORKS =head2 The data structures Consider this example code, using classes in this distribution: use IO::Scalar; use IO::WrapTie; $WT = wraptie('IO::Scalar',\$s); print $WT "Hello, "; $WT->print("world!\n"); In it, the C<wraptie> function creates a data structure as follows: * $WT is a blessed reference to a tied filehandle $WT glob; that glob is tied to the "Slave" object. | * You would do all your i/o with $WT directly. | | | ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle V / .-------------. | | | | * Perl i/o operators work on the tied object, | "Master" | invoking the C<TIEHANDLE> methods. | | * Method invocations are delegated to the tied | | slave. `-------------' | tied(*$WT) | .---isa--> IO::WrapTie::Slave V / .-------------. | | | "Slave" | * Instance of FileHandle-like class which doesn't | | actually use file descriptors, like IO::Scalar. | IO::Scalar | * The slave can be any kind of object. | | * Must implement the C<TIEHANDLE> interface. `-------------' I<NOTE:> just as an L<IO::Handle> is really just a blessed reference to a I<traditional> file handle glob. So also, an C<IO::WrapTie::Master> is really just a blessed reference to a file handle glob I<which has been tied to some "slave" class.> =head2 How C<wraptie> works =over 4 =item 1. The call to function C<wraptie(SLAVECLASS, TIEARGS...)> is passed onto C<IO::WrapTie::Master::new()>. Note that class C<IO::WrapTie::Master> is a subclass of L<IO::Handle>. =item 2. The C<< IO::WrapTie::Master->new >> method creates a new L<IO::Handle> object, re-blessed into class C<IO::WrapTie::Master>. This object is the I<master>, which will be returned from the constructor. At the same time... =item 3. The C<new> method also creates the I<slave>: this is an instance of C<SLAVECLASS> which is created by tying the master's L<IO::Handle> to C<SLAVECLASS> via C<tie>. This call to C<tie> creates the slave in the following manner: =item 4. Class C<SLAVECLASS> is sent the message C<TIEHANDLE>; it will usually delegate this to C<< SLAVECLASS->new(TIEARGS) >>, resulting in a new instance of C<SLAVECLASS> being created and returned. =item 5. Once both master and slave have been created, the master is returned to the caller. =back =head2 How I/O operators work (on the master) Consider using an i/o operator on the master: print $WT "Hello, world!\n"; Since the master C<$WT> is really a C<blessed> reference to a glob, the normal Perl I/O operators like C<print> may be used on it. They will just operate on the symbol part of the glob. Since the glob is tied to the slave, the slave's C<PRINT> method (part of the C<TIEHANDLE> interface) will be automatically invoked. If the slave is an L<IO::Scalar>, that means L<IO::Scalar/"PRINT"> will be invoked, and that method happens to delegate to the C<print> method of the same class. So the I<real> work is ultimately done by L<IO::Scalar/"print">. =head2 How methods work (on the master) Consider using a method on the master: $WT->print("Hello, world!\n"); Since the master C<$WT> is blessed into the class C<IO::WrapTie::Master>, Perl first attempts to find a C<print> method there. Failing that, Perl next attempts to find a C<print> method in the super class, L<IO::Handle>. It just so happens that there I<is> such a method; that method merely invokes the C<print> I/O operator on the self object... and for that, see above! But let's suppose we're dealing with a method which I<isn't> part of L<IO::Handle>... for example: my $sref = $WT->sref; In this case, the intuitive behavior is to have the master delegate the method invocation to the slave (now do you see where the designations come from?). This is indeed what happens: C<IO::WrapTie::Master> contains an C<AUTOLOAD> method which performs the delegation. So: when C<sref> can't be found in L<IO::Handle>, the C<AUTOLOAD> method of C<IO::WrapTie::Master> is invoked, and the standard behavior of delegating the method to the underlying slave (here, an L<IO::Scalar>) is done. Sometimes, to get this to work properly, you may need to create a subclass of C<IO::WrapTie::Master> which is an effective master for I<your> class, and do the delegation there. =head1 NOTES B<Why not simply use the object's OO interface?> Because that means forsaking the use of named operators like C<print>, and you may need to pass the object to a subroutine which will attempt to use those operators: $O = FooHandle->new(&FOO_RDWR, 2); $O->print("Hello, world\n"); ### OO syntax is okay, BUT.... sub nope { print $_[0] "Nope!\n" } X nope($O); ### ERROR!!! (not a glob ref) B<Why not simply use tie()?> Because (1) you have to use C<tied> to invoke methods in the object's public interface (yuck), and (2) you may need to pass the tied symbol to another subroutine which will attempt to treat it in an OO-way... and that will break it: tie *T, 'FooHandle', &FOO_RDWR, 2; print T "Hello, world\n"; ### Operator is okay, BUT... tied(*T)->other_stuff; ### yuck! AND... sub nope { shift->print("Nope!\n") } X nope(\*T); ### ERROR!!! (method "print" on unblessed ref) B<Why a master and slave?> Why not simply write C<FooHandle> to inherit from L<IO::Handle?> I tried this, with an implementation similar to that of L<IO::Socket>. The problem is that I<the whole point is to use this with objects that don't have an underlying file/socket descriptor.>. Subclassing L<IO::Handle> will work fine for the OO stuff, and fine with named operators I<if> you C<tie>... but if you just attempt to say: $IO = FooHandle->new(&FOO_RDWR, 2); print $IO "Hello!\n"; you get a warning from Perl like: Filehandle GEN001 never opened because it's trying to do system-level I/O on an (unopened) file descriptor. To avoid this, you apparently have to C<tie> the handle... which brings us right back to where we started! At least the L<IO::WrapTie> mixin lets us say: $IO = FooHandle->new_tie(&FOO_RDWR, 2); print $IO "Hello!\n"; and so is not I<too> bad. C<:-)> =head1 WARNINGS Remember: this stuff is for doing L<FileHandle>-like I/O on things I<without underlying file descriptors>. If you have an underlying file descriptor, you're better off just inheriting from L<IO::Handle>. B<Be aware that new_tie() always returns an instance of a kind of IO::WrapTie::Master...> it does B<not> return an instance of the I/O class you're tying to! Invoking some methods on the master object causes C<AUTOLOAD> to delegate them to the slave object... so it I<looks> like you're manipulating a C<FooHandle> object directly, but you're not. I have not explored all the ramifications of this use of C<tie>. I<Here there be dragons>. =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/Stringy.pm 0000444 00000003435 14711220303 0010073 0 ustar 00 package IO::Stringy; use strict; use Exporter; our $VERSION = '2.113'; 1; __END__ =head1 NAME IO-stringy - I/O on in-core objects like strings and arrays =head1 SYNOPSIS use strict; use warnings; use IO::AtomicFile; # Write a file which is updated atomically use IO::InnerFile; # define a file inside another file use IO::Lines; # I/O handle to read/write to array of lines use IO::Scalar; # I/O handle to read/write to a string use IO::ScalarArray; # I/O handle to read/write to array of scalars use IO::Wrap; # Wrap old-style FHs in standard OO interface use IO::WrapTie; # Tie your handles & retain full OO interface # ... =head1 DESCRIPTION This toolkit primarily provides modules for performing both traditional and object-oriented i/o) on things I<other> than normal filehandles; in particular, L<IO::Scalar|IO::Scalar>, L<IO::ScalarArray|IO::ScalarArray>, and L<IO::Lines|IO::Lines>. In the more-traditional IO::Handle front, we have L<IO::AtomicFile|IO::AtomicFile> which may be used to painlessly create files which are updated atomically. And in the "this-may-prove-useful" corner, we have L<IO::Wrap|IO::Wrap>, whose exported wraphandle() function will clothe anything that's not a blessed object in an IO::Handle-like wrapper... so you can just use OO syntax and stop worrying about whether your function's caller handed you a string, a globref, or a FileHandle. =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/Scalar.pm 0000444 00000035264 14711220303 0007646 0 ustar 00 package IO::Scalar; use strict; use Carp; use IO::Handle; ### Stringification, courtesy of B. K. Oxley (binkley): :-) use overload '""' => sub { ${*{$_[0]}->{SR}} }; use overload 'bool' => sub { 1 }; ### have to do this, so object is true! ### The package version, both in 1.23 style *and* usable by MakeMaker: our $VERSION = '2.113'; ### Inheritance: our @ISA = qw(IO::Handle); ### This stuff should be got rid of ASAP. require IO::WrapTie and push @ISA, 'IO::WrapTie::Slave' if ($] >= 5.004); #============================== =head1 NAME IO::Scalar - IO:: interface for reading/writing a scalar =head1 SYNOPSIS Perform I/O on strings, using the basic OO interface... use 5.005; use IO::Scalar; $data = "My message:\n"; ### Open a handle on a string, and append to it: $SH = new IO::Scalar \$data; $SH->print("Hello"); $SH->print(", world!\nBye now!\n"); print "The string is now: ", $data, "\n"; ### Open a handle on a string, read it line-by-line, then close it: $SH = new IO::Scalar \$data; while (defined($_ = $SH->getline)) { print "Got line: $_"; } $SH->close; ### Open a handle on a string, and slurp in all the lines: $SH = new IO::Scalar \$data; print "All lines:\n", $SH->getlines; ### Get the current position (either of two ways): $pos = $SH->getpos; $offset = $SH->tell; ### Set the current position (either of two ways): $SH->setpos($pos); $SH->seek($offset, 0); ### Open an anonymous temporary scalar: $SH = new IO::Scalar; $SH->print("Hi there!"); print "I printed: ", ${$SH->sref}, "\n"; ### get at value Don't like OO for your I/O? No problem. Thanks to the magic of an invisible tie(), the following now works out of the box, just as it does with IO::Handle: use 5.005; use IO::Scalar; $data = "My message:\n"; ### Open a handle on a string, and append to it: $SH = new IO::Scalar \$data; print $SH "Hello"; print $SH ", world!\nBye now!\n"; print "The string is now: ", $data, "\n"; ### Open a handle on a string, read it line-by-line, then close it: $SH = new IO::Scalar \$data; while (<$SH>) { print "Got line: $_"; } close $SH; ### Open a handle on a string, and slurp in all the lines: $SH = new IO::Scalar \$data; print "All lines:\n", <$SH>; ### Get the current position (WARNING: requires 5.6): $offset = tell $SH; ### Set the current position (WARNING: requires 5.6): seek $SH, $offset, 0; ### Open an anonymous temporary scalar: $SH = new IO::Scalar; print $SH "Hi there!"; print "I printed: ", ${$SH->sref}, "\n"; ### get at value And for you folks with 1.x code out there: the old tie() style still works, though this is I<unnecessary and deprecated>: use IO::Scalar; ### Writing to a scalar... my $s; tie *OUT, 'IO::Scalar', \$s; print OUT "line 1\nline 2\n", "line 3\n"; print "String is now: $s\n" ### Reading and writing an anonymous scalar... tie *OUT, 'IO::Scalar'; print OUT "line 1\nline 2\n", "line 3\n"; tied(OUT)->seek(0,0); while (<OUT>) { print "Got line: ", $_; } Stringification works, too! my $SH = new IO::Scalar \$data; print $SH "Hello, "; print $SH "world!"; print "I printed: $SH\n"; =head1 DESCRIPTION This class is part of the IO::Stringy distribution; see L<IO::Stringy> for change log and general information. The IO::Scalar class implements objects which behave just like IO::Handle (or FileHandle) objects, except that you may use them to write to (or read from) scalars. These handles are automatically C<tiehandle>d (though please see L<"WARNINGS"> for information relevant to your Perl version). Basically, this: my $s; $SH = new IO::Scalar \$s; $SH->print("Hel", "lo, "); ### OO style $SH->print("world!\n"); ### ditto Or this: my $s; $SH = tie *OUT, 'IO::Scalar', \$s; print OUT "Hel", "lo, "; ### non-OO style print OUT "world!\n"; ### ditto Causes $s to be set to: "Hello, world!\n" =head1 PUBLIC INTERFACE =head2 Construction =over 4 =cut #------------------------------ =item new [ARGS...] I<Class method.> Return a new, unattached scalar handle. If any arguments are given, they're sent to open(). =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = bless \do { local *FH }, $class; tie *$self, $class, $self; $self->open(@_); ### open on anonymous by default $self; } sub DESTROY { shift->close; } #------------------------------ =item open [SCALARREF] I<Instance method.> Open the scalar handle on a new scalar, pointed to by SCALARREF. If no SCALARREF is given, a "private" scalar is created to hold the file data. Returns the self object on success, undefined on error. =cut sub open { my ($self, $sref) = @_; ### Sanity: defined($sref) or do {my $s = ''; $sref = \$s}; (ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar"; ### Setup: *$self->{Pos} = 0; ### seek position *$self->{SR} = $sref; ### scalar reference $self; } #------------------------------ =item opened I<Instance method.> Is the scalar handle opened on something? =cut sub opened { *{shift()}->{SR}; } #------------------------------ =item close I<Instance method.> Disassociate the scalar handle from its underlying scalar. Done automatically on destroy. =cut sub close { my $self = shift; %{*$self} = (); 1; } =back =cut #============================== =head2 Input and output =over 4 =cut #------------------------------ =item flush I<Instance method.> No-op, provided for OO compatibility. =cut sub flush { "0 but true" } #------------------------------ =item fileno I<Instance method.> No-op, returns undef =cut sub fileno { } #------------------------------ =item getc I<Instance method.> Return the next character, or undef if none remain. =cut sub getc { my $self = shift; ### Return undef right away if at EOF; else, move pos forward: return undef if $self->eof; substr(${*$self->{SR}}, *$self->{Pos}++, 1); } #------------------------------ =item getline I<Instance method.> Return the next line, or undef on end of string. Can safely be called in an array context. Currently, lines are delimited by "\n". =cut sub getline { my $self = shift; ### Return undef right away if at EOF: return undef if $self->eof; ### Get next line: my $sr = *$self->{SR}; my $i = *$self->{Pos}; ### Start matching at this point. ### Minimal impact implementation! ### We do the fast thing (no regexps) if using the ### classic input record separator. ### Case 1: $/ is undef: slurp all... if (!defined($/)) { *$self->{Pos} = length $$sr; return substr($$sr, $i); } ### Case 2: $/ is "\n": zoom zoom zoom... elsif ($/ eq "\012") { ### Seek ahead for "\n"... yes, this really is faster than regexps. my $len = length($$sr); for (; $i < $len; ++$i) { last if ord (substr ($$sr, $i, 1)) == 10; } ### Extract the line: my $line; if ($i < $len) { ### We found a "\n": $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1); *$self->{Pos} = $i+1; ### Remember where we finished up. } else { ### No "\n"; slurp the remainder: $line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos}); *$self->{Pos} = $len; } return $line; } ### Case 3: $/ is ref to int. Do fixed-size records. ### (Thanks to Dominique Quatravaux.) elsif (ref($/)) { my $len = length($$sr); my $i = ${$/} + 0; my $line = substr ($$sr, *$self->{Pos}, $i); *$self->{Pos} += $i; *$self->{Pos} = $len if (*$self->{Pos} > $len); return $line; } ### Case 4: $/ is either "" (paragraphs) or something weird... ### This is Graham's general-purpose stuff, which might be ### a tad slower than Case 2 for typical data, because ### of the regexps. else { pos($$sr) = $i; ### If in paragraph mode, skip leading lines (and update i!): length($/) or (($$sr =~ m/\G\n*/g) and ($i = pos($$sr))); ### If we see the separator in the buffer ahead... if (length($/) ? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp! : $$sr =~ m,\n\n,g ### (a paragraph) ) { *$self->{Pos} = pos $$sr; return substr($$sr, $i, *$self->{Pos}-$i); } ### Else if no separator remains, just slurp the rest: else { *$self->{Pos} = length $$sr; return substr($$sr, $i); } } } #------------------------------ =item getlines I<Instance method.> Get all remaining lines. It will croak() if accidentally called in a scalar context. =cut sub getlines { my $self = shift; wantarray or croak("can't call getlines in scalar context!"); my ($line, @lines); push @lines, $line while (defined($line = $self->getline)); @lines; } #------------------------------ =item print ARGS... I<Instance method.> Print ARGS to the underlying scalar. B<Warning:> this continues to always cause a seek to the end of the string, but if you perform seek()s and tell()s, it is still safer to explicitly seek-to-end before subsequent print()s. =cut sub print { my $self = shift; *$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : "")); 1; } sub _unsafe_print { my $self = shift; my $append = join('', @_) . $\; ${*$self->{SR}} .= $append; *$self->{Pos} += length($append); 1; } sub _old_print { my $self = shift; ${*$self->{SR}} .= join('', @_) . $\; *$self->{Pos} = length(${*$self->{SR}}); 1; } #------------------------------ =item read BUF, NBYTES, [OFFSET] I<Instance method.> Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub read { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n); $n = length($read); *$self->{Pos} += $n; ($off ? substr($_[1], $off) : $_[1]) = $read; return $n; } #------------------------------ =item write BUF, NBYTES, [OFFSET] I<Instance method.> Write some bytes to the scalar. =cut sub write { my $self = $_[0]; my $n = $_[2]; my $off = $_[3] || 0; my $data = substr($_[1], $off, $n); $n = length($data); $self->print($data); return $n; } #------------------------------ =item sysread BUF, LEN, [OFFSET] I<Instance method.> Read some bytes from the scalar. Returns the number of bytes actually read, 0 on end-of-file, undef on error. =cut sub sysread { my $self = shift; $self->read(@_); } #------------------------------ =item syswrite BUF, NBYTES, [OFFSET] I<Instance method.> Write some bytes to the scalar. =cut sub syswrite { my $self = shift; $self->write(@_); } =back =cut #============================== =head2 Seeking/telling and other attributes =over 4 =cut #------------------------------ =item autoflush I<Instance method.> No-op, provided for OO compatibility. =cut sub autoflush {} #------------------------------ =item binmode I<Instance method.> No-op, provided for OO compatibility. =cut sub binmode {} #------------------------------ =item clearerr I<Instance method.> Clear the error and EOF flags. A no-op. =cut sub clearerr { 1 } #------------------------------ =item eof I<Instance method.> Are we at end of file? =cut sub eof { my $self = shift; (*$self->{Pos} >= length(${*$self->{SR}})); } #------------------------------ =item seek OFFSET, WHENCE I<Instance method.> Seek to a given position in the stream. =cut sub seek { my ($self, $pos, $whence) = @_; my $eofpos = length(${*$self->{SR}}); ### Seek: if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END else { croak "bad seek whence ($whence)" } ### Fixup: if (*$self->{Pos} < 0) { *$self->{Pos} = 0 } if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos } return 1; } #------------------------------ =item sysseek OFFSET, WHENCE I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.> =cut sub sysseek { my $self = shift; $self->seek (@_); } #------------------------------ =item tell I<Instance method.> Return the current position in the stream, as a numeric offset. =cut sub tell { *{shift()}->{Pos} } #------------------------------ # # use_RS [YESNO] # # I<Instance method.> # Obey the current setting of $/, like IO::Handle does? # Default is false in 1.x, but cold-welded true in 2.x and later. # sub use_RS { my ($self, $yesno) = @_; carp "use_RS is deprecated and ignored; \$/ is always consulted\n"; } #------------------------------ =item setpos POS I<Instance method.> Set the current position, using the opaque value returned by C<getpos()>. =cut sub setpos { shift->seek($_[0],0) } #------------------------------ =item getpos I<Instance method.> Return the current position in the string, as an opaque object. =cut *getpos = \&tell; #------------------------------ =item sref I<Instance method.> Return a reference to the underlying scalar. =cut sub sref { *{shift()}->{SR} } #------------------------------ # Tied handle methods... #------------------------------ # Conventional tiehandle interface: sub TIEHANDLE { ((defined($_[1]) && UNIVERSAL::isa($_[1], "IO::Scalar")) ? $_[1] : shift->new(@_)); } sub GETC { shift->getc(@_) } sub PRINT { shift->print(@_) } sub PRINTF { shift->print(sprintf(shift, @_)) } sub READ { shift->read(@_) } sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) } sub WRITE { shift->write(@_); } sub CLOSE { shift->close(@_); } sub SEEK { shift->seek(@_); } sub TELL { shift->tell(@_); } sub EOF { shift->eof(@_); } sub BINMODE { 1; } #------------------------------------------------------------ 1; __END__ =back =cut =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/IO/InnerFile.pm 0000444 00000015601 14711220303 0010305 0 ustar 00 package IO::InnerFile; use strict; use warnings; use Symbol; our $VERSION = '2.113'; sub new { my ($class, $fh, $start, $lg) = @_; $start = 0 if (!$start or ($start < 0)); $lg = 0 if (!$lg or ($lg < 0)); ### Create the underlying "object": my $a = { FH => $fh, CRPOS => 0, START => $start, LG => $lg, }; ### Create a new filehandle tied to this object: $fh = gensym; tie(*$fh, $class, $a); return bless($fh, $class); } sub TIEHANDLE { my ($class, $data) = @_; return bless($data, $class); } sub DESTROY { my ($self) = @_; $self->close() if (ref($self) eq 'SCALAR'); } sub set_length { tied(${$_[0]})->{LG} = $_[1]; } sub get_length { tied(${$_[0]})->{LG}; } sub add_length { tied(${$_[0]})->{LG} += $_[1]; } sub set_start { tied(${$_[0]})->{START} = $_[1]; } sub get_start { tied(${$_[0]})->{START}; } sub set_end { tied(${$_[0]})->{LG} = $_[1] - tied(${$_[0]})->{START}; } sub get_end { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; } sub write { shift->WRITE(@_) } sub print { shift->PRINT(@_) } sub printf { shift->PRINTF(@_) } sub flush { "0 but true"; } sub fileno { } sub binmode { 1; } sub getc { return GETC(tied(${$_[0]}) ); } sub read { return READ( tied(${$_[0]}), @_[1,2,3] ); } sub readline { return READLINE( tied(${$_[0]}) ); } sub getline { return READLINE( tied(${$_[0]}) ); } sub close { return CLOSE(tied(${$_[0]}) ); } sub seek { my ($self, $ofs, $whence) = @_; $self = tied( $$self ); $self->{CRPOS} = $ofs if ($whence == 0); $self->{CRPOS}+= $ofs if ($whence == 1); $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2); $self->{CRPOS} = 0 if ($self->{CRPOS} < 0); $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG}); return 1; } sub tell { return tied(${$_[0]})->{CRPOS}; } sub WRITE { die "inner files can only open for reading\n"; } sub PRINT { die "inner files can only open for reading\n"; } sub PRINTF { die "inner files can only open for reading\n"; } sub GETC { my ($self) = @_; return 0 if ($self->{CRPOS} >= $self->{LG}); my $data; ### Save and seek... my $old_pos = $self->{FH}->tell; $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); ### ...read... my $lg = $self->{FH}->read($data, 1); $self->{CRPOS} += $lg; ### ...and restore: $self->{FH}->seek($old_pos, 0); $self->{LG} = $self->{CRPOS} unless ($lg); return ($lg ? $data : undef); } sub READ { my ($self, $undefined, $lg, $ofs) = @_; $undefined = undef; return 0 if ($self->{CRPOS} >= $self->{LG}); $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); return 0 unless ($lg); ### Save and seek... my $old_pos = $self->{FH}->tell; $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); ### ...read... $lg = $self->{FH}->read($_[1], $lg, $_[3] ); $self->{CRPOS} += $lg; ### ...and restore: $self->{FH}->seek($old_pos, 0); $self->{LG} = $self->{CRPOS} unless ($lg); return $lg; } sub READLINE { my ($self) = @_; return $self->_readline_helper() unless wantarray; my @arr; while(defined(my $line = $self->_readline_helper())) { push(@arr, $line); } return @arr; } sub _readline_helper { my ($self) = @_; return undef if ($self->{CRPOS} >= $self->{LG}); # Handle slurp mode (CPAN ticket #72710) if (! defined($/)) { my $text; $self->READ($text, $self->{LG} - $self->{CRPOS}); return $text; } ### Save and seek... my $old_pos = $self->{FH}->tell; $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0); ### ...read... my $text = $self->{FH}->getline; ### ...and restore: $self->{FH}->seek($old_pos, 0); #### If we detected a new EOF ... unless (defined $text) { $self->{LG} = $self->{CRPOS}; return undef; } my $lg=length($text); $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG}); $self->{CRPOS} += $lg; return substr($text, 0,$lg); } sub CLOSE { %{$_[0]}=(); } 1; __END__ __END__ =head1 NAME IO::InnerFile - define a file inside another file =head1 SYNOPSIS use strict; use warnings; use IO::InnerFile; # Read a subset of a file: my $fh = _some_file_handle; my $start = 10; my $length = 50; my $inner = IO::InnerFile->new($fh, $start, $length); while (my $line = <$inner>) { # ... } =head1 DESCRIPTION If you have a file handle that can C<seek> and C<tell>, then you can open an L<IO::InnerFile> on a range of the underlying file. =head1 CONSTRUCTORS L<IO::InnerFile> implements the following constructors. =head2 new my $inner = IO::InnerFile->new($fh); $inner = IO::InnerFile->new($fh, 10); $inner = IO::InnerFile->new($fh, 10, 50); Create a new L<IO::InnerFile> opened on the given file handle. The file handle supplied B<MUST> be able to both C<seek> and C<tell>. The second and third parameters are start and length. Both are defaulted to zero (C<0>). Negative values are silently coerced to zero. =head1 METHODS L<IO::InnerFile> implements the following methods. =head2 add_length $inner->add_length(30); Add to the virtual length of the inner file by the number given in bytes. =head2 add_start $inner->add_start(30); Add to the virtual position of the inner file by the number given in bytes. =head2 binmode $inner->binmode(); This is a NOOP method just to satisfy the normal L<IO::File> interface. =head2 close =head2 fileno $inner->fileno(); This is a NOOP method just to satisfy the normal L<IO::File> interface. =head2 flush $inner->flush(); This is a NOOP method just to satisfy the normal L<IO::File> interface. =head2 get_end my $num_bytes = $inner->get_end(); Get the virtual end position of the inner file in bytes. =head2 get_length my $num_bytes = $inner->get_length(); Get the virtual length of the inner file in bytes. =head2 get_start my $num_bytes = $inner->get_start(); Get the virtual position of the inner file in bytes. =head2 getc =head2 getline =head2 print LIST =head2 printf =head2 read =head2 readline =head2 seek =head2 set_end $inner->set_end(30); Set the virtual end of the inner file in bytes (this basically just alters the length). =head2 set_length $inner->set_length(30); Set the virtual length of the inner file in bytes. =head2 set_start $inner->set_start(30); Set the virtual start position of the inner file in bytes. =head2 tell =head2 write =head1 AUTHOR Eryq (F<eryq@zeegee.com>). President, ZeeGee Software Inc (F<http://www.zeegee.com>). =head1 CONTRIBUTORS Dianne Skoll (F<dfs@roaringpenguin.com>). =head1 COPYRIGHT & LICENSE Copyright (c) 1997 Erik (Eryq) Dorfman, ZeeGee Software, Inc. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl5/Expect.pm 0000444 00000304137 14711220304 0007361 0 ustar 00 # -*-cperl-*- # This module is copyrighted as per the usual perl legalese: # Copyright (c) 1997 Austin Schutz. # expect() interface & functionality enhancements (c) 1999 Roland Giersig. # # All rights reserved. This program is free software; you can # redistribute it and/or modify it under the same terms as Perl # itself. # # Don't blame/flame me if you bust your stuff. # Austin Schutz <ASchutz@users.sourceforge.net> # # This module now is maintained by # Dave Jacoby <jacoby@cpan.org> # use 5.006; package Expect; use strict; use warnings; use IO::Pty 1.11; # We need make_slave_controlling_terminal() use IO::Tty; use POSIX qw(:sys_wait_h :unistd_h); # For WNOHANG and isatty use Fcntl qw(:DEFAULT); # For checking file handle settings. use Carp qw(cluck croak carp confess); use IO::Handle (); use Exporter qw(import); use Errno; # This is necessary to make routines within Expect work. @Expect::ISA = qw(IO::Pty); @Expect::EXPORT = qw(expect exp_continue exp_continue_timeout); BEGIN { $Expect::VERSION = '1.35'; # These are defaults which may be changed per object, or set as # the user wishes. # This will be unset, since the default behavior differs between # spawned processes and initialized filehandles. # $Expect::Log_Stdout = 1; $Expect::Log_Group = 1; $Expect::Debug = 0; $Expect::Exp_Max_Accum = 0; # unlimited $Expect::Exp_Internal = 0; $Expect::IgnoreEintr = 0; $Expect::Manual_Stty = 0; $Expect::Multiline_Matching = 1; $Expect::Do_Soft_Close = 0; @Expect::Before_List = (); @Expect::After_List = (); %Expect::Spawned_PIDs = (); } sub version { my ($version) = @_; warn "Version $version is later than $Expect::VERSION. It may not be supported" if ( defined($version) && ( $version > $Expect::VERSION ) ); die "Versions before 1.03 are not supported in this release" if ( ( defined($version) ) && ( $version < 1.03 ) ); return $Expect::VERSION; } sub new { my ($class, @args) = @_; $class = ref($class) if ref($class); # so we can be called as $exp->new() # Create the pty which we will use to pass process info. my ($self) = IO::Pty->new; die "$class: Could not assign a pty" unless $self; bless $self => $class; $self->autoflush(1); # This is defined here since the default is different for # initialized handles as opposed to spawned processes. ${*$self}{exp_Log_Stdout} = 1; $self->_init_vars(); if (@args) { # we got add'l parms, so pass them to spawn return $self->spawn(@args); } return $self; } sub spawn { my ($class, @cmd) = @_; # spawn is passed command line args. my $self; if ( ref($class) ) { $self = $class; } else { $self = $class->new(); } croak "Cannot reuse an object with an already spawned command" if exists ${*$self}{"exp_Command"}; ${*$self}{"exp_Command"} = \@cmd; # set up pipe to detect childs exec error pipe( FROM_CHILD, TO_PARENT ) or die "Cannot open pipe: $!"; pipe( FROM_PARENT, TO_CHILD ) or die "Cannot open pipe: $!"; TO_PARENT->autoflush(1); TO_CHILD->autoflush(1); eval { fcntl( TO_PARENT, Fcntl::F_SETFD, Fcntl::FD_CLOEXEC ); }; my $pid = fork; unless ( defined($pid) ) { warn "Cannot fork: $!" if $^W; return; } if ($pid) { # parent my $errno; ${*$self}{exp_Pid} = $pid; close TO_PARENT; close FROM_PARENT; $self->close_slave(); $self->set_raw() if $self->raw_pty and isatty($self); close TO_CHILD; # so child gets EOF and can go ahead # now wait for child exec (eof due to close-on-exit) or exec error my $errstatus = sysread( FROM_CHILD, $errno, 256 ); die "Cannot sync with child: $!" if not defined $errstatus; close FROM_CHILD; if ($errstatus) { $! = $errno + 0; warn "Cannot exec(@cmd): $!\n" if $^W; return; } } else { # child close FROM_CHILD; close TO_CHILD; $self->make_slave_controlling_terminal(); my $slv = $self->slave() or die "Cannot get slave: $!"; $slv->set_raw() if $self->raw_pty; close($self); # wait for parent before we detach my $buffer; my $errstatus = sysread( FROM_PARENT, $buffer, 256 ); die "Cannot sync with parent: $!" if not defined $errstatus; close FROM_PARENT; close(STDIN); open( STDIN, "<&" . $slv->fileno() ) or die "Couldn't reopen STDIN for reading, $!\n"; close(STDOUT); open( STDOUT, ">&" . $slv->fileno() ) or die "Couldn't reopen STDOUT for writing, $!\n"; close(STDERR); open( STDERR, ">&" . $slv->fileno() ) or die "Couldn't reopen STDERR for writing, $!\n"; { exec(@cmd) }; print TO_PARENT $! + 0; die "Cannot exec(@cmd): $!\n"; } # This is sort of for code compatibility, and to make debugging a little # easier. By code compatibility I mean that previously the process's # handle was referenced by $process{Pty_Handle} instead of just $process. # This is almost like 'naming' the handle to the process. # I think this also reflects Tcl Expect-like behavior. ${*$self}{exp_Pty_Handle} = "spawn id(" . $self->fileno() . ")"; if ( ( ${*$self}{"exp_Debug"} ) or ( ${*$self}{"exp_Exp_Internal"} ) ) { cluck( "Spawned '@cmd'\r\n", "\t${*$self}{exp_Pty_Handle}\r\n", "\tPid: ${*$self}{exp_Pid}\r\n", "\tTty: " . $self->SUPER::ttyname() . "\r\n", ); } $Expect::Spawned_PIDs{ ${*$self}{exp_Pid} } = undef; return $self; } sub exp_init { my ($class, $self) = @_; # take a filehandle, for use later with expect() or interconnect() . # All the functions are written for reading from a tty, so if the naming # scheme looks odd, that's why. bless $self, $class; croak "exp_init not passed a file object, stopped" unless defined( $self->fileno() ); $self->autoflush(1); # Define standard variables.. debug states, etc. $self->_init_vars(); # Turn of logging. By default we don't want crap from a file to get spewed # on screen as we read it. ${*$self}{exp_Log_Stdout} = 0; ${*$self}{exp_Pty_Handle} = "handle id(" . $self->fileno() . ")"; ${*$self}{exp_Pty_Handle} = "STDIN" if $self->fileno() == fileno(STDIN); print STDERR "Initialized ${*$self}{exp_Pty_Handle}.'\r\n" if ${*$self}{"exp_Debug"}; return $self; } # make an alias *init = \&exp_init; ###################################################################### # We're happy OOP people. No direct access to stuff. # For standard read-writeable parameters, we define some autoload magic... my %Writeable_Vars = ( debug => 'exp_Debug', exp_internal => 'exp_Exp_Internal', do_soft_close => 'exp_Do_Soft_Close', max_accum => 'exp_Max_Accum', match_max => 'exp_Max_Accum', notransfer => 'exp_NoTransfer', log_stdout => 'exp_Log_Stdout', log_user => 'exp_Log_Stdout', log_group => 'exp_Log_Group', manual_stty => 'exp_Manual_Stty', restart_timeout_upon_receive => 'exp_Continue', raw_pty => 'exp_Raw_Pty', ); my %Readable_Vars = ( pid => 'exp_Pid', exp_pid => 'exp_Pid', exp_match_number => 'exp_Match_Number', match_number => 'exp_Match_Number', exp_error => 'exp_Error', error => 'exp_Error', exp_command => 'exp_Command', command => 'exp_Command', exp_match => 'exp_Match', match => 'exp_Match', exp_matchlist => 'exp_Matchlist', matchlist => 'exp_Matchlist', exp_before => 'exp_Before', before => 'exp_Before', exp_after => 'exp_After', after => 'exp_After', exp_exitstatus => 'exp_Exit', exitstatus => 'exp_Exit', exp_pty_handle => 'exp_Pty_Handle', pty_handle => 'exp_Pty_Handle', exp_logfile => 'exp_Log_File', logfile => 'exp_Log_File', %Writeable_Vars, ); sub AUTOLOAD { my ($self, @args) = @_; my $type = ref($self) or croak "$self is not an object"; use vars qw($AUTOLOAD); my $name = $AUTOLOAD; $name =~ s/.*:://; # strip fully-qualified portion unless ( exists $Readable_Vars{$name} ) { croak "ERROR: cannot find method `$name' in class $type"; } my $varname = $Readable_Vars{$name}; my $tmp; $tmp = ${*$self}{$varname} if exists ${*$self}{$varname}; if (@args) { if ( exists $Writeable_Vars{$name} ) { my $ref = ref($tmp); if ( $ref eq 'ARRAY' ) { ${*$self}{$varname} = [@args]; } elsif ( $ref eq 'HASH' ) { ${*$self}{$varname} = {@args}; } else { ${*$self}{$varname} = shift @args; } } else { carp "Trying to set read-only variable `$name'" if $^W; } } my $ref = ref($tmp); return ( wantarray ? @{$tmp} : $tmp ) if ( $ref eq 'ARRAY' ); return ( wantarray ? %{$tmp} : $tmp ) if ( $ref eq 'HASH' ); return $tmp; } ###################################################################### sub set_seq { my ( $self, $escape_sequence, $function, $params, @args ) = @_; # Set an escape sequence/function combo for a read handle for interconnect. # Ex: $read_handle->set_seq('',\&function,\@parameters); ${ ${*$self}{exp_Function} }{$escape_sequence} = $function; if ( ( !defined($function) ) || ( $function eq 'undef' ) ) { ${ ${*$self}{exp_Function} }{$escape_sequence} = \&_undef; } ${ ${*$self}{exp_Parameters} }{$escape_sequence} = $params; # This'll be a joy to execute. :) if ( ${*$self}{"exp_Debug"} ) { print STDERR "Escape seq. '" . $escape_sequence; print STDERR "' function for ${*$self}{exp_Pty_Handle} set to '"; print STDERR ${ ${*$self}{exp_Function} }{$escape_sequence}; print STDERR "(" . join( ',', @args ) . ")'\r\n"; } } sub set_group { my ($self, @args) = @_; # Make sure we can read from the read handle if ( !defined( $args[0] ) ) { if ( defined( ${*$self}{exp_Listen_Group} ) ) { return @{ ${*$self}{exp_Listen_Group} }; } else { # Refrain from referencing an undef return; } } @{ ${*$self}{exp_Listen_Group} } = (); if ( $self->_get_mode() !~ 'r' ) { warn( "Attempting to set a handle group on ${*$self}{exp_Pty_Handle}, ", "a non-readable handle!\r\n" ); } while ( my $write_handle = shift @args ) { if ( $write_handle->_get_mode() !~ 'w' ) { warn( "Attempting to set a non-writeable listen handle ", "${*$write_handle}{exp_Pty_handle} for ", "${*$self}{exp_Pty_Handle}!\r\n" ); } push( @{ ${*$self}{exp_Listen_Group} }, $write_handle ); } } sub log_file { my ($self, $file, $mode) = @_; $mode ||= "a"; return ( ${*$self}{exp_Log_File} ) if @_ < 2; # we got no param, return filehandle # $e->log_file(undef) is an acceptable call hence we need to check the number of parameters here if ( ${*$self}{exp_Log_File} and ref( ${*$self}{exp_Log_File} ) ne 'CODE' ) { close( ${*$self}{exp_Log_File} ); } ${*$self}{exp_Log_File} = undef; return if ( not $file ); my $fh = $file; if ( not ref($file) ) { # it's a filename $fh = IO::File->new( $file, $mode ) or croak "Cannot open logfile $file: $!"; } if ( ref($file) ne 'CODE' ) { croak "Given logfile doesn't have a 'print' method" if not $fh->can("print"); $fh->autoflush(1); # so logfile is up to date } ${*$self}{exp_Log_File} = $fh; return $fh; } # I'm going to leave this here in case I might need to change something. # Previously this was calling `stty`, in a most bastardized manner. sub exp_stty { my ($self) = shift; my ($mode) = "@_"; return unless defined $mode; if ( not defined $INC{"IO/Stty.pm"} ) { carp "IO::Stty not installed, cannot change mode"; return; } if ( ${*$self}{"exp_Debug"} ) { print STDERR "Setting ${*$self}{exp_Pty_Handle} to tty mode '$mode'\r\n"; } unless ( POSIX::isatty($self) ) { if ( ${*$self}{"exp_Debug"} or $^W ) { warn "${*$self}{exp_Pty_Handle} is not a tty. Not changing mode"; } return ''; # No undef to avoid warnings elsewhere. } IO::Stty::stty( $self, split( /\s/, $mode ) ); } *stty = \&exp_stty; # If we want to clear the buffer. Otherwise Accum will grow during send_slow # etc. and contain the remainder after matches. sub clear_accum { my ($self) = @_; return $self->set_accum(''); } sub set_accum { my ($self, $accum) = @_; my $old_accum = ${*$self}{exp_Accum}; ${*$self}{exp_Accum} = $accum; # return the contents of the accumulator. return $old_accum; } sub get_accum { my ($self) = @_; return ${*$self}{exp_Accum}; } ###################################################################### # define constants for pattern subs sub exp_continue {"exp_continue"} sub exp_continue_timeout {"exp_continue_timeout"} ###################################################################### # Expect on multiple objects at once. # # Call as Expect::expect($timeout, -i => \@exp_list, @patternlist, # -i => $exp, @pattern_list, ...); # or $exp->expect($timeout, @patternlist, -i => \@exp_list, @patternlist, # -i => $exp, @pattern_list, ...); # # Patterns are arrays that consist of # [ $pattern_type, $pattern, $sub, @subparms ] # # Optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); # # $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) # if pattern matched; may return exp_continue or exp_continue_timeout. # # Old-style syntax (pure pattern strings with optional type) also supported. # sub expect { my $self; print STDERR ("expect(@_) called...\n") if $Expect::Debug; if ( defined( $_[0] ) ) { if ( ref( $_[0] ) and $_[0]->isa('Expect') ) { $self = shift; } elsif ( $_[0] eq 'Expect' ) { shift; # or as Expect->expect } } croak "expect(): not enough arguments, should be expect(timeout, [patterns...])" if @_ < 1; my $timeout = shift; my $timeout_hook = undef; my @object_list; my %patterns; my @pattern_list; my @timeout_list; my $curr_list; if ($self) { $curr_list = [$self]; } else { # called directly, so first parameter must be '-i' to establish # object list. $curr_list = []; croak "expect(): ERROR: if called directly (not as \$obj->expect(...), but as Expect::expect(...), first parameter MUST be '-i' to set an object (list) for the patterns to work on." if ( $_[0] ne '-i' ); } # Let's make a list of patterns wanting to be evaled as regexps. my $parm; my $parm_nr = 1; while ( defined( $parm = shift ) ) { print STDERR ("expect(): handling param '$parm'...\n") if $Expect::Debug; if ( ref($parm) ) { if ( ref($parm) eq 'ARRAY' ) { my $err = _add_patterns_to_list( \@pattern_list, \@timeout_list, $parm_nr, $parm ); carp( "expect(): Warning: multiple `timeout' patterns (", scalar(@timeout_list), ").\r\n" ) if @timeout_list > 1; $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; croak $err if $err; $parm_nr++; } else { croak("expect(): Unknown pattern ref $parm"); } } else { # not a ref, is an option or raw pattern if ( substr( $parm, 0, 1 ) eq '-' ) { # it's an option print STDERR ("expect(): handling option '$parm'...\n") if $Expect::Debug; if ( $parm eq '-i' ) { # first add collected patterns to object list if ( scalar(@$curr_list) ) { push @object_list, $curr_list if not exists $patterns{"$curr_list"}; push @{ $patterns{"$curr_list"} }, @pattern_list; @pattern_list = (); } # now put parm(s) into current object list if ( ref( $_[0] ) eq 'ARRAY' ) { $curr_list = shift; } else { $curr_list = [shift]; } } elsif ( $parm eq '-re' or $parm eq '-ex' ) { if ( ref( $_[1] ) eq 'CODE' ) { push @pattern_list, [ $parm_nr, $parm, shift, shift ]; } else { push @pattern_list, [ $parm_nr, $parm, shift, undef ]; } $parm_nr++; } else { croak("Unknown option $parm"); } } else { # a plain pattern, check if it is followed by a CODE ref if ( ref( $_[0] ) eq 'CODE' ) { if ( $parm eq 'timeout' ) { push @timeout_list, shift; carp( "expect(): Warning: multiple `timeout' patterns (", scalar(@timeout_list), ").\r\n" ) if @timeout_list > 1; $timeout_hook = $timeout_list[-1] if $timeout_list[-1]; } elsif ( $parm eq 'eof' ) { push @pattern_list, [ $parm_nr, "-$parm", undef, shift ]; } else { push @pattern_list, [ $parm_nr, '-ex', $parm, shift ]; } } else { print STDERR ("expect(): exact match '$parm'...\n") if $Expect::Debug; push @pattern_list, [ $parm_nr, '-ex', $parm, undef ]; } $parm_nr++; } } } # add rest of collected patterns to object list carp "expect(): Empty object list" unless $curr_list; push @object_list, $curr_list if not exists $patterns{"$curr_list"}; push @{ $patterns{"$curr_list"} }, @pattern_list; my $debug = $self ? ${*$self}{exp_Debug} : $Expect::Debug; my $internal = $self ? ${*$self}{exp_Exp_Internal} : $Expect::Exp_Internal; # now start matching... if (@Expect::Before_List) { print STDERR ("Starting BEFORE pattern matching...\r\n") if ( $debug or $internal ); _multi_expect( 0, undef, @Expect::Before_List ); } cluck("Starting EXPECT pattern matching...\r\n") if ( $debug or $internal ); my @ret; @ret = _multi_expect( $timeout, $timeout_hook, map { [ $_, @{ $patterns{"$_"} } ] } @object_list ); if (@Expect::After_List) { print STDERR ("Starting AFTER pattern matching...\r\n") if ( $debug or $internal ); _multi_expect( 0, undef, @Expect::After_List ); } return wantarray ? @ret : $ret[0]; } ###################################################################### # the real workhorse # sub _multi_expect { my ($timeout, $timeout_hook, @params) = @_; if ($timeout_hook) { croak "Unknown timeout_hook type $timeout_hook" unless ( ref($timeout_hook) eq 'CODE' or ref($timeout_hook) eq 'ARRAY' ); } foreach my $pat (@params) { my @patterns = @{$pat}[ 1 .. $#{$pat} ]; foreach my $exp ( @{ $pat->[0] } ) { ${*$exp}{exp_New_Data} = 1; # first round we always try to match if ( exists ${*$exp}{"exp_Max_Accum"} and ${*$exp}{"exp_Max_Accum"} ) { ${*$exp}{exp_Accum} = $exp->_trim_length( ${*$exp}{exp_Accum}, ${*$exp}{exp_Max_Accum} ); } print STDERR ( "${*$exp}{exp_Pty_Handle}: beginning expect.\r\n", "\tTimeout: ", ( defined($timeout) ? $timeout : "unlimited" ), " seconds.\r\n", "\tCurrent time: " . localtime() . "\r\n", ) if $Expect::Debug; # What are we expecting? What do you expect? :-) if ( ${*$exp}{exp_Exp_Internal} ) { print STDERR "${*$exp}{exp_Pty_Handle}: list of patterns:\r\n"; foreach my $pattern (@patterns) { print STDERR ( ' ', defined( $pattern->[0] ) ? '#' . $pattern->[0] . ': ' : '', $pattern->[1], " `", _make_readable( $pattern->[2] ), "'\r\n" ); } print STDERR "\r\n"; } } } my $successful_pattern; my $exp_matched; my $err; my $before; my $after; my $match; my @matchlist; # Set the last loop time to now for time comparisons at end of loop. my $start_loop_time = time(); my $exp_cont = 1; READLOOP: while ($exp_cont) { $exp_cont = 1; $err = ""; my $rmask = ''; my $time_left = undef; if ( defined $timeout ) { $time_left = $timeout - ( time() - $start_loop_time ); $time_left = 0 if $time_left < 0; } $exp_matched = undef; # Test for a match first so we can test the current Accum w/out # worrying about an EOF. foreach my $pat (@params) { my @patterns = @{$pat}[ 1 .. $#{$pat} ]; foreach my $exp ( @{ $pat->[0] } ) { # build mask for select in next section... my $fn = $exp->fileno(); vec( $rmask, $fn, 1 ) = 1 if defined $fn; next unless ${*$exp}{exp_New_Data}; # clear error status ${*$exp}{exp_Error} = undef; ${*$exp}{exp_After} = undef; ${*$exp}{exp_Match_Number} = undef; ${*$exp}{exp_Match} = undef; # This could be huge. We should attempt to do something # about this. Because the output is used for debugging # I'm of the opinion that showing smaller amounts if the # total is huge should be ok. # Thus the 'trim_length' print STDERR ( "\r\n${*$exp}{exp_Pty_Handle}: Does `", $exp->_trim_length( _make_readable( ${*$exp}{exp_Accum} ) ), "'\r\nmatch:\r\n" ) if ${*$exp}{exp_Exp_Internal}; # we don't keep the parameter number anymore # (clashes with before & after), instead the parameter number is # stored inside the pattern; we keep the pattern ref # and look up the number later. foreach my $pattern (@patterns) { print STDERR ( " pattern", defined( $pattern->[0] ) ? ' #' . $pattern->[0] : '', ": ", $pattern->[1], " `", _make_readable( $pattern->[2] ), "'? " ) if ( ${*$exp}{exp_Exp_Internal} ); # Matching exactly if ( $pattern->[1] eq '-ex' ) { my $match_index = index( ${*$exp}{exp_Accum}, $pattern->[2] ); # We matched if $match_index > -1 if ( $match_index > -1 ) { $before = substr( ${*$exp}{exp_Accum}, 0, $match_index ); $match = substr( ${*$exp}{exp_Accum}, $match_index, length( $pattern->[2] ) ); $after = substr( ${*$exp}{exp_Accum}, $match_index + length( $pattern->[2] ) ); ${*$exp}{exp_Before} = $before; ${*$exp}{exp_Match} = $match; ${*$exp}{exp_After} = $after; ${*$exp}{exp_Match_Number} = $pattern->[0]; $exp_matched = $exp; } } elsif ( $pattern->[1] eq '-re' ) { if ($Expect::Multiline_Matching) { @matchlist = ( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/m); } else { @matchlist = ( ${*$exp}{exp_Accum} =~ m/($pattern->[2])/); } if (@matchlist) { # Matching regexp $match = shift @matchlist; my $start = index ${*$exp}{exp_Accum}, $match; die 'The match could not be found' if $start == -1; $before = substr ${*$exp}{exp_Accum}, 0, $start; $after = substr ${*$exp}{exp_Accum}, $start + length($match); ${*$exp}{exp_Before} = $before; ${*$exp}{exp_Match} = $match; ${*$exp}{exp_After} = $after; #pop @matchlist; # remove kludged empty bracket from end @{ ${*$exp}{exp_Matchlist} } = @matchlist; ${*$exp}{exp_Match_Number} = $pattern->[0]; $exp_matched = $exp; } } else { # 'timeout' or 'eof' } if ($exp_matched) { ${*$exp}{exp_Accum} = $after unless ${*$exp}{exp_NoTransfer}; print STDERR "YES!!\r\n" if ${*$exp}{exp_Exp_Internal}; print STDERR ( " Before match string: `", $exp->_trim_length( _make_readable( ($before) ) ), "'\r\n", " Match string: `", _make_readable($match), "'\r\n", " After match string: `", $exp->_trim_length( _make_readable( ($after) ) ), "'\r\n", " Matchlist: (", join( ", ", map { "`" . $exp->_trim_length( _make_readable( ($_) ) ) . "'" } @matchlist, ), ")\r\n", ) if ( ${*$exp}{exp_Exp_Internal} ); # call hook function if defined if ( $pattern->[3] ) { print STDERR ( "Calling hook $pattern->[3]...\r\n", ) if ( ${*$exp}{exp_Exp_Internal} or $Expect::Debug ); if ( $#{$pattern} > 3 ) { # call with parameters if given $exp_cont = &{ $pattern->[3] }( $exp, @{$pattern}[ 4 .. $#{$pattern} ] ); } else { $exp_cont = &{ $pattern->[3] }($exp); } } if ( $exp_cont and $exp_cont eq exp_continue ) { print STDERR ("Continuing expect, restarting timeout...\r\n") if ( ${*$exp}{exp_Exp_Internal} or $Expect::Debug ); $start_loop_time = time(); # restart timeout count next READLOOP; } elsif ( $exp_cont and $exp_cont eq exp_continue_timeout ) { print STDERR ("Continuing expect...\r\n") if ( ${*$exp}{exp_Exp_Internal} or $Expect::Debug ); next READLOOP; } last READLOOP; } print STDERR "No.\r\n" if ${*$exp}{exp_Exp_Internal}; } print STDERR "\r\n" if ${*$exp}{exp_Exp_Internal}; # don't have to match again until we get new data ${*$exp}{exp_New_Data} = 0; } } # End of matching section # No match, let's see what is pending on the filehandles... print STDERR ( "Waiting for new data (", defined($time_left) ? $time_left : 'unlimited', " seconds)...\r\n", ) if ( $Expect::Exp_Internal or $Expect::Debug ); my $nfound; SELECT: { $nfound = select( $rmask, undef, undef, $time_left ); if ( $nfound < 0 ) { if ( $!{EINTR} and $Expect::IgnoreEintr ) { print STDERR ("ignoring EINTR, restarting select()...\r\n") if ( $Expect::Exp_Internal or $Expect::Debug ); next SELECT; } print STDERR ("select() returned error code '$!'\r\n") if ( $Expect::Exp_Internal or $Expect::Debug ); # returned error $err = "4:$!"; last READLOOP; } } # go until we don't find something (== timeout). if ( $nfound == 0 ) { # No pattern, no EOF. Did we time out? $err = "1:TIMEOUT"; foreach my $pat (@params) { foreach my $exp ( @{ $pat->[0] } ) { $before = ${*$exp}{exp_Before} = ${*$exp}{exp_Accum}; next if not defined $exp->fileno(); # skip already closed ${*$exp}{exp_Error} = $err unless ${*$exp}{exp_Error}; } } print STDERR ("TIMEOUT\r\n") if ( $Expect::Debug or $Expect::Exp_Internal ); if ($timeout_hook) { my $ret; print STDERR ("Calling timeout function $timeout_hook...\r\n") if ( $Expect::Debug or $Expect::Exp_Internal ); if ( ref($timeout_hook) eq 'CODE' ) { $ret = &{$timeout_hook}( $params[0]->[0] ); } else { if ( $#{$timeout_hook} > 3 ) { $ret = &{ $timeout_hook->[3] }( $params[0]->[0], @{$timeout_hook}[ 4 .. $#{$timeout_hook} ] ); } else { $ret = &{ $timeout_hook->[3] }( $params[0]->[0] ); } } if ( $ret and $ret eq exp_continue ) { $start_loop_time = time(); # restart timeout count next READLOOP; } } last READLOOP; } my @bits = split( //, unpack( 'b*', $rmask ) ); foreach my $pat (@params) { foreach my $exp ( @{ $pat->[0] } ) { next if not defined $exp->fileno(); # skip already closed if ( $bits[ $exp->fileno() ] ) { print STDERR ("${*$exp}{exp_Pty_Handle}: new data.\r\n") if $Expect::Debug; # read in what we found. my $buffer; my $nread = sysread( $exp, $buffer, 2048 ); # Make errors (nread undef) show up as EOF. $nread = 0 unless defined($nread); if ( $nread == 0 ) { print STDERR ("${*$exp}{exp_Pty_Handle}: EOF\r\n") if ($Expect::Debug); $before = ${*$exp}{exp_Before} = $exp->clear_accum(); $err = "2:EOF"; ${*$exp}{exp_Error} = $err; ${*$exp}{exp_Has_EOF} = 1; $exp_cont = undef; foreach my $eof_pat ( grep { $_->[1] eq '-eof' } @{$pat}[ 1 .. $#{$pat} ] ) { my $ret; print STDERR ( "Calling EOF hook $eof_pat->[3]...\r\n", ) if ($Expect::Debug); if ( $#{$eof_pat} > 3 ) { # call with parameters if given $ret = &{ $eof_pat->[3] }( $exp, @{$eof_pat}[ 4 .. $#{$eof_pat} ] ); } else { $ret = &{ $eof_pat->[3] }($exp); } if ($ret and ( $ret eq exp_continue or $ret eq exp_continue_timeout ) ) { $exp_cont = $ret; } } # is it dead? if ( defined( ${*$exp}{exp_Pid} ) ) { my $ret = waitpid( ${*$exp}{exp_Pid}, POSIX::WNOHANG ); if ( $ret == ${*$exp}{exp_Pid} ) { printf STDERR ( "%s: exit(0x%02X)\r\n", ${*$exp}{exp_Pty_Handle}, $? ) if ($Expect::Debug); $err = "3:Child PID ${*$exp}{exp_Pid} exited with status $?"; ${*$exp}{exp_Error} = $err; ${*$exp}{exp_Exit} = $?; delete $Expect::Spawned_PIDs{ ${*$exp}{exp_Pid} }; ${*$exp}{exp_Pid} = undef; } } print STDERR ("${*$exp}{exp_Pty_Handle}: closing...\r\n") if ($Expect::Debug); $exp->hard_close(); next; } print STDERR ("${*$exp}{exp_Pty_Handle}: read $nread byte(s).\r\n") if ($Expect::Debug); # ugly hack for broken solaris ttys that spew <blank><backspace> # into our pretty output $buffer =~ s/ \cH//g if not ${*$exp}{exp_Raw_Pty}; # Append it to the accumulator. ${*$exp}{exp_Accum} .= $buffer; if ( exists ${*$exp}{exp_Max_Accum} and ${*$exp}{exp_Max_Accum} ) { ${*$exp}{exp_Accum} = $exp->_trim_length( ${*$exp}{exp_Accum}, ${*$exp}{exp_Max_Accum} ); } ${*$exp}{exp_New_Data} = 1; # next round we try to match again $exp_cont = exp_continue if ( exists ${*$exp}{exp_Continue} and ${*$exp}{exp_Continue} ); # Now propagate what we have read to other listeners... $exp->_print_handles($buffer); # End handle reading section. } } } # end read loop $start_loop_time = time() # restart timeout count if ( $exp_cont and $exp_cont eq exp_continue ); } # End READLOOP # Post loop. Do we have anything? # Tell us status if ( $Expect::Debug or $Expect::Exp_Internal ) { if ($exp_matched) { print STDERR ( "Returning from expect ", ${*$exp_matched}{exp_Error} ? 'un' : '', "successfully.", ${*$exp_matched}{exp_Error} ? "\r\n Error: ${*$exp_matched}{exp_Error}." : '', "\r\n" ); } else { print STDERR ("Returning from expect with TIMEOUT or EOF\r\n"); } if ( $Expect::Debug and $exp_matched ) { print STDERR " ${*$exp_matched}{exp_Pty_Handle}: accumulator: `"; if ( ${*$exp_matched}{exp_Error} ) { print STDERR ( $exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Before} ) ), "'\r\n" ); } else { print STDERR ( $exp_matched->_trim_length( _make_readable( ${*$exp_matched}{exp_Accum} ) ), "'\r\n" ); } } } if ($exp_matched) { return wantarray ? ( ${*$exp_matched}{exp_Match_Number}, ${*$exp_matched}{exp_Error}, ${*$exp_matched}{exp_Match}, ${*$exp_matched}{exp_Before}, ${*$exp_matched}{exp_After}, $exp_matched, ) : ${*$exp_matched}{exp_Match_Number}; } return wantarray ? ( undef, $err, undef, $before, undef, undef ) : undef; } # Patterns are arrays that consist of # [ $pattern_type, $pattern, $sub, @subparms ] # optional $pattern_type is '-re' (RegExp, default) or '-ex' (exact); # $sub is optional CODE ref, which is called as &{$sub}($exp, @subparms) # if pattern matched; # the $parm_nr gets unshifted onto the array for reporting purposes. sub _add_patterns_to_list { my ($listref, $timeoutlistref,$store_parm_nr, @params) = @_; # $timeoutlistref gets timeout patterns my $parm_nr = $store_parm_nr || 1; foreach my $parm (@params) { if ( not ref($parm) eq 'ARRAY' ) { return "Parameter #$parm_nr is not an ARRAY ref."; } $parm = [@$parm]; # make copy if ( $parm->[0] =~ m/\A-/ ) { # it's an option if ( $parm->[0] ne '-re' and $parm->[0] ne '-ex' ) { return "Unknown option $parm->[0] in pattern #$parm_nr"; } } else { if ( $parm->[0] eq 'timeout' ) { if ( defined $timeoutlistref ) { splice @$parm, 0, 1, ( "-$parm->[0]", undef ); unshift @$parm, $store_parm_nr ? $parm_nr : undef; push @$timeoutlistref, $parm; } next; } elsif ( $parm->[0] eq 'eof' ) { splice @$parm, 0, 1, ( "-$parm->[0]", undef ); } else { unshift @$parm, '-re'; # defaults to RegExp } } if ( @$parm > 2 ) { if ( ref( $parm->[2] ) ne 'CODE' ) { croak( "Pattern #$parm_nr doesn't have a CODE reference", "after the pattern." ); } } else { push @$parm, undef; # make sure we have three elements } unshift @$parm, $store_parm_nr ? $parm_nr : undef; push @$listref, $parm; $parm_nr++; } return; } ###################################################################### # $process->interact([$in_handle],[$escape sequence]) # If you don't specify in_handle STDIN will be used. sub interact { my ($self, $infile, $escape_sequence) = @_; my $outfile; my @old_group = $self->set_group(); # If the handle is STDIN we'll # $infile->fileno == 0 should be stdin.. follow stdin rules. no strict 'subs'; # Allow bare word 'STDIN' unless ( defined($infile) ) { # We need a handle object Associated with STDIN. $infile = IO::File->new; $infile->IO::File::fdopen( STDIN, 'r' ); $outfile = IO::File->new; $outfile->IO::File::fdopen( STDOUT, 'w' ); } elsif ( fileno($infile) == fileno(STDIN) ) { # With STDIN we want output to go to stdout. $outfile = IO::File->new; $outfile->IO::File::fdopen( STDOUT, 'w' ); } else { undef($outfile); } # Here we assure ourselves we have an Expect object. my $in_object = Expect->exp_init($infile); if ( defined($outfile) ) { # as above.. we want output to go to stdout if we're given stdin. my $out_object = Expect->exp_init($outfile); $out_object->manual_stty(1); $self->set_group($out_object); } else { $self->set_group($in_object); } $in_object->set_group($self); $in_object->set_seq( $escape_sequence, undef ) if defined($escape_sequence); # interconnect normally sets stty -echo raw. Interact really sort # of implies we don't do that by default. If anyone wanted to they could # set it before calling interact, of use interconnect directly. my $old_manual_stty_val = $self->manual_stty(); $self->manual_stty(1); # I think this is right. Don't send stuff from in_obj to stdout by default. # in theory whatever 'self' is should echo what's going on. my $old_log_stdout_val = $self->log_stdout(); $self->log_stdout(0); $in_object->log_stdout(0); # Allow for the setting of an optional EOF escape function. # $in_object->set_seq('EOF',undef); # $self->set_seq('EOF',undef); Expect::interconnect( $self, $in_object ); $self->log_stdout($old_log_stdout_val); $self->set_group(@old_group); # If old_group was undef, make sure that occurs. This is a slight hack since # it modifies the value directly. # Normally an undef passed to set_group will return the current groups. # It is possible that it may be of worth to make it possible to undef # The current group without doing this. unless (@old_group) { @{ ${*$self}{exp_Listen_Group} } = (); } $self->manual_stty($old_manual_stty_val); return; } sub interconnect { my (@handles) = @_; # my ($handle)=(shift); call as Expect::interconnect($spawn1,$spawn2,...) my ( $nread ); my ( $rout, $emask, $eout ); my ( $escape_character_buffer ); my ( $read_mask, $temp_mask ) = ( '', '' ); # Get read/write handles foreach my $handle (@handles) { $temp_mask = ''; vec( $temp_mask, $handle->fileno(), 1 ) = 1; # Under Linux w/ 5.001 the next line comes up w/ 'Uninit var.'. # It appears to be impossible to make the warning go away. # doing something like $temp_mask='' unless defined ($temp_mask) # has no effect whatsoever. This may be a bug in 5.001. $read_mask = $read_mask | $temp_mask; } if ($Expect::Debug) { print STDERR "Read handles:\r\n"; foreach my $handle (@handles) { print STDERR "\tRead handle: "; print STDERR "'${*$handle}{exp_Pty_Handle}'\r\n"; print STDERR "\t\tListen Handles:"; foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { print STDERR " '${*$write_handle}{exp_Pty_Handle}'"; } print STDERR ".\r\n"; } } # I think if we don't set raw/-echo here we may have trouble. We don't # want a bunch of echoing crap making all the handles jabber at each other. foreach my $handle (@handles) { unless ( ${*$handle}{"exp_Manual_Stty"} ) { # This is probably O/S specific. ${*$handle}{exp_Stored_Stty} = $handle->exp_stty('-g'); print STDERR "Setting tty for ${*$handle}{exp_Pty_Handle} to 'raw -echo'.\r\n" if ${*$handle}{"exp_Debug"}; $handle->exp_stty("raw -echo"); } foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { unless ( ${*$write_handle}{"exp_Manual_Stty"} ) { ${*$write_handle}{exp_Stored_Stty} = $write_handle->exp_stty('-g'); print STDERR "Setting ${*$write_handle}{exp_Pty_Handle} to 'raw -echo'.\r\n" if ${*$handle}{"exp_Debug"}; $write_handle->exp_stty("raw -echo"); } } } print STDERR "Attempting interconnection\r\n" if $Expect::Debug; # Wait until the process dies or we get EOF # In the case of !${*$handle}{exp_Pid} it means # the handle was exp_inited instead of spawned. CONNECT_LOOP: # Go until we have a reason to stop while (1) { # test each handle to see if it's still alive. foreach my $read_handle (@handles) { waitpid( ${*$read_handle}{exp_Pid}, WNOHANG ) if ( exists( ${*$read_handle}{exp_Pid} ) and ${*$read_handle}{exp_Pid} ); if ( exists( ${*$read_handle}{exp_Pid} ) and ( ${*$read_handle}{exp_Pid} ) and ( !kill( 0, ${*$read_handle}{exp_Pid} ) ) ) { print STDERR "Got EOF (${*$read_handle}{exp_Pty_Handle} died) reading ${*$read_handle}{exp_Pty_Handle}\r\n" if ${*$read_handle}{"exp_Debug"}; last CONNECT_LOOP unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); } } # Every second? No, go until we get something from someone. my $nfound = select( $rout = $read_mask, undef, $eout = $emask, undef ); # Is there anything to share? May be -1 if interrupted by a signal... next CONNECT_LOOP if not defined $nfound or $nfound < 1; # Which handles have stuff? my @bits = split( //, unpack( 'b*', $rout ) ); $eout = 0 unless defined($eout); my @ebits = split( //, unpack( 'b*', $eout ) ); # print "Ebits: $eout\r\n"; foreach my $read_handle (@handles) { if ( $bits[ $read_handle->fileno() ] ) { $nread = sysread( $read_handle, ${*$read_handle}{exp_Pty_Buffer}, 1024 ); # Appease perl -w $nread = 0 unless defined($nread); print STDERR "interconnect: read $nread byte(s) from ${*$read_handle}{exp_Pty_Handle}.\r\n" if ${*$read_handle}{"exp_Debug"} > 1; # Test for escape seq. before printing. # Appease perl -w $escape_character_buffer = '' unless defined($escape_character_buffer); $escape_character_buffer .= ${*$read_handle}{exp_Pty_Buffer}; foreach my $escape_sequence ( keys( %{ ${*$read_handle}{exp_Function} } ) ) { print STDERR "Tested escape sequence $escape_sequence from ${*$read_handle}{exp_Pty_Handle}" if ${*$read_handle}{"exp_Debug"} > 1; # Make sure it doesn't grow out of bounds. $escape_character_buffer = $read_handle->_trim_length( $escape_character_buffer, ${*$read_handle}{"exp_Max_Accum"} ) if ( ${*$read_handle}{"exp_Max_Accum"} ); if ( $escape_character_buffer =~ /($escape_sequence)/ ) { my $match = $1; if ( ${*$read_handle}{"exp_Debug"} ) { print STDERR "\r\ninterconnect got escape sequence from ${*$read_handle}{exp_Pty_Handle}.\r\n"; # I'm going to make the esc. seq. pretty because it will # probably contain unprintable characters. print STDERR "\tEscape Sequence: '" . _trim_length( undef, _make_readable($escape_sequence) ) . "'\r\n"; print STDERR "\tMatched by string: '" . _trim_length( undef, _make_readable($match) ) . "'\r\n"; } # Print out stuff before the escape. # Keep in mind that the sequence may have been split up # over several reads. # Let's get rid of it from this read. If part of it was # in the last read there's not a lot we can do about it now. if ( ${*$read_handle}{exp_Pty_Buffer} =~ /([\w\W]*)($escape_sequence)/ ) { $read_handle->_print_handles($1); } else { $read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} ); } # Clear the buffer so no more matches can be made and it will # only be printed one time. ${*$read_handle}{exp_Pty_Buffer} = ''; $escape_character_buffer = ''; # Do the function here. Must return non-zero to continue. # More cool syntax. Maybe I should turn these in to objects. last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{$escape_sequence} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{$escape_sequence} } ); } } $nread = 0 unless defined($nread); # Appease perl -w? waitpid( ${*$read_handle}{exp_Pid}, WNOHANG ) if ( defined( ${*$read_handle}{exp_Pid} ) && ${*$read_handle}{exp_Pid} ); if ( $nread == 0 ) { print STDERR "Got EOF reading ${*$read_handle}{exp_Pty_Handle}\r\n" if ${*$read_handle}{"exp_Debug"}; last CONNECT_LOOP unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); } last CONNECT_LOOP if ( $nread < 0 ); # This would be an error $read_handle->_print_handles( ${*$read_handle}{exp_Pty_Buffer} ); } # I'm removing this because I haven't determined what causes exceptions # consistently. if (0) #$ebits[$read_handle->fileno()]) { print STDERR "Got Exception reading ${*$read_handle}{exp_Pty_Handle}\r\n" if ${*$read_handle}{"exp_Debug"}; last CONNECT_LOOP unless defined( ${ ${*$read_handle}{exp_Function} }{"EOF"} ); last CONNECT_LOOP unless &{ ${ ${*$read_handle}{exp_Function} }{"EOF"} } ( @{ ${ ${*$read_handle}{exp_Parameters} }{"EOF"} } ); } } } foreach my $handle (@handles) { unless ( ${*$handle}{"exp_Manual_Stty"} ) { $handle->exp_stty( ${*$handle}{exp_Stored_Stty} ); } foreach my $write_handle ( @{ ${*$handle}{exp_Listen_Group} } ) { unless ( ${*$write_handle}{"exp_Manual_Stty"} ) { $write_handle->exp_stty( ${*$write_handle}{exp_Stored_Stty} ); } } } return; } # user can decide if log output gets also sent to logfile sub print_log_file { my ($self, @params) = @_; if ( ${*$self}{exp_Log_File} ) { if ( ref( ${*$self}{exp_Log_File} ) eq 'CODE' ) { ${*$self}{exp_Log_File}->(@params); } else { ${*$self}{exp_Log_File}->print(@params); } } return; } # we provide our own print so we can debug what gets sent to the # processes... sub print { my ( $self, @args ) = @_; return if not defined $self->fileno(); # skip if closed if ( ${*$self}{exp_Exp_Internal} ) { my $args = _make_readable( join( '', @args ) ); cluck "Sending '$args' to ${*$self}{exp_Pty_Handle}\r\n"; } foreach my $arg (@args) { while ( length($arg) > 80 ) { $self->SUPER::print( substr( $arg, 0, 80 ) ); $arg = substr( $arg, 80 ); } $self->SUPER::print($arg); } return; } # make an alias for Tcl/Expect users for a DWIM experience... *send = \&print; # This is an Expect standard. It's nice for talking to modems and the like # where from time to time they get unhappy if you send items too quickly. sub send_slow { my ($self, $sleep_time, @chunks) = @_; return if not defined $self->fileno(); # skip if closed # Flushing makes it so each character can be seen separately. my $chunk; while ( $chunk = shift @chunks ) { my @linechars = split( '', $chunk ); foreach my $char (@linechars) { # How slow? select( undef, undef, undef, $sleep_time ); print $self $char; print STDERR "Printed character \'" . _make_readable($char) . "\' to ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{"exp_Debug"} > 1; # I think I can get away with this if I save it in accum if ( ${*$self}{"exp_Log_Stdout"} || ${*$self}{exp_Log_Group} ) { my $rmask = ""; vec( $rmask, $self->fileno(), 1 ) = 1; # .01 sec granularity should work. If we miss something it will # probably get flushed later, maybe in an expect call. while ( select( $rmask, undef, undef, .01 ) ) { my $ret = sysread( $self, ${*$self}{exp_Pty_Buffer}, 1024 ); last if not defined $ret or $ret == 0; # Is this necessary to keep? Probably.. # # if you need to expect it later. ${*$self}{exp_Accum} .= ${*$self}{exp_Pty_Buffer}; ${*$self}{exp_Accum} = $self->_trim_length( ${*$self}{exp_Accum}, ${*$self}{"exp_Max_Accum"} ) if ( ${*$self}{"exp_Max_Accum"} ); $self->_print_handles( ${*$self}{exp_Pty_Buffer} ); print STDERR "Received \'" . $self->_trim_length( _make_readable($char) ) . "\' from ${*$self}{exp_Pty_Handle}\r\n" if ${*$self}{"exp_Debug"} > 1; } } } } return; } sub test_handles { my ($timeout, @handle_list) = @_; # This should be called by Expect::test_handles($timeout,@objects); my ( $allmask, $rout ); foreach my $handle (@handle_list) { my $rmask = ''; vec( $rmask, $handle->fileno(), 1 ) = 1; $allmask = '' unless defined($allmask); $allmask = $allmask | $rmask; } my $nfound = select( $rout = $allmask, undef, undef, $timeout ); return () unless $nfound; # Which handles have stuff? my @bits = split( //, unpack( 'b*', $rout ) ); my $handle_num = 0; my @return_list = (); foreach my $handle (@handle_list) { # I go to great lengths to get perl -w to shut the hell up. if ( defined( $bits[ $handle->fileno() ] ) and ( $bits[ $handle->fileno() ] ) ) { push( @return_list, $handle_num ); } } continue { $handle_num++; } return @return_list; } # Be nice close. This should emulate what an interactive shell does after a # command finishes... sort of. We're not as patient as a shell. sub soft_close { my ($self) = @_; my ( $nfound, $nread, $rmask, $end_time, $temp_buffer ); # Give it 15 seconds to cough up an eof. cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; return -1 if not defined $self->fileno(); # skip if handle already closed unless ( exists ${*$self}{exp_Has_EOF} and ${*$self}{exp_Has_EOF} ) { $end_time = time() + 15; while ( $end_time > time() ) { my $select_time = $end_time - time(); # Sanity check. $select_time = 0 if $select_time < 0; $rmask = ''; vec( $rmask, $self->fileno(), 1 ) = 1; ($nfound) = select( $rmask, undef, undef, $select_time ); last unless ( defined($nfound) && $nfound ); $nread = sysread( $self, $temp_buffer, 8096 ); # 0 = EOF. unless ( defined($nread) && $nread ) { print STDERR "Got EOF from ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; last; } $self->_print_handles($temp_buffer); } if ( ( $end_time <= time() ) && ${*$self}{exp_Debug} ) { print STDERR "Timed out waiting for an EOF from ${*$self}{exp_Pty_Handle}.\r\n"; } } my $close_status = $self->close(); if ( $close_status && ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; } # quit now if it isn't a process. return $close_status unless defined( ${*$self}{exp_Pid} ); # Now give it 15 seconds to die. $end_time = time() + 15; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); # Stop here if the process dies. if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s exited, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; # Keep loop nice. } # Send it a term if it isn't dead. if ( ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; } kill TERM => ${*$self}{exp_Pid}; # Now to be anal retentive.. wait 15 more seconds for it to die. $end_time = time() + 15; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s terminated, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return $?; } sleep 1; } # Since this is a 'soft' close, sending it a -9 would be inappropriate. return; } # 'Make it go away' close. sub hard_close { my ($self) = @_; cluck "Closing ${*$self}{exp_Pty_Handle}.\r\n" if ${*$self}{exp_Debug}; # Don't wait for an EOF. my $close_status = $self->close(); if ( $close_status && ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} closed.\r\n"; } # Return now if handle. return $close_status unless defined( ${*$self}{exp_Pid} ); # Now give it 5 seconds to die. Less patience here if it won't die. my $end_time = time() + 5; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); # Stop here if the process dies. if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s terminated, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; # Keep loop nice. } # Send it a term if it isn't dead. if ( ${*$self}{exp_Debug} ) { print STDERR "${*$self}{exp_Pty_Handle} not exiting, sending TERM.\r\n"; } kill TERM => ${*$self}{exp_Pid}; # wait 15 more seconds for it to die. $end_time = time() + 15; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s terminated, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; } kill KILL => ${*$self}{exp_Pid}; # wait 5 more seconds for it to die. $end_time = time() + 5; while ( $end_time > time() ) { my $returned_pid = waitpid( ${*$self}{exp_Pid}, &WNOHANG ); if ( defined($returned_pid) && $returned_pid ) { delete $Expect::Spawned_PIDs{$returned_pid}; if ( ${*$self}{exp_Debug} ) { printf STDERR ( "Pid %d of %s killed, Status: 0x%02X\r\n", ${*$self}{exp_Pid}, ${*$self}{exp_Pty_Handle}, $? ); } ${*$self}{exp_Pid} = undef; ${*$self}{exp_Exit} = $?; return ${*$self}{exp_Exit}; } sleep 1; } warn "Pid ${*$self}{exp_Pid} of ${*$self}{exp_Pty_Handle} is HUNG.\r\n"; ${*$self}{exp_Pid} = undef; return; } # These should not be called externally. sub _init_vars { my ($self) = @_; # for every spawned process or filehandle. ${*$self}{exp_Log_Stdout} = $Expect::Log_Stdout if defined($Expect::Log_Stdout); ${*$self}{exp_Log_Group} = $Expect::Log_Group; ${*$self}{exp_Debug} = $Expect::Debug; ${*$self}{exp_Exp_Internal} = $Expect::Exp_Internal; ${*$self}{exp_Manual_Stty} = $Expect::Manual_Stty; ${*$self}{exp_Stored_Stty} = 'sane'; ${*$self}{exp_Do_Soft_Close} = $Expect::Do_Soft_Close; # sysread doesn't like my or local vars. ${*$self}{exp_Pty_Buffer} = ''; # Initialize accumulator. ${*$self}{exp_Max_Accum} = $Expect::Exp_Max_Accum; ${*$self}{exp_Accum} = ''; ${*$self}{exp_NoTransfer} = 0; # create empty expect_before & after lists ${*$self}{exp_expect_before_list} = []; ${*$self}{exp_expect_after_list} = []; return; } sub _make_readable { my ($s) = @_; $s = '' if not defined($s); study $s; # Speed things up? $s =~ s/\\/\\\\/g; # So we can tell easily(?) what is a backslash $s =~ s/\n/\\n/g; $s =~ s/\r/\\r/g; $s =~ s/\t/\\t/g; $s =~ s/\'/\\\'/g; # So we can tell whassa quote and whassa notta quote. $s =~ s/\"/\\\"/g; # Formfeed (does anyone use formfeed?) $s =~ s/\f/\\f/g; $s =~ s/\010/\\b/g; # escape control chars high/low, but allow ISO 8859-1 chars $s =~ s/([\000-\037\177-\237\377])/sprintf("\\%03lo",ord($1))/ge; return $s; } sub _trim_length { my ($self, $string, $length) = @_; # This is sort of a reverse truncation function # Mostly so we don't have to see the full output when we're using # Also used if Max_Accum gets set to limit the size of the accumulator # for matching functions. # exp_internal croak('No string passed') if not defined $string; # If we're not passed a length (_trim_length is being used for debugging # purposes) AND debug >= 3, don't trim. return ($string) if (defined($self) and ${*$self}{"exp_Debug"} >= 3 and ( !( defined($length) ) ) ); my $indicate_truncation = ($length ? '' : '...'); $length ||= 1021; return $string if $length >= length $string; # We wouldn't want the accumulator to begin with '...' if max_accum is passed # This is because this funct. gets called internally w/ max_accum # and is also used to print information back to the user. return $indicate_truncation . substr( $string, ( length($string) - $length ), $length ); } sub _print_handles { my ($self, $print_this) = @_; # Given crap from 'self' and the handles self wants to print to, print to # them. these are indicated by the handle's 'group' if ( ${*$self}{exp_Log_Group} ) { foreach my $handle ( @{ ${*$self}{exp_Listen_Group} } ) { $print_this = '' unless defined($print_this); # Appease perl -w print STDERR "Printed '" . $self->_trim_length( _make_readable($print_this) ) . "' to ${*$handle}{exp_Pty_Handle} from ${*$self}{exp_Pty_Handle}.\r\n" if ( ${*$handle}{"exp_Debug"} > 1 ); print $handle $print_this; } } # If ${*$self}{exp_Pty_Handle} is STDIN this would make it echo. print STDOUT $print_this if ${*$self}{"exp_Log_Stdout"}; $self->print_log_file($print_this); $| = 1; # This should not be necessary but autoflush() doesn't always work. return; } sub _get_mode { my ($handle) = @_; my ($fcntl_flags) = ''; # What mode are we opening with? use fcntl to find out. $fcntl_flags = fcntl( \*{$handle}, Fcntl::F_GETFL, $fcntl_flags ); die "fcntl returned undef during exp_init of $handle, $!\r\n" unless defined($fcntl_flags); if ( $fcntl_flags | (Fcntl::O_RDWR) ) { return 'rw'; } elsif ( $fcntl_flags | (Fcntl::O_WRONLY) ) { return 'w'; } else { # Under Solaris (among others?) O_RDONLY is implemented as 0. so |O_RDONLY would fail. return 'r'; } } sub _undef { return undef; # Seems a little retarded but &CORE::undef fails in interconnect. # This is used for the default escape sequence function. # w/out the leading & it won't compile. } # clean up child processes sub DESTROY { my ($self) = @_; my $status = $?; # save this as it gets mangled by the terminating spawned children if ( ${*$self}{exp_Do_Soft_Close} ) { $self->soft_close(); } $self->hard_close(); $? = $status; # restore it. otherwise deleting an Expect object may mangle $?, which is unintuitive return; } 1; __END__ =head1 NAME Expect - automate interactions with command line programs that expose a text terminal interface. =head1 SYNOPSIS use Expect; # create an Expect object by spawning another process my $exp = Expect->spawn($command, @params) or die "Cannot spawn $command: $!\n"; # or by using an already opened filehandle (e.g. from Net::Telnet) my $exp = Expect->exp_init(\*FILEHANDLE); # if you prefer the OO mindset: my $exp = Expect->new; $exp->raw_pty(1); $exp->spawn($command, @parameters) or die "Cannot spawn $command: $!\n"; # send some string there: $exp->send("string\n"); # or, for the filehandle mindset: print $exp "string\n"; # then do some pattern matching with either the simple interface $patidx = $exp->expect($timeout, @match_patterns); # or multi-match on several spawned commands with callbacks, # just like the Tcl version $exp->expect($timeout, [ qr/regex1/ => sub { my $exp = shift; $exp->send("response\n"); exp_continue; } ], [ "regexp2" , \&callback, @cbparms ], ); # if no longer needed, do a soft_close to nicely shut down the command $exp->soft_close(); # or be less patient with $exp->hard_close(); Expect.pm is built to either spawn a process or take an existing filehandle and interact with it such that normally interactive tasks can be done without operator assistance. This concept makes more sense if you are already familiar with the versatile Tcl version of Expect. The public functions that make up Expect.pm are: Expect->new() Expect::interconnect(@objects_to_be_read_from) Expect::test_handles($timeout, @objects_to_test) Expect::version($version_requested | undef); $object->spawn(@command) $object->clear_accum() $object->set_accum($value) $object->debug($debug_level) $object->exp_internal(0 | 1) $object->notransfer(0 | 1) $object->raw_pty(0 | 1) $object->stty(@stty_modes) # See the IO::Stty docs $object->slave() $object->before(); $object->match(); $object->after(); $object->matchlist(); $object->match_number(); $object->error(); $object->command(); $object->exitstatus(); $object->pty_handle(); $object->do_soft_close(); $object->restart_timeout_upon_receive(0 | 1); $object->interact($other_object, $escape_sequence) $object->log_group(0 | 1 | undef) $object->log_user(0 | 1 | undef) $object->log_file("filename" | $filehandle | \&coderef | undef) $object->manual_stty(0 | 1 | undef) $object->match_max($max_buffersize or undef) $object->pid(); $object->send_slow($delay, @strings_to_send) $object->set_group(@listen_group_objects | undef) $object->set_seq($sequence,\&function,\@parameters); There are several configurable package variables that affect the behavior of Expect. They are: $Expect::Debug; $Expect::Exp_Internal; $Expect::IgnoreEintr; $Expect::Log_Group; $Expect::Log_Stdout; $Expect::Manual_Stty; $Expect::Multiline_Matching; $Expect::Do_Soft_Close; =head1 DESCRIPTION See an explanation of L<What is Expect|http://code-maven.com/expect> The Expect module is a successor of Comm.pl and a descendent of Chat.pl. It more closely resembles the Tcl Expect language than its predecessors. It does not contain any of the networking code found in Comm.pl. I suspect this would be obsolete anyway given the advent of IO::Socket and external tools such as netcat. Expect.pm is an attempt to have more of a switch() & case feeling to make decision processing more fluid. Three separate types of debugging have been implemented to make code production easier. It is possible to interconnect multiple file handles (and processes) much like Tcl's Expect. An attempt was made to enable all the features of Tcl's Expect without forcing Tcl on the victim programmer :-) . Please, before you consider using Expect, read the FAQs about L</"I want to automate password entry for su/ssh/scp/rsh/..."> and L</"I want to use Expect to automate [anything with a buzzword]..."> =head1 USAGE =over 4 =item new Creates a new Expect object, i.e. a pty. You can change parameters on it before actually spawning a command. This is important if you want to modify the terminal settings for the slave. See slave() below. The object returned is actually a reblessed IO::Pty filehandle, so see there for additional methods. =item Expect->exp_init(\*FILEHANDLE) I<or> =item Expect->init(\*FILEHANDLE) Initializes $new_handle_object for use with other Expect functions. It must be passed a B<_reference_> to FILEHANDLE if you want it to work properly. IO::File objects are preferable. Returns a reference to the newly created object. You can use only real filehandles, certain tied filehandles (e.g. Net::SSH2) that lack a fileno() will not work. Net::Telnet objects can be used but have been reported to work only for certain hosts. YMMV. =item Expect->spawn($command, @parameters) I<or> =item $object->spawn($command, @parameters) I<or> =item Expect->new($command, @parameters) Forks and execs $command. Returns an Expect object upon success or C<undef> if the fork was unsuccessful or the command could not be found. spawn() passes its parameters unchanged to Perls exec(), so look there for detailed semantics. Note that if spawn cannot exec() the given command, the Expect object is still valid and the next expect() will see "Cannot exec", so you can use that for error handling. Also note that you cannot reuse an object with an already spawned command, even if that command has exited. Sorry, but you have to allocate a new object... =item $object->debug(0 | 1 | 2 | 3 | undef) Sets debug level for $object. 1 refers to general debugging information, 2 refers to verbose debugging and 0 refers to no debugging. If you call debug() with no parameters it will return the current debugging level. When the object is created the debugging level will match that $Expect::Debug, normally 0. The '3' setting is new with 1.05, and adds the additional functionality of having the _full_ accumulated buffer printed every time data is read from an Expect object. This was implemented by request. I recommend against using this unless you think you need it as it can create quite a quantity of output under some circumstances.. =item $object->exp_internal(1 | 0) Sets/unsets 'exp_internal' debugging. This is similar in nature to its Tcl counterpart. It is extremely valuable when debugging expect() sequences. When the object is created the exp_internal setting will match the value of $Expect::Exp_Internal, normally 0. Returns the current setting if called without parameters. It is highly recommended that you make use of the debugging features lest you have angry code. =item $object->raw_pty(1 | 0) Set pty to raw mode before spawning. This disables echoing, CR->LF translation and an ugly hack for broken Solaris TTYs (which send <space><backspace> to slow things down) and thus gives a more pipe-like behaviour (which is important if you want to transfer binary content). Note that this must be set I<before> spawning the program. =item $object->stty(qw(mode1 mode2...)) Sets the tty mode for $object's associated terminal to the given modes. Note that on many systems the master side of the pty is not a tty, so you have to modify the slave pty instead, see next item. This needs IO::Stty installed, which is no longer required. =item $object->slave() Returns a filehandle to the slave part of the pty. Very useful in modifying the terminal settings: $object->slave->stty(qw(raw -echo)); Typical values are 'sane', 'raw', and 'raw -echo'. Note that I recommend setting the terminal to 'raw' or 'raw -echo', as this avoids a lot of hassle and gives pipe-like (i.e. transparent) behaviour (without the buffering issue). =item $object->print(@strings) I<or> =item $object->send(@strings) Sends the given strings to the spawned command. Note that the strings are not logged in the logfile (see print_log_file) but will probably be echoed back by the pty, depending on pty settings (default is echo) and thus end up there anyway. This must also be taken into account when expect()ing for an answer: the next string will be the command just sent. I suggest setting the pty to raw, which disables echo and makes the pty transparently act like a bidirectional pipe. =item $object->expect($timeout, @match_patterns) =over 4 =item Simple interface Given $timeout in seconds Expect will wait for $object's handle to produce one of the match_patterns, which are matched exactly by default. If you want a regexp match, prefix the pattern with '-re'. $object->expect(15, 'match me exactly','-re','match\s+me\s+exactly'); Due to o/s limitations $timeout should be a round number. If $timeout is 0 Expect will check one time to see if $object's handle contains any of the match_patterns. If $timeout is undef Expect will wait forever for a pattern to match. If called in a scalar context, expect() will return the position of the matched pattern within @matched_patterns, or undef if no pattern was matched. This is a position starting from 1, so if you want to know which of an array of @matched_patterns matched you should subtract one from the return value. If called in an array context expect() will return ($matched_pattern_position, $error, $successfully_matching_string, $before_match, and $after_match). C<$matched_pattern_position> will contain the value that would have been returned if expect() had been called in a scalar context. C<$error> is the error that occurred that caused expect() to return. $error will contain a number followed by a string equivalent expressing the nature of the error. Possible values are undef, indicating no error, '1:TIMEOUT' indicating that $timeout seconds had elapsed without a match, '2:EOF' indicating an eof was read from $object, '3: spawn id($fileno) died' indicating that the process exited before matching and '4:$!' indicating whatever error was set in $ERRNO during the last read on $object's handle or during select(). All handles indicated by set_group plus STDOUT will have all data to come out of $object printed to them during expect() if log_group and log_stdout are set. C<$successfully_matching_string> C<$before_match> C<$after_match> Changed from older versions is the regular expression handling. By default now all strings passed to expect() are treated as literals. To match a regular expression pass '-re' as a parameter in front of the pattern you want to match as a regexp. This change makes it possible to match literals and regular expressions in the same expect() call. Also new is multiline matching. ^ will now match the beginning of lines. Unfortunately, because perl doesn't use $/ in determining where lines break using $ to find the end of a line frequently doesn't work. This is because your terminal is returning "\r\n" at the end of every line. One way to check for a pattern at the end of a line would be to use \r?$ instead of $. Example: Spawning telnet to a host, you might look for the escape character. telnet would return to you "\r\nEscape character is '^]'.\r\n". To find this you might use $match='^Escape char.*\.\r?$'; $telnet->expect(10,'-re',$match); =item New more Tcl/Expect-like interface expect($timeout, '-i', [ $obj1, $obj2, ... ], [ $re_pattern, sub { ...; exp_continue; }, @subparms, ], [ 'eof', sub { ... } ], [ 'timeout', sub { ... }, \$subparm1 ], '-i', [ $objn, ...], '-ex', $exact_pattern, sub { ... }, $exact_pattern, sub { ...; exp_continue_timeout; }, '-re', $re_pattern, sub { ... }, '-i', \@object_list, @pattern_list, ...); It's now possible to expect on more than one connection at a time by specifying 'C<-i>' and a single Expect object or a ref to an array containing Expect objects, e.g. expect($timeout, '-i', $exp1, @patterns_1, '-i', [ $exp2, $exp3 ], @patterns_2_3, ) Furthermore, patterns can now be specified as array refs containing [$regexp, sub { ...}, @optional_subprams] . When the pattern matches, the subroutine is called with parameters ($matched_expect_obj, @optional_subparms). The subroutine can return the symbol `exp_continue' to continue the expect matching with timeout starting anew or return the symbol `exp_continue_timeout' for continuing expect without resetting the timeout count. $exp->expect($timeout, [ qr/username: /i, sub { my $self = shift; $self->send("$username\n"); exp_continue; }], [ qr/password: /i, sub { my $self = shift; $self->send("$password\n"); exp_continue; }], $shell_prompt); `expect' is now exported by default. =back =item $object->exp_before() I<or> =item $object->before() before() returns the 'before' part of the last expect() call. If the last expect() call didn't match anything, exp_before() will return the entire output of the object accumulated before the expect() call finished. Note that this is something different than Tcl Expects before()!! =item $object->exp_after() I<or> =item $object->after() returns the 'after' part of the last expect() call. If the last expect() call didn't match anything, exp_after() will return undef(). =item $object->exp_match() I<or> =item $object->match() returns the string matched by the last expect() call, undef if no string was matched. =item $object->exp_match_number() I<or> =item $object->match_number() exp_match_number() returns the number of the pattern matched by the last expect() call. Keep in mind that the first pattern in a list of patterns is 1, not 0. Returns undef if no pattern was matched. =item $object->exp_matchlist() I<or> =item $object->matchlist() exp_matchlist() returns a list of matched substrings from the brackets () inside the regexp that last matched. ($object->matchlist)[0] thus corresponds to $1, ($object->matchlist)[1] to $2, etc. =item $object->exp_error() I<or> =item $object->error() exp_error() returns the error generated by the last expect() call if no pattern was matched. It is typically useful to examine the value returned by before() to find out what the output of the object was in determining why it didn't match any of the patterns. =item $object->clear_accum() Clear the contents of the accumulator for $object. This gets rid of any residual contents of a handle after expect() or send_slow() such that the next expect() call will only see new data from $object. The contents of the accumulator are returned. =item $object->set_accum($value) Sets the content of the accumulator for $object to $value. The previous content of the accumulator is returned. =item $object->exp_command() I<or> =item $object->command() exp_command() returns the string that was used to spawn the command. Helpful for debugging and for reused patternmatch subroutines. =item $object->exp_exitstatus() I<or> =item $object->exitstatus() Returns the exit status of $object (if it already exited). =item $object->exp_pty_handle() I<or> =item $object->pty_handle() Returns a string representation of the attached pty, for example: `spawn id(5)' (pty has fileno 5), `handle id(7)' (pty was initialized from fileno 7) or `STDIN'. Useful for debugging. =item $object->restart_timeout_upon_receive(0 | 1) If this is set to 1, the expect timeout is retriggered whenever something is received from the spawned command. This allows to perform some aliveness testing and still expect for patterns. $exp->restart_timeout_upon_receive(1); $exp->expect($timeout, [ timeout => \&report_timeout ], [ qr/pattern/ => \&handle_pattern], ); Now the timeout isn't triggered if the command produces any kind of output, i.e. is still alive, but you can act upon patterns in the output. =item $object->notransfer(1 | 0) Do not truncate the content of the accumulator after a match. Normally, the accumulator is set to the remains that come after the matched string. Note that this setting is per object and not per pattern, so if you want to have normal acting patterns that truncate the accumulator, you have to add a $exp->set_accum($exp->after); to their callback, e.g. $exp->notransfer(1); $exp->expect($timeout, # accumulator not truncated, pattern1 will match again [ "pattern1" => sub { my $self = shift; ... } ], # accumulator truncated, pattern2 will not match again [ "pattern2" => sub { my $self = shift; ... $self->set_accum($self->after()); } ], ); This is only a temporary fix until I can rewrite the pattern matching part so it can take that additional -notransfer argument. =item Expect::interconnect(@objects); Read from @objects and print to their @listen_groups until an escape sequence is matched from one of @objects and the associated function returns 0 or undef. The special escape sequence 'EOF' is matched when an object's handle returns an end of file. Note that it is not necessary to include objects that only accept data in @objects since the escape sequence is _read_ from an object. Further note that the listen_group for a write-only object is always empty. Why would you want to have objects listening to STDOUT (for example)? By default every member of @objects _as well as every member of its listen group_ will be set to 'raw -echo' for the duration of interconnection. Setting $object->manual_stty() will stop this behavior per object. The original tty settings will be restored as interconnect exits. For a generic way to interconnect processes, take a look at L<IPC::Run>. =item Expect::test_handles(@objects) Given a set of objects determines which objects' handles have data ready to be read. B<Returns an array> who's members are positions in @objects that have ready handles. Returns undef if there are no such handles ready. =item Expect::version($version_requested or undef); Returns current version of Expect. As of .99 earlier versions are not supported. Too many things were changed to make versioning possible. =item $object->interact( C<\*FILEHANDLE, $escape_sequence>) interact() is essentially a macro for calling interconnect() for connecting 2 processes together. \*FILEHANDLE defaults to \*STDIN and $escape_sequence defaults to undef. Interaction ceases when $escape_sequence is read from B<FILEHANDLE>, not $object. $object's listen group will consist solely of \*FILEHANDLE for the duration of the interaction. \*FILEHANDLE will not be echoed on STDOUT. =item $object->log_group(0 | 1 | undef) Set/unset logging of $object to its 'listen group'. If set all objects in the listen group will have output from $object printed to them during $object->expect(), $object->send_slow(), and C<Expect::interconnect($object , ...)>. Default value is on. During creation of $object the setting will match the value of $Expect::Log_Group, normally 1. =item $object->log_user(0 | 1 | undef) I<or> =item $object->log_stdout(0 | 1 | undef) Set/unset logging of object's handle to STDOUT. This corresponds to Tcl's log_user variable. Returns current setting if called without parameters. Default setting is off for initialized handles. When a process object is created (not a filehandle initialized with exp_init) the log_stdout setting will match the value of $Expect::Log_Stdout variable, normally 1. If/when you initialize STDIN it is usually associated with a tty which will by default echo to STDOUT anyway, so be careful or you will have multiple echoes. =item $object->log_file("filename" | $filehandle | \&coderef | undef) Log session to a file. All characters send to or received from the spawned process are written to the file. Normally appends to the logfile, but you can pass an additional mode of "w" to truncate the file upon open(): $object->log_file("filename", "w"); Returns the logfilehandle. If called with an undef value, stops logging and closes logfile: $object->log_file(undef); If called without argument, returns the logfilehandle: $fh = $object->log_file(); Can be set to a code ref, which will be called instead of printing to the logfile: $object->log_file(\&myloggerfunc); =item $object->print_log_file(@strings) Prints to logfile (if opened) or calls the logfile hook function. This allows the user to add arbitrary text to the logfile. Note that this could also be done as $object->log_file->print() but would only work for log files, not code hooks. =item $object->set_seq($sequence, \&function, \@function_parameters) During Expect->interconnect() if $sequence is read from $object &function will be executed with parameters @function_parameters. It is B<_highly recommended_> that the escape sequence be a single character since the likelihood is great that the sequence will be broken into to separate reads from the $object's handle, making it impossible to strip $sequence from getting printed to $object's listen group. \&function should be something like 'main::control_w_function' and @function_parameters should be an array defined by the caller, passed by reference to set_seq(). Your function should return a non-zero value if execution of interconnect() is to resume after the function returns, zero or undefined if interconnect() should return after your function returns. The special sequence 'EOF' matches the end of file being reached by $object. See interconnect() for details. =item $object->set_group(@listener_objects) @listener_objects is the list of objects that should have their handles printed to by $object when Expect::interconnect, $object->expect() or $object->send_slow() are called. Calling w/out parameters will return the current list of the listener objects. =item $object->manual_stty(0 | 1 | undef) Sets/unsets whether or not Expect should make reasonable guesses as to when and how to set tty parameters for $object. Will match $Expect::Manual_Stty value (normally 0) when $object is created. If called without parameters manual_stty() will return the current manual_stty setting. =item $object->match_max($maximum_buffer_length | undef) I<or> =item $object->max_accum($maximum_buffer_length | undef) Set the maximum accumulator size for object. This is useful if you think that the accumulator will grow out of hand during expect() calls. Since the buffer will be matched by every match_pattern it may get slow if the buffer gets too large. Returns current value if called without parameters. Not defined by default. =item $object->notransfer(0 | 1) If set, matched strings will not be deleted from the accumulator. Returns current value if called without parameters. False by default. =item $object->exp_pid() I<or> =item $object->pid() Return pid of $object, if one exists. Initialized filehandles will not have pids (of course). =item $object->send_slow($delay, @strings); print each character from each string of @strings one at a time with $delay seconds before each character. This is handy for devices such as modems that can be annoying if you send them data too fast. After each character $object will be checked to determine whether or not it has any new data ready and if so update the accumulator for future expect() calls and print the output to STDOUT and @listen_group if log_stdout and log_group are appropriately set. =back =head2 Configurable Package Variables: =over 4 =item $Expect::Debug Defaults to 0. Newly created objects have a $object->debug() value of $Expect::Debug. See $object->debug(); =item $Expect::Do_Soft_Close Defaults to 0. When destroying objects, soft_close may take up to half a minute to shut everything down. From now on, only hard_close will be called, which is less polite but still gives the process a chance to terminate properly. Set this to '1' for old behaviour. =item $Expect::Exp_Internal Defaults to 0. Newly created objects have a $object->exp_internal() value of $Expect::Exp_Internal. See $object->exp_internal(). =item $Expect::IgnoreEintr Defaults to 0. If set to 1, when waiting for new data, Expect will ignore EINTR errors and restart the select() call instead. =item $Expect::Log_Group Defaults to 1. Newly created objects have a $object->log_group() value of $Expect::Log_Group. See $object->log_group(). =item $Expect::Log_Stdout Defaults to 1 for spawned commands, 0 for file handles attached with exp_init(). Newly created objects have a $object->log_stdout() value of $Expect::Log_Stdout. See $object->log_stdout(). =item $Expect::Manual_Stty Defaults to 0. Newly created objects have a $object->manual_stty() value of $Expect::Manual_Stty. See $object->manual_stty(). =item $Expect::Multiline_Matching Defaults to 1. Affects whether or not expect() uses the /m flag for doing regular expression matching. If set to 1 /m is used. This makes a difference when you are trying to match ^ and $. If you have this on you can match lines in the middle of a page of output using ^ and $ instead of it matching the beginning and end of the entire expression. I think this is handy. The $Expect::Multiline_Matching turns on and off Expect's multi-line matching mode. But this only has an effect if you pass in a string, and then use '-re' mode. If you pass in a regular expression value (via qr//), then the qr//'s own flags are preserved irrespective of what it gets interpolated into. There was a bug in Perl 5.8.x where interpolating a regex without /m into a match with /m would incorrectly apply the /m to the inner regex too, but this was fixed in Perl 5.10. The correct behavior, as seen in Perl 5.10, is that if you pass in a regex (via qr//), then $Expect::Multiline_Matching has no effect. So if you pass in a regex, then you must use the qr's flags to control whether it is multiline (which by default it is not, opposite of the default behavior of Expect). =back =head1 CONTRIBUTIONS Lee Eakin <leakin@japh.itg.ti.com> has ported the kibitz script from Tcl/Expect to Perl/Expect. Jeff Carr <jcarr@linuxmachines.com> provided a simple example of how handle terminal window resize events (transmitted via the WINCH signal) in a ssh session. You can find both scripts in the examples/ subdir. Thanks to both! Historical notes: There are still a few lines of code dating back to the inspirational Comm.pl and Chat.pl modules without which this would not have been possible. Kudos to Eric Arnold <Eric.Arnold@Sun.com> and Randal 'Nuke your NT box with one line of perl code' Schwartz<merlyn@stonehenge.com> for making these available to the perl public. As of .98 I think all the old code is toast. No way could this have been done without it though. Special thanks to Graham Barr for helping make sense of the IO::Handle stuff as well as providing the highly recommended IO::Tty module. =head1 REFERENCES Mark Rogaski <rogaski@att.com> wrote: "I figured that you'd like to know that Expect.pm has been very useful to AT&T Labs over the past couple of years (since I first talked to Austin about design decisions). We use Expect.pm for managing the switches in our network via the telnet interface, and such automation has significantly increased our reliability. So, you can honestly say that one of the largest digital networks in existence (AT&T Frame Relay) uses Expect.pm quite extensively." =head1 FAQ - Frequently Asked Questions This is a growing collection of things that might help. Please send you questions that are not answered here to RGiersig@cpan.org =head2 What systems does Expect run on? Expect itself doesn't have real system dependencies, but the underlying IO::Tty needs pseudoterminals. IO::Stty uses POSIX.pm and Fcntl.pm. I have used it on Solaris, Linux and AIX, others report *BSD and OSF as working. Generally, any modern POSIX Unix should do, but there are exceptions to every rule. Feedback is appreciated. See L<IO::Tty> for a list of verified systems. =head2 Can I use this module with ActivePerl on Windows? Up to now, the answer was 'No', but this has changed. You still cannot use ActivePerl, but if you use the Cygwin environment (http://sources.redhat.com), which brings its own perl, and have the latest IO::Tty (v0.05 or later) installed, it should work (feedback appreciated). =head2 The examples in the tutorial don't work! The tutorial is hopelessly out of date and needs a serious overhaul. I apologize for this, I have concentrated my efforts mainly on the functionality. Volunteers welcomed. =head2 How can I find out what Expect is doing? If you set $Expect::Exp_Internal = 1; Expect will tell you very verbosely what it is receiving and sending, what matching it is trying and what it found. You can do this on a per-command base with $exp->exp_internal(1); You can also set $Expect::Debug = 1; # or 2, 3 for more verbose output or $exp->debug(1); which gives you even more output. =head2 I am seeing the output of the command I spawned. Can I turn that off? Yes, just set $Expect::Log_Stdout = 0; to globally disable it or $exp->log_stdout(0); for just that command. 'log_user' is provided as an alias so Tcl/Expect user get a DWIM experience... :-) =head2 No, I mean that when I send some text to the spawned process, it gets echoed back and I have to deal with it in the next expect. This is caused by the pty, which has probably 'echo' enabled. A solution would be to set the pty to raw mode, which in general is cleaner for communication between two programs (no more unexpected character translations). Unfortunately this would break a lot of old code that sends "\r" to the program instead of "\n" (translating this is also handled by the pty), so I won't add this to Expect just like that. But feel free to experiment with C<$exp-E<gt>raw_pty(1)>. =head2 How do I send control characters to a process? A: You can send any characters to a process with the print command. To represent a control character in Perl, use \c followed by the letter. For example, control-G can be represented with "\cG" . Note that this will not work if you single-quote your string. So, to send control-C to a process in $exp, do: print $exp "\cC"; Or, if you prefer: $exp->send("\cC"); The ability to include control characters in a string like this is provided by Perl, not by Expect.pm . Trying to learn Expect.pm without a thorough grounding in Perl can be very daunting. We suggest you look into some of the excellent Perl learning material, such as the books _Programming Perl_ and _Learning Perl_ by O'Reilly, as well as the extensive online Perl documentation available through the perldoc command. =head2 My script fails from time to time without any obvious reason. It seems that I am sometimes loosing output from the spawned program. You could be exiting too fast without giving the spawned program enough time to finish. Try adding $exp->soft_close() to terminate the program gracefully or do an expect() for 'eof'. Alternatively, try adding a 'sleep 1' after you spawn() the program. It could be that pty creation on your system is just slow (but this is rather improbable if you are using the latest IO-Tty). =head2 I want to automate password entry for su/ssh/scp/rsh/... You shouldn't use Expect for this. Putting passwords, especially root passwords, into scripts in clear text can mean severe security problems. I strongly recommend using other means. For 'su', consider switching to 'sudo', which gives you root access on a per-command and per-user basis without the need to enter passwords. 'ssh'/'scp' can be set up with RSA authentication without passwords. 'rsh' can use the .rhost mechanism, but I'd strongly suggest to switch to 'ssh'; to mention 'rsh' and 'security' in the same sentence makes an oxymoron. It will work for 'telnet', though, and there are valid uses for it, but you still might want to consider using 'ssh', as keeping cleartext passwords around is very insecure. =head2 I want to use Expect to automate [anything with a buzzword]... Are you sure there is no other, easier way? As a rule of thumb, Expect is useful for automating things that expect to talk to a human, where no formal standard applies. For other tasks that do follow a well-defined protocol, there are often better-suited modules that already can handle those protocols. Don't try to do HTTP requests by spawning telnet to port 80, use LWP instead. To automate FTP, take a look at L<Net::FTP> or C<ncftp> (http://www.ncftp.org). You don't use a screwdriver to hammer in your nails either, or do you? =head2 Is it possible to use threads with Expect? Basically yes, with one restriction: you must spawn() your programs in the main thread and then pass the Expect objects to the handling threads. The reason is that spawn() uses fork(), and L<perlthrtut>: "Thinking of mixing fork() and threads? Please lie down and wait until the feeling passes." =head2 I want to log the whole session to a file. Use $exp->log_file("filename"); or $exp->log_file($filehandle); or even $exp->log_file(\&log_procedure); for maximum flexibility. Note that the logfile is appended to by default, but you can specify an optional mode "w" to truncate the logfile: $exp->log_file("filename", "w"); To stop logging, just call it with a false argument: $exp->log_file(undef); =head2 How can I turn off multi-line matching for my regexps? To globally unset multi-line matching for all regexps: $Expect::Multiline_Matching = 0; You can do that on a per-regexp basis by stating C<(?-m)> inside the regexp (you need perl5.00503 or later for that). =head2 How can I expect on multiple spawned commands? You can use the B<-i> parameter to specify a single object or a list of Expect objects. All following patterns will be evaluated against that list. You can specify B<-i> multiple times to create groups of objects and patterns to match against within the same expect statement. This works just like in Tcl/Expect. See the source example below. =head2 I seem to have problems with ptys! Well, pty handling is really a black magic, as it is extremely system dependent. I have extensively revised IO-Tty, so these problems should be gone. If your system is listed in the "verified" list of IO::Tty, you probably have some non-standard setup, e.g. you compiled your Linux-kernel yourself and disabled ptys. Please ask your friendly sysadmin for help. If your system is not listed, unpack the latest version of IO::Tty, do a 'perl Makefile.PL; make; make test; uname C<-a>' and send me the results and I'll see what I can deduce from that. =head2 I just want to read the output of a process without expect()ing anything. How can I do this? [ Are you sure you need Expect for this? How about qx() or open("prog|")? ] By using expect without any patterns to match. $process->expect(undef); # Forever until EOF $process->expect($timeout); # For a few seconds $process->expect(0); # Is there anything ready on the handle now? =head2 Ok, so now how do I get what was read on the handle? $read = $process->before(); =head2 Where's IO::Pty? Find it on CPAN as IO-Tty, which provides both. =head2 How come when I automate the passwd program to change passwords for me passwd dies before changing the password sometimes/every time? What's happening is you are closing the handle before passwd exits. When you close the handle to a process, it is sent a signal (SIGPIPE?) telling it that STDOUT has gone away. The default behavior for processes is to die in this circumstance. Two ways you can make this not happen are: $process->soft_close(); This will wait 15 seconds for a process to come up with an EOF by itself before killing it. $process->expect(undef); This will wait forever for the process to match an empty set of patterns. It will return when the process hits an EOF. As a rule, you should always expect() the result of your transaction before you continue with processing. =head2 How come when I try to make a logfile with log_file() or set_group() it doesn't print anything after the last time I run expect()? Output is only printed to the logfile/group when Expect reads from the process, during expect(), send_slow() and interconnect(). One way you can force this is to make use of $process->expect(undef); and $process->expect(0); which will make expect() run with an empty pattern set forever or just for an instant to capture the output of $process. The output is available in the accumulator, so you can grab it using $process->before(). =head2 I seem to have problems with terminal settings, double echoing, etc. Tty settings are a major pain to keep track of. If you find unexpected behavior such as double-echoing or a frozen session, doublecheck the documentation for default settings. When in doubt, handle them yourself using $exp->stty() and manual_stty() functions. As of .98 you shouldn't have to worry about stty settings getting fouled unless you use interconnect or intentionally change them (like doing -echo to get a password). If you foul up your terminal's tty settings, kill any hung processes and enter 'stty sane' at a shell prompt. This should make your terminal manageable again. Note that IO::Tty returns ptys with your systems default setting regarding echoing, CRLF translation etc. and Expect does not change them. I have considered setting the ptys to 'raw' without any translation whatsoever, but this would break a lot of existing things, as '\r' translation would not work anymore. On the other hand, a raw pty works much like a pipe and is more WYGIWYE (what you get is what you expect), so I suggest you set it to 'raw' by yourself: $exp = Expect->new; $exp->raw_pty(1); $exp->spawn(...); To disable echo: $exp->slave->stty(qw(-echo)); =head2 I'm spawning a telnet/ssh session and then let the user interact with it. But screen-oriented applications on the other side don't work properly. You have to set the terminal screen size for that. Luckily, IO::Pty already has a method for that, so modify your code to look like this: my $exp = Expect->new; $exp->slave->clone_winsize_from(\*STDIN); $exp->spawn("telnet somehost); Also, some applications need the TERM shell variable set so they know how to move the cursor across the screen. When logging in, the remote shell sends a query (Ctrl-Z I think) and expects the terminal to answer with a string, e.g. 'xterm'. If you really want to go that way (be aware, madness lies at its end), you can handle that and send back the value in $ENV{TERM}. This is only a hand-waving explanation, please figure out the details by yourself. =head2 I set the terminal size as explained above, but if I resize the window, the application does not notice this. You have to catch the signal WINCH ("window size changed"), change the terminal size and propagate the signal to the spawned application: my $exp = Expect->new; $exp->slave->clone_winsize_from(\*STDIN); $exp->spawn("ssh somehost); $SIG{WINCH} = \&winch; sub winch { $exp->slave->clone_winsize_from(\*STDIN); kill WINCH => $exp->pid if $exp->pid; $SIG{WINCH} = \&winch; } $exp->interact(); There is an example file ssh.pl in the examples/ subdir that shows how this works with ssh. Please note that I do strongly object against using Expect to automate ssh login, as there are better way to do that (see L<ssh-keygen>). =head2 I noticed that the test uses a string that resembles, but not exactly matches, a well-known sentence that contains every character. What does that mean? That means you are anal-retentive. :-) [Gotcha there!] =head2 I get a "Could not assign a pty" error when running as a non-root user on an IRIX box? The OS may not be configured to grant additional pty's (pseudo terminals) to non-root users. /usr/sbin/mkpts should be 4755, not 700 for this to work. I don't know about security implications if you do this. =head2 How come I don't notice when the spawned process closes its stdin/out/err?? You are probably on one of the systems where the master doesn't get an EOF when the slave closes stdin/out/err. One possible solution is when you spawn a process, follow it with a unique string that would indicate the process is finished. $process = Expect->spawn('telnet somehost; echo ____END____'); And then $process->expect($timeout,'____END____','other','patterns'); =head1 Source Examples =head2 How to automate login my $telnet = Net::Telnet->new("remotehost") # see Net::Telnet or die "Cannot telnet to remotehost: $!\n";; my $exp = Expect->exp_init($telnet); # deprecated use of spawned telnet command # my $exp = Expect->spawn("telnet localhost") # or die "Cannot spawn telnet: $!\n";; my $spawn_ok; $exp->expect($timeout, [ qr'login: $', sub { $spawn_ok = 1; my $fh = shift; $fh->send("$username\n"); exp_continue; } ], [ 'Password: $', sub { my $fh = shift; print $fh "$password\n"; exp_continue; } ], [ eof => sub { if ($spawn_ok) { die "ERROR: premature EOF in login.\n"; } else { die "ERROR: could not spawn telnet.\n"; } } ], [ timeout => sub { die "No login.\n"; } ], '-re', qr'[#>:] $', #' wait for shell prompt, then exit expect ); =head2 How to expect on multiple spawned commands foreach my $cmd (@list_of_commands) { push @commands, Expect->spawn($cmd); } expect($timeout, '-i', \@commands, [ qr"pattern", # find this pattern in output of all commands sub { my $obj = shift; # object that matched print $obj "something\n"; exp_continue; # we don't want to terminate the expect call } ], '-i', $some_other_command, [ "some other pattern", sub { my ($obj, $parmref) = @_; # ... # now we exit the expect command }, \$parm ], ); =head2 How to propagate terminal sizes my $exp = Expect->new; $exp->slave->clone_winsize_from(\*STDIN); $exp->spawn("ssh somehost); $SIG{WINCH} = \&winch; sub winch { $exp->slave->clone_winsize_from(\*STDIN); kill WINCH => $exp->pid if $exp->pid; $SIG{WINCH} = \&winch; } $exp->interact(); =head1 HOMEPAGE L<http://sourceforge.net/projects/expectperl/> though the source code is now in GitHub: L<https://github.com/jacoby/expect.pm> =head1 MAILING LISTS There are two mailing lists available, expectperl-announce and expectperl-discuss, at http://lists.sourceforge.net/lists/listinfo/expectperl-announce and http://lists.sourceforge.net/lists/listinfo/expectperl-discuss =head1 BUG TRACKING You can use the CPAN Request Tracker http://rt.cpan.org/ and submit new bugs under http://rt.cpan.org/Ticket/Create.html?Queue=Expect =head1 AUTHORS (c) 1997 Austin Schutz E<lt>F<ASchutz@users.sourceforge.net>E<gt> (retired) expect() interface & functionality enhancements (c) 1999-2006 Roland Giersig. This module is now maintained by Dave Jacoby E<lt>F<jacoby@cpan.org>E<gt> =head1 LICENSE This module can be used under the same terms as Perl. =head1 DISCLAIMER THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. In other words: Use at your own risk. Provided as is. Your mileage may vary. Read the source, Luke! And finally, just to be sure: Any Use of This Product, in Any Manner Whatsoever, Will Increase the Amount of Disorder in the Universe. Although No Liability Is Implied Herein, the Consumer Is Warned That This Process Will Ultimately Lead to the Heat Death of the Universe. =cut perl5/AppConfig.pm 0000444 00000077320 14711220311 0007776 0 ustar 00 #============================================================================ # # AppConfig.pm # # Perl5 module for reading and parsing configuration files and command line # arguments. # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. #========================================================================== package AppConfig; use 5.006; use strict; use warnings; use base 'Exporter'; our $VERSION = '1.71'; # variable expansion constants use constant EXPAND_NONE => 0; use constant EXPAND_VAR => 1; use constant EXPAND_UID => 2; use constant EXPAND_ENV => 4; use constant EXPAND_ALL => EXPAND_VAR | EXPAND_UID | EXPAND_ENV; use constant EXPAND_WARN => 8; # argument count types use constant ARGCOUNT_NONE => 0; use constant ARGCOUNT_ONE => 1; use constant ARGCOUNT_LIST => 2; use constant ARGCOUNT_HASH => 3; # Exporter tagsets our @EXPAND = qw( EXPAND_NONE EXPAND_VAR EXPAND_UID EXPAND_ENV EXPAND_ALL EXPAND_WARN ); our @ARGCOUNT = qw( ARGCOUNT_NONE ARGCOUNT_ONE ARGCOUNT_LIST ARGCOUNT_HASH ); our @EXPORT_OK = ( @EXPAND, @ARGCOUNT ); our %EXPORT_TAGS = ( expand => [ @EXPAND ], argcount => [ @ARGCOUNT ], ); our $AUTOLOAD; require AppConfig::State; #------------------------------------------------------------------------ # new(\%config, @vars) # # Module constructor. All parameters passed are forwarded onto the # AppConfig::State constructor. Returns a reference to a newly created # AppConfig object. #------------------------------------------------------------------------ sub new { my $class = shift; bless { STATE => AppConfig::State->new(@_) }, $class; } #------------------------------------------------------------------------ # file(@files) # # The file() method is called to parse configuration files. An # AppConfig::File object is instantiated and stored internally for # use in subsequent calls to file(). #------------------------------------------------------------------------ sub file { my $self = shift; my $state = $self->{ STATE }; my $file; require AppConfig::File; # create an AppConfig::File object if one isn't defined $file = $self->{ FILE } ||= AppConfig::File->new($state); # call on the AppConfig::File object to process files. $file->parse(@_); } #------------------------------------------------------------------------ # args(\@args) # # The args() method is called to parse command line arguments. An # AppConfig::Args object is instantiated and then stored internally for # use in subsequent calls to args(). #------------------------------------------------------------------------ sub args { my $self = shift; my $state = $self->{ STATE }; my $args; require AppConfig::Args; # create an AppConfig::Args object if one isn't defined $args = $self->{ ARGS } ||= AppConfig::Args->new($state); # call on the AppConfig::Args object to process arguments. $args->parse(shift); } #------------------------------------------------------------------------ # getopt(@config, \@args) # # The getopt() method is called to parse command line arguments. The # AppConfig::Getopt module is require()'d and an AppConfig::Getopt object # is created to parse the arguments. #------------------------------------------------------------------------ sub getopt { my $self = shift; my $state = $self->{ STATE }; my $getopt; require AppConfig::Getopt; # create an AppConfig::Getopt object if one isn't defined $getopt = $self->{ GETOPT } ||= AppConfig::Getopt->new($state); # call on the AppConfig::Getopt object to process arguments. $getopt->parse(@_); } #------------------------------------------------------------------------ # cgi($query) # # The cgi() method is called to parse a CGI query string. An # AppConfig::CGI object is instantiated and then stored internally for # use in subsequent calls to args(). #------------------------------------------------------------------------ sub cgi { my $self = shift; my $state = $self->{ STATE }; my $cgi; require AppConfig::CGI; # create an AppConfig::CGI object if one isn't defined $cgi = $self->{ CGI } ||= AppConfig::CGI->new($state); # call on the AppConfig::CGI object to process a query. $cgi->parse(shift); } #------------------------------------------------------------------------ # AUTOLOAD # # Autoload function called whenever an unresolved object method is # called. All methods are delegated to the $self->{ STATE } # AppConfig::State object. # #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $method; # splat the leading package name ($method = $AUTOLOAD) =~ s/.*:://; # ignore destructor $method eq 'DESTROY' && return; # delegate method call to AppConfig::State object in $self->{ STATE } $self->{ STATE }->$method(@_); } 1; __END__ =head1 NAME AppConfig - Perl5 module for reading configuration files and parsing command line arguments. =head1 SYNOPSIS use AppConfig; # create a new AppConfig object my $config = AppConfig->new( \%cfg ); # define a new variable $config->define( $varname => \%varopts ); # create/define combined my $config = AppConfig->new( \%cfg, $varname => \%varopts, $varname => \%varopts, ... ); # set/get the value $config->set( $varname, $value ); $config->get($varname); # shortcut form $config->varname($value); $config->varname; # read configuration file $config->file($file); # parse command line options $config->args(\@args); # default to \@ARGV # advanced command line options with Getopt::Long $config->getopt(\@args); # default to \@ARGV # parse CGI parameters (GET method) $config->cgi($query); # default to $ENV{ QUERY_STRING } =head1 OVERVIEW AppConfig is a Perl5 module for managing application configuration information. It maintains the state of any number of variables and provides methods for parsing configuration files, command line arguments and CGI script parameters. Variables values may be set via configuration files. Variables may be flags (On/Off), take a single value, or take multiple values stored as a list or hash. The number of arguments a variable expects is determined by its configuration when defined. # flags verbose nohelp debug = On # single value home = /home/abw/ # multiple list value file = /tmp/file1 file = /tmp/file2 # multiple hash value book camel = Programming Perl book llama = Learning Perl The '-' prefix can be used to reset a variable to its default value and the '+' prefix can be used to set it to 1 -verbose +debug Variable, environment variable and tilde (home directory) expansions can be applied (selectively, if necessary) to the values read from configuration files: home = ~ # home directory nntp = ${NNTPSERVER} # environment variable html = $home/html # internal variables img = $html/images Configuration files may be arranged in blocks as per the style of Win32 "INI" files. [file] site = kfs src = ~/websrc/docs/$site lib = ~/websrc/lib dest = ~/public_html/$site [page] header = $lib/header footer = $lib/footer You can also use Perl's "heredoc" syntax to define a large block of text in a configuration file. multiline = <<FOOBAR line 1 line 2 FOOBAR paths exe = "${PATH}:${HOME}/.bin" paths link = <<'FOO' ${LD_LIBARRAY_PATH}:${HOME}/lib FOO Variables may also be set by parsing command line arguments. myapp -verbose -site kfs -file f1 -file f2 AppConfig provides a simple method (args()) for parsing command line arguments. A second method (getopt()) allows more complex argument processing by delegation to Johan Vroman's Getopt::Long module. AppConfig also allows variables to be set by parameters passed to a CGI script via the URL (GET method). http://www.nowhere.com/cgi-bin/myapp?verbose&site=kfs =head1 PREREQUISITES AppConfig requires Perl 5.005 or later. The L<Getopt::Long> and L<Test::More> modules should be installed. If you are using a recent version of Perl (e.g. 5.8.0) then these should already be installed. =head1 OBTAINING AND INSTALLING THE AppConfig MODULE BUNDLE The AppConfig module bundle is available from CPAN. As the 'perlmod' manual page explains: CPAN stands for the Comprehensive Perl Archive Network. This is a globally replicated collection of all known Perl materials, including hundreds of unbundled modules. [...] For an up-to-date listing of CPAN sites, see http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/ . Within the CPAN archive, AppConfig is in the category: 12) Option, Argument, Parameter and Configuration File Processing The module is available in the following directories: /modules/by-module/AppConfig/AppConfig-<version>.tar.gz /authors/id/ABW/AppConfig-<version>.tar.gz AppConfig is distributed as a single gzipped tar archive file: AppConfig-<version>.tar.gz Note that "<version>" represents the current AppConfig version number, of the form "n.nn", e.g. "3.14". See the REVISION section below to determine the current version number for AppConfig. Unpack the archive to create a AppConfig installation directory: gunzip AppConfig-<version>.tar.gz tar xvf AppConfig-<version>.tar 'cd' into that directory, make, test and install the modules: cd AppConfig-<version> perl Makefile.PL make make test make install The 't' sub-directory contains a number of test scripts that are run when a 'make test' is run. The 'make install' will install the module on your system. You may need administrator privileges to perform this task. If you install the module in a local directory (for example, by executing "perl Makefile.PL LIB=~/lib" in the above - see C<perldoc MakeMaker> for full details), you will need to ensure that the PERL5LIB environment variable is set to include the location, or add a line to your scripts explicitly naming the library location: use lib '/local/path/to/lib'; The 'examples' sub-directory contains some simple examples of using the AppConfig modules. =head1 DESCRIPTION =head2 USING THE AppConfig MODULE To import and use the L<AppConfig> module the following line should appear in your Perl script: use AppConfig; To import constants defined by the AppConfig module, specify the name of one or more of the constant or tag sets as parameters to C<use>: use AppConfig qw(:expand :argcount); See L<CONSTANT DEFINITIONS> below for more information on the constant tagsets defined by AppConfig. AppConfig is implemented using object-oriented methods. A new AppConfig object is created and initialized using the new() method. This returns a reference to a new AppConfig object. my $config = AppConfig->new(); This will create and return a reference to a new AppConfig object. In doing so, the AppConfig object also creates an internal reference to an AppConfig::State object in which to store variable state. All arguments passed into the AppConfig constructor are passed directly to the AppConfig::State constructor. The first (optional) parameter may be a reference to a hash array containing configuration information. my $config = AppConfig->new( { CASE => 1, ERROR => \&my_error, GLOBAL => { DEFAULT => "<unset>", ARGCOUNT => ARGCOUNT_ONE, }, } ); See L<AppConfig::State> for full details of the configuration options available. These are, in brief: =over 4 =item CASE Used to set case sensitivity for variable names (default: off). =item CREATE Used to indicate that undefined variables should be created automatically (default: off). =item GLOBAL Reference to a hash array of global values used by default when defining variables. Valid global values are DEFAULT, ARGCOUNT, EXPAND, VALIDATE and ACTION. =item PEDANTIC Used to indicate that command line and configuration file parsing routines should return immediately on encountering an error. =item ERROR Used to provide a error handling routine. Arguments as per printf(). =back Subsequent parameters may be variable definitions. These are passed to the define() method, described below in L<DEFINING VARIABLES>. my $config = AppConfig->new("foo", "bar", "baz"); my $config = AppConfig->new( { CASE => 1 }, qw(foo bar baz) ); Note that any unresolved method calls to AppConfig are automatically delegated to the AppConfig::State object. In practice, it means that it is possible to treat the AppConfig object as if it were an AppConfig::State object: # create AppConfig my $config = AppConfig->new('foo', 'bar'); # methods get passed through to internal AppConfig::State $config->foo(100); $config->set('bar', 200); $config->define('baz'); $config->baz(300); =head2 DEFINING VARIABLES The C<define()> method (delegated to AppConfig::State) is used to pre-declare a variable and specify its configuration. $config->define("foo"); Variables may also be defined directly from the AppConfig new() constructor. my $config = AppConfig->new("foo"); In both simple examples above, a new variable called "foo" is defined. A reference to a hash array may also be passed to specify configuration information for the variable: $config->define("foo", { DEFAULT => 99, ALIAS => 'metavar1', }); Configuration items specified in the GLOBAL option to the module constructor are applied by default when variables are created. e.g. my $config = AppConfig->new( { GLOBAL => { DEFAULT => "<undef>", ARGCOUNT => ARGCOUNT_ONE, } } ); $config->define("foo"); $config->define("bar", { ARGCOUNT => ARGCOUNT_NONE } ); is equivalent to: my $config = AppConfig->new(); $config->define( "foo", { DEFAULT => "<undef>", ARGCOUNT => ARGCOUNT_ONE, } ); $config->define( "bar", DEFAULT => "<undef>", ARGCOUNT => ARGCOUNT_NONE, } ); Multiple variables may be defined in the same call to define(). Configuration hashes for variables can be omitted. $config->define("foo", "bar" => { ALIAS = "boozer" }, "baz"); See L<AppConfig::State> for full details of the configuration options available when defining variables. These are, in brief: =over =item DEFAULT The default value for the variable (default: undef). =item ALIAS One or more (list reference or "list|like|this") alternative names for the variable. =item ARGCOUNT Specifies the number and type of arguments that the variable expects. Constants in C<:expand> tag set define ARGCOUNT_NONE - simple on/off flag (default), ARGCOUNT_ONE - single value, ARGCOUNT_LIST - multiple values accessed via list reference, ARGCOUNT_HASH - hash table, "key=value", accessed via hash reference. =item ARGS Used to provide an argument specification string to pass to Getopt::Long via AppConfig::Getopt. E.g. "=i", ":s", "=s@". This can also be used to implicitly set the ARGCOUNT value (C</^!/> = ARGCOUNT_NONE, C</@/> = ARGCOUNT_LIST, C</%/> = ARGCOUNT_HASH, C</[=:].*/> = ARGCOUNT_ONE) =item EXPAND Specifies which variable expansion policies should be used when parsing configuration files. Constants in C<:expand> tag set define: EXPAND_NONE - no expansion (default) EXPAND_VAR - expand C<$var> or C<$(var)> as other variables EXPAND_UID - expand C<~> and C<~uid> as user's home directory EXPAND_ENV - expand C<${var}> as environment variable EXPAND_ALL - do all expansions. =item VALIDATE Regex which the intended variable value should match or code reference which returns 1 to indicate successful validation (variable may now be set). =item ACTION Code reference to be called whenever variable value changes. =back =head2 COMPACT FORMAT DEFINITION Variables can be specified using a compact format. This is identical to the specification format of Getopt::Long and is of the form: "name|alias|alias<argopts>" The first element indicates the variable name and subsequent ALIAS values may be added, each separated by a vertical bar '|'. The E<lt>argoptsE<gt> element indicates the ARGCOUNT value and may be one of the following; ! ARGCOUNT_NONE =s ARGCOUNT_ONE =s@ ARGCOUNT_LIST =s% ARGCOUNT_HASH Additional constructs supported by Getopt::Long may be specified instead of the "=s" element (e.g. "=f"). The entire E<lt>argoptsE<gt> element is stored in the ARGS parameter for the variable and is passed intact to Getopt::Long when the getopt() method is called. The following examples demonstrate use of the compact format, with their equivalent full specifications: $config->define("foo|bar|baz!"); $config->define( "foo" => { ALIAS => "bar|baz", ARGCOUNT => ARGCOUNT_NONE, }); $config->define("name=s"); $config->define( "name" => { ARGCOUNT => ARGCOUNT_ONE, }); $config->define("file|filelist|f=s@"); $config->define( "file" => { ALIAS => "filelist|f", ARGCOUNT => ARGCOUNT_LIST, }); $config->define("user|u=s%"); $config->define( "user" => { ALIAS => "u", ARGCOUNT => ARGCOUNT_HASH, }); Additional configuration options may be specified by hash reference, as per normal. The compact definition format will override any configuration values provided for ARGS and ARGCOUNT. $config->define("file|filelist|f=s@", { VALIDATE => \&check_file } ); =head2 READING AND MODIFYING VARIABLE VALUES AppConfig defines two methods (via AppConfig::State) to manipulate variable values set($variable, $value); get($variable); Once defined, variables may be accessed directly as object methods where the method name is the same as the variable name. i.e. $config->set("verbose", 1); is equivalent to $config->verbose(1); Note that AppConfig defines the following methods: new(); file(); args(); getopt(); And also, through delegation to AppConfig::State: define() get() set() varlist() If you define a variable with one of the above names, you will not be able to access it directly as an object method. i.e. $config->file(); This will call the file() method, instead of returning the value of the 'file' variable. You can work around this by explicitly calling get() and set() on a variable whose name conflicts: $config->get('file'); or by defining a "safe" alias by which the variable can be accessed: $config->define("file", { ALIAS => "fileopt" }); or $config->define("file|fileopt"); ... $config->fileopt(); Without parameters, the current value of the variable is returned. If a parameter is specified, the variable is set to that value and the result of the set() operation is returned. $config->age(29); # sets 'age' to 29, returns 1 (ok) print $config->age(); # prints "29" The varlist() method can be used to extract a number of variables into a hash array. The first parameter should be a regular expression used for matching against the variable names. my %vars = $config->varlist("^file"); # all "file*" variables A second parameter may be specified (any true value) to indicate that the part of the variable name matching the regex should be removed when copied to the target hash. $config->file_name("/tmp/file"); $config->file_path("/foo:/bar:/baz"); my %vars = $config->varlist("^file_", 1); # %vars: # name => /tmp/file # path => "/foo:/bar:/baz" =head2 READING CONFIGURATION FILES The AppConfig module provides a streamlined interface for reading configuration files with the AppConfig::File module. The file() method automatically loads the AppConfig::File module and creates an object to process the configuration file or files. Variables stored in the internal AppConfig::State are automatically updated with values specified in the configuration file. $config->file($filename); Multiple files may be passed to file() and should indicate the file name or be a reference to an open file handle or glob. $config->file($filename, $filehandle, \*STDIN, ...); The file may contain blank lines and comments (prefixed by '#') which are ignored. Continutation lines may be marked by ending the line with a '\'. # this is a comment callsign = alpha bravo camel delta echo foxtrot golf hipowls \ india juliet kilo llama mike november oscar papa \ quebec romeo sierra tango umbrella victor whiskey \ x-ray yankee zebra Variables that are simple flags and do not expect an argument (ARGCOUNT = ARGCOUNT_NONE) can be specified without any value. They will be set with the value 1, with any value explicitly specified (except "0" and "off") being ignored. The variable may also be specified with a "no" prefix to implicitly set the variable to 0. verbose # on (1) verbose = 1 # on (1) verbose = 0 # off (0) verbose off # off (0) verbose on # on (1) verbose mumble # on (1) noverbose # off (0) Variables that expect an argument (ARGCOUNT = ARGCOUNT_ONE) will be set to whatever follows the variable name, up to the end of the current line (including any continuation lines). An optional equals sign may be inserted between the variable and value for clarity. room = /home/kitchen room /home/bedroom Each subsequent re-definition of the variable value overwrites the previous value. print $config->room(); # prints "/home/bedroom" Variables may be defined to accept multiple values (ARGCOUNT = ARGCOUNT_LIST). Each subsequent definition of the variable adds the value to the list of previously set values for the variable. drink = coffee drink = tea A reference to a list of values is returned when the variable is requested. my $beverages = $config->drink(); print join(", ", @$beverages); # prints "coffee, tea" Variables may also be defined as hash lists (ARGCOUNT = ARGCOUNT_HASH). Each subsequent definition creates a new key and value in the hash array. alias l="ls -CF" alias e="emacs" A reference to the hash is returned when the variable is requested. my $aliases = $config->alias(); foreach my $k (keys %$aliases) { print "$k => $aliases->{ $k }\n"; } The '-' prefix can be used to reset a variable to its default value and the '+' prefix can be used to set it to 1 -verbose +debug =head2 VARIABLE EXPANSION Variable values may contain references to other AppConfig variables, environment variables and/or users' home directories. These will be expanded depending on the EXPAND value for each variable or the GLOBAL EXPAND value. Three different expansion types may be applied: bin = ~/bin # expand '~' to home dir if EXPAND_UID tmp = ~abw/tmp # as above, but home dir for user 'abw' perl = $bin/perl # expand value of 'bin' variable if EXPAND_VAR ripl = $(bin)/ripl # as above with explicit parens home = ${HOME} # expand HOME environment var if EXPAND_ENV See L<AppConfig::State> for more information on expanding variable values. The configuration files may have variables arranged in blocks. A block header, consisting of the block name in square brackets, introduces a configuration block. The block name and an underscore are then prefixed to the names of all variables subsequently referenced in that block. The block continues until the next block definition or to the end of the current file. [block1] foo = 10 # block1_foo = 10 [block2] foo = 20 # block2_foo = 20 =head2 PARSING COMMAND LINE OPTIONS There are two methods for processing command line options. The first, args(), is a small and efficient implementation which offers basic functionality. The second, getopt(), offers a more powerful and complete facility by delegating the task to Johan Vroman's Getopt::Long module. The trade-off between args() and getopt() is essentially one of speed/size against flexibility. Use as appropriate. Both implement on-demand loading of modules and incur no overhead until used. The args() method is used to parse simple command line options. It automatically loads the AppConfig::Args module and creates an object to process the command line arguments. Variables stored in the internal AppConfig::State are automatically updated with values specified in the arguments. The method should be passed a reference to a list of arguments to parse. The @ARGV array is used if args() is called without parameters. $config->args(\@myargs); $config->args(); # uses @ARGV Arguments are read and shifted from the array until the first is encountered that is not prefixed by '-' or '--'. At that point, the method returns 1 to indicate success, leaving any unprocessed arguments remaining in the list. Each argument should be the name or alias of a variable prefixed by '-' or '--'. Arguments that are not prefixed as such (and are not an additional parameter to a previous argument) will cause a warning to be raised. If the PEDANTIC option is set, the method will return 0 immediately. With PEDANTIC unset (default), the method will continue to parse the rest of the arguments, returning 0 when done. If the variable is a simple flag (ARGCOUNT = ARGCOUNT_NONE) then it is set to the value 1. The variable may be prefixed by "no" to set its value to 0. myprog -verbose --debug -notaste # $config->verbose(1) # $config->debug(1) # $config->taste(0) Variables that expect an additional argument (ARGCOUNT != 0) will be set to the value of the argument following it. myprog -f /tmp/myfile # $config->file('/tmp/file'); Variables that expect multiple values (ARGCOUNT = ARGCOUNT_LIST or ARGCOUNT_HASH) will have successive values added each time the option is encountered. myprog -file /tmp/foo -file /tmp/bar # $config->file('/tmp/foo') # $config->file('/tmp/bar') # file => [ '/tmp/foo', '/tmp/bar' ] myprog -door "jim=Jim Morrison" -door "ray=Ray Manzarek" # $config->door("jim=Jim Morrison"); # $config->door("ray=Ray Manzarek"); # door => { 'jim' => 'Jim Morrison', 'ray' => 'Ray Manzarek' } See L<AppConfig::Args> for further details on parsing command line arguments. The getopt() method provides a way to use the power and flexibility of the Getopt::Long module to parse command line arguments and have the internal values of the AppConfig object updates automatically. The first (non-list reference) parameters may contain a number of configuration string to pass to Getopt::Long::Configure. A reference to a list of arguments may additionally be passed or @ARGV is used by default. $config->getopt(); # uses @ARGV $config->getopt(\@myargs); $config->getopt(qw(auto_abbrev debug)); # uses @ARGV $config->getopt(qw(debug), \@myargs); See Getopt::Long for details of the configuration options available. The getopt() method constructs a specification string for each internal variable and then initializes Getopt::Long with these values. The specification string is constructed from the name, any aliases (delimited by a vertical bar '|') and the value of the ARGS parameter. $config->define("foo", { ARGS => "=i", ALIAS => "bar|baz", }); # Getopt::Long specification: "foo|bar|baz=i" Errors and warning generated by the Getopt::Long module are trapped and handled by the AppConfig error handler. This may be a user-defined routine installed with the ERROR configuration option. Please note that the AppConfig::Getopt interface is still experimental and may not be 100% operational. This is almost undoubtedly due to problems in AppConfig::Getopt rather than Getopt::Long. =head2 PARSING CGI PARAMETERS The cgi() method provides an interface to the AppConfig::CGI module for updating variable values based on the parameters appended to the URL for a CGI script. This is commonly known as the CGI "GET" method. The CGI "POST" method is currently not supported. Parameter definitions are separated from the CGI script name by a question mark and from each other by ampersands. Where variables have specific values, these are appended to the variable with an equals sign: http://www.here.com/cgi-bin/myscript?foo=bar&baz=qux&verbose # $config->foo('bar'); # $config->baz('qux'); # $config->verbose(1); Certain values specified in a URL must be escaped in the appropriate manner (see CGI specifications at http://www.w3c.org/ for full details). The AppConfig::CGI module automatically unescapes the CGI query string to restore the parameters to their intended values. http://where.com/mycgi?title=%22The+Wrong+Trousers%22 # $config->title('"The Wrong Trousers"'); Please be considerate of the security implications of providing writable access to script variables via CGI. http://rebel.alliance.com/cgi-bin/... .../send_report?file=%2Fetc%2Fpasswd&email=darth%40empire.com To avoid any accidental or malicious changing of "private" variables, define only the "public" variables before calling the cgi() (or any other) method. Further variables can subsequently be defined which can not be influenced by the CGI parameters. $config->define('verbose', 'debug') $config->cgi(); # can only set verbose and debug $config->define('email', 'file'); $config->file($cfgfile); # can set verbose, debug, email + file =head1 CONSTANT DEFINITIONS A number of constants are defined by the AppConfig module. These may be accessed directly (e.g. AppConfig::EXPAND_VARS) or by first importing them into the caller's package. Constants are imported by specifying their names as arguments to C<use AppConfig> or by importing a set of constants identified by its "tag set" name. use AppConfig qw(ARGCOUNT_NONE ARGCOUNT_ONE); use AppConfig qw(:argcount); The following tag sets are defined: =over 4 =item :expand The ':expand' tagset defines the following constants: EXPAND_NONE EXPAND_VAR EXPAND_UID EXPAND_ENV EXPAND_ALL # EXPAND_VAR | EXPAND_UID | EXPAND_ENV EXPAND_WARN See AppConfig::File for full details of the use of these constants. =item :argcount The ':argcount' tagset defines the following constants: ARGCOUNT_NONE ARGCOUNT_ONE ARGCOUNT_LIST ARGCOUNT_HASH See AppConfig::State for full details of the use of these constants. =back =head1 REPOSITORY L<https://github.com/neilbowers/AppConfig> =head1 AUTHOR Andy Wardley, E<lt>abw@wardley.orgE<gt> With contributions from Dave Viner, Ijon Tichy, Axel Gerstmair and many others whose names have been lost to the sands of time (reminders welcome). =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L<AppConfig::State>, L<AppConfig::File>, L<AppConfig::Args>, L<AppConfig::Getopt>, L<AppConfig::CGI>, L<Getopt::Long> =cut perl5/AppConfig/File.pm 0000444 00000057016 14711220313 0010657 0 ustar 00 #============================================================================ # # AppConfig::File.pm # # Perl5 module to read configuration files and use the contents therein # to update variable values in an AppConfig::State object. # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. # #============================================================================ package AppConfig::File; use 5.006; use strict; use warnings; use AppConfig; use AppConfig::State; our $VERSION = '1.71'; #------------------------------------------------------------------------ # new($state, $file, [$file, ...]) # # Module constructor. The first, mandatory parameter should be a # reference to an AppConfig::State object to which all actions should # be applied. The remaining parameters are assumed to be file names or # file handles for reading and are passed to parse(). # # Returns a reference to a newly created AppConfig::File object. #------------------------------------------------------------------------ sub new { my $class = shift; my $state = shift; my $self = { STATE => $state, # AppConfig::State ref DEBUG => $state->_debug(), # store local copy of debug PEDANTIC => $state->_pedantic, # and pedantic flags }; bless $self, $class; # call parse(@_) to parse any files specified as further params $self->parse(@_) if @_; return $self; } #------------------------------------------------------------------------ # parse($file, [file, ...]) # # Reads and parses a config file, updating the contents of the # AppConfig::State referenced by $self->{ STATE } according to the # contents of the file. Multiple files may be specified and are # examined in turn. The method reports any error condition via # $self->{ STATE }->_error() and immediately returns undef if it # encounters a system error (i.e. cannot open one of the files. # Parsing errors such as unknown variables or unvalidated values will # also cause warnings to be raised vi the same _error(), but parsing # continues to the end of the current file and through any subsequent # files. If the PEDANTIC option is set in the $self->{ STATE } object, # the behaviour is overridden and the method returns 0 immediately on # any system or parsing error. # # The EXPAND option for each variable determines how the variable # value should be expanded. # # Returns undef on system error, 0 if all files were parsed but generated # one or more warnings, 1 if all files parsed without warnings. #------------------------------------------------------------------------ sub parse { my $self = shift; my $warnings = 0; my $prefix; # [block] defines $prefix my $file; my $flag; # take a local copy of the state to avoid much hash dereferencing my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) }; # we want to install a custom error handler into the AppConfig::State # which appends filename and line info to error messages and then # calls the previous handler; we start by taking a copy of the # current handler.. my $errhandler = $state->_ehandler(); # ...and if it doesn't exist, we craft a default handler $errhandler = sub { warn(sprintf(shift, @_), "\n") } unless defined $errhandler; # install a closure as a new error handler $state->_ehandler( sub { # modify the error message my $format = shift; $format .= ref $file ? " at line $." : " at $file line $."; # chain call to prevous handler &$errhandler($format, @_); } ); # trawl through all files passed as params FILE: while ($file = shift) { # local/lexical vars ensure opened files get closed my $handle; local *FH; # if the file is a reference, we assume it's a file handle, if # not, we assume it's a filename and attempt to open it $handle = $file; if (ref($file)) { $handle = $file; # DEBUG print STDERR "reading from file handle: $file\n" if $debug; } else { # open and read config file open(FH, $file) or do { # restore original error handler and report error $state->_ehandler($errhandler); $state->_error("$file: $!"); return undef; }; $handle = \*FH; # DEBUG print STDERR "reading file: $file\n" if $debug; } # initialise $prefix to nothing (no [block]) $prefix = ''; local $_; while (<$handle>) { chomp; # Throw away everything from an unescaped # to EOL s/(^|\s+)#.*/$1/; # add next line if there is one and this is a continuation if (s/\\$// && !eof($handle)) { $_ .= <$handle>; redo; } # Convert \# -> # s/\\#/#/g; # ignore blank lines next if /^\s*$/; # strip leading and trailing whitespace s/^\s+//; s/\s+$//; # look for a [block] to set $prefix if (/^\[([^\]]+)\]$/) { $prefix = $1; print STDERR "Entering [$prefix] block\n" if $debug; next; } # split line up by whitespace (\s+) or "equals" (\s*=\s*) if (/^([^\s=]+)(?:(?:(?:\s*=\s*)|\s+)(.*))?/) { my ($variable, $value) = ($1, $2); if (defined $value) { # here document if ($value =~ /^([^\s=]+\s*=)?\s*<<(['"]?)(\S+)\2$/) { # '<<XX' or 'hashkey =<<XX' my $boundary = "$3\n"; $value = defined($1) ? $1 : ''; while (<$handle>) { last if $_ eq $boundary; $value .= $_; }; $value =~ s/[\r\n]$//; } else { # strip any quoting from the variable value $value =~ s/^(['"])(.*)\1$/$2/; }; }; # strip any leading '+/-' from the variable $variable =~ s/^([\-+]?)//; $flag = $1; # $variable gets any $prefix $variable = $prefix . '_' . $variable if length $prefix; # if the variable doesn't exist, we call set() to give # AppConfig::State a chance to auto-create it unless ($state->_exists($variable) || $state->set($variable, 1)) { $warnings++; last FILE if $pedantic; next; } my $nargs = $state->_argcount($variable); # variables prefixed '-' are reset to their default values if ($flag eq '-') { $state->_default($variable); next; } # those prefixed '+' get set to 1 elsif ($flag eq '+') { $value = 1 unless defined $value; } # determine if any extra arguments were expected if ($nargs) { if (defined $value && length $value) { # expand any embedded variables, ~uids or # environment variables, testing the return value # for errors; we pass in any variable-specific # EXPAND value unless ($self->_expand(\$value, $state->_expand($variable), $prefix)) { print STDERR "expansion of [$value] failed\n" if $debug; $warnings++; last FILE if $pedantic; } } else { $state->_error("$variable expects an argument"); $warnings++; last FILE if $pedantic; next; } } # $nargs = 0 else { # default value to 1 unless it is explicitly defined # as '0' or "off" if (defined $value) { # "off" => 0 $value = 0 if $value =~ /off/i; # any value => 1 $value = 1 if $value; } else { # assume 1 unless explicitly defined off/0 $value = 1; } print STDERR "$variable => $value (no expansion)\n" if $debug; } # set the variable, noting any failure from set() unless ($state->set($variable, $value)) { $warnings++; last FILE if $pedantic; } } else { $state->_error("parse error"); $warnings++; } } } # restore original error handler $state->_ehandler($errhandler); # return $warnings => 0, $success => 1 return $warnings ? 0 : 1; } #======================================================================== # ----- PRIVATE METHODS ----- #======================================================================== #------------------------------------------------------------------------ # _expand(\$value, $expand, $prefix) # # The variable value string, referenced by $value, is examined and any # embedded variables, environment variables or tilde globs (home # directories) are replaced with their respective values, depending on # the value of the second parameter, $expand. The third paramter may # specify the name of the current [block] in which the parser is # parsing. This prefix is prepended to any embedded variable name that # can't otherwise be resolved. This allows the following to work: # # [define] # home = /home/abw # html = $define_home/public_html # html = $home/public_html # same as above, 'define' is prefix # # Modifications are made directly into the variable referenced by $value. # The method returns 1 on success or 0 if any warnings (undefined # variables) were encountered. #------------------------------------------------------------------------ sub _expand { my ($self, $value, $expand, $prefix) = @_; my $warnings = 0; my ($sys, $var, $val); # ensure prefix contains something (nothing!) valid for length() $prefix = "" unless defined $prefix; # take a local copy of the state to avoid much hash dereferencing my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) }; # bail out if there's nothing to do return 1 unless $expand && defined($$value); # create an AppConfig::Sys instance, or re-use a previous one, # to handle platform dependant functions: getpwnam(), getpwuid() unless ($sys = $self->{ SYS }) { require AppConfig::Sys; $sys = $self->{ SYS } = AppConfig::Sys->new(); } print STDERR "Expansion of [$$value] " if $debug; EXPAND: { # # EXPAND_VAR # expand $(var) and $var as AppConfig::State variables # if ($expand & AppConfig::EXPAND_VAR) { $$value =~ s{ (?<!\\)\$ (?: \((\w+)\) | (\w+) ) # $2 => $(var) | $3 => $var } { # embedded variable name will be one of $2 or $3 $var = defined $1 ? $1 : $2; # expand the variable if defined if ($state->_exists($var)) { $val = $state->get($var); } elsif (length $prefix && $state->_exists($prefix . '_' . $var)) { print STDERR "(\$$var => \$${prefix}_$var) " if $debug; $var = $prefix . '_' . $var; $val = $state->get($var); } else { # raise a warning if EXPAND_WARN set if ($expand & AppConfig::EXPAND_WARN) { $state->_error("$var: no such variable"); $warnings++; } # replace variable with nothing $val = ''; } # $val gets substituted back into the $value string $val; }gex; $$value =~ s/\\\$/\$/g; # bail out now if we need to last EXPAND if $warnings && $pedantic; } # # EXPAND_UID # expand ~uid as home directory (for $< if uid not specified) # if ($expand & AppConfig::EXPAND_UID) { $$value =~ s{ ~(\w+)? # $1 => username (optional) } { $val = undef; # embedded user name may be in $1 if (defined ($var = $1)) { # try and get user's home directory if ($sys->can_getpwnam()) { $val = ($sys->getpwnam($var))[7]; } } else { # determine home directory $val = $ENV{ HOME }; } # catch-all for undefined $dir unless (defined $val) { # raise a warning if EXPAND_WARN set if ($expand & AppConfig::EXPAND_WARN) { $state->_error("cannot determine home directory%s", defined $var ? " for $var" : ""); $warnings++; } # replace variable with nothing $val = ''; } # $val gets substituted back into the $value string $val; }gex; # bail out now if we need to last EXPAND if $warnings && $pedantic; } # # EXPAND_ENV # expand ${VAR} as environment variables # if ($expand & AppConfig::EXPAND_ENV) { $$value =~ s{ ( \$ \{ (\w+) \} ) } { $var = $2; # expand the variable if defined if (exists $ENV{ $var }) { $val = $ENV{ $var }; } elsif ( $var eq 'HOME' ) { # In the special case of HOME, if not set # use the internal version $val = $self->{ HOME }; } else { # raise a warning if EXPAND_WARN set if ($expand & AppConfig::EXPAND_WARN) { $state->_error("$var: no such environment variable"); $warnings++; } # replace variable with nothing $val = ''; } # $val gets substituted back into the $value string $val; }gex; # bail out now if we need to last EXPAND if $warnings && $pedantic; } } print STDERR "=> [$$value] (EXPAND = $expand)\n" if $debug; # return status return $warnings ? 0 : 1; } #------------------------------------------------------------------------ # _dump() # # Dumps the contents of the Config object. #------------------------------------------------------------------------ sub _dump { my $self = shift; foreach my $key (keys %$self) { printf("%-10s => %s\n", $key, defined($self->{ $key }) ? $self->{ $key } : "<undef>"); } } 1; __END__ =head1 NAME AppConfig::File - Perl5 module for reading configuration files. =head1 SYNOPSIS use AppConfig::File; my $state = AppConfig::State->new(\%cfg1); my $cfgfile = AppConfig::File->new($state, $file); $cfgfile->parse($file); # read config file =head1 OVERVIEW AppConfig::File is a Perl5 module which reads configuration files and use the contents therein to update variable values in an AppConfig::State object. AppConfig::File is distributed as part of the AppConfig bundle. =head1 DESCRIPTION =head2 USING THE AppConfig::File MODULE To import and use the AppConfig::File module the following line should appear in your Perl script: use AppConfig::File; AppConfig::File is used automatically if you use the AppConfig module and create an AppConfig::File object through the file() method. AppConfig::File is implemented using object-oriented methods. A new AppConfig::File object is created and initialised using the AppConfig::File->new() method. This returns a reference to a new AppConfig::File object. A reference to an AppConfig::State object should be passed in as the first parameter: my $state = AppConfig::State->new(); my $cfgfile = AppConfig::File->new($state); This will create and return a reference to a new AppConfig::File object. =head2 READING CONFIGURATION FILES The C<parse()> method is used to read a configuration file and have the contents update the STATE accordingly. $cfgfile->parse($file); Multiple files maye be specified and will be read in turn. $cfgfile->parse($file1, $file2, $file3); The method will return an undef value if it encounters any errors opening the files. It will return immediately without processing any further files. By default, the PEDANTIC option in the AppConfig::State object, $self->{ STATE }, is turned off and any parsing errors (invalid variables, unvalidated values, etc) will generated warnings, but not cause the method to return. Having processed all files, the method will return 1 if all files were processed without warning or 0 if one or more warnings were raised. When the PEDANTIC option is turned on, the method generates a warning and immediately returns a value of 0 as soon as it encounters any parsing error. Variables values in the configuration files may be expanded depending on the value of their EXPAND option, as determined from the App::State object. See L<AppConfig::State> for more information on variable expansion. =head2 CONFIGURATION FILE FORMAT A configuration file may contain blank lines and comments which are ignored. Comments begin with a '#' as the first character on a line or following one or more whitespace tokens, and continue to the end of the line. # this is a comment foo = bar # so is this url = index.html#hello # this too, but not the '#welcome' Notice how the '#welcome' part of the URL is not treated as a comment because a whitespace character doesn't precede it. Long lines can be continued onto the next line by ending the first line with a '\'. callsign = alpha bravo camel delta echo foxtrot golf hipowls \ india juliet kilo llama mike november oscar papa \ quebec romeo sierra tango umbrella victor whiskey \ x-ray yankee zebra Variables that are simple flags and do not expect an argument (ARGCOUNT = ARGCOUNT_NONE) can be specified without any value. They will be set with the value 1, with any value explicitly specified (except "0" and "off") being ignored. The variable may also be specified with a "no" prefix to implicitly set the variable to 0. verbose # on (1) verbose = 1 # on (1) verbose = 0 # off (0) verbose off # off (0) verbose on # on (1) verbose mumble # on (1) noverbose # off (0) Variables that expect an argument (ARGCOUNT = ARGCOUNT_ONE) will be set to whatever follows the variable name, up to the end of the current line. An equals sign may be inserted between the variable and value for clarity. room = /home/kitchen room /home/bedroom Each subsequent re-definition of the variable value overwrites the previous value. print $config->room(); # prints "/home/bedroom" Variables may be defined to accept multiple values (ARGCOUNT = ARGCOUNT_LIST). Each subsequent definition of the variable adds the value to the list of previously set values for the variable. drink = coffee drink = tea A reference to a list of values is returned when the variable is requested. my $beverages = $config->drinks(); print join(", ", @$beverages); # prints "coffee, tea" Variables may also be defined as hash lists (ARGCOUNT = ARGCOUNT_HASH). Each subsequent definition creates a new key and value in the hash array. alias l="ls -CF" alias h="history" A reference to the hash is returned when the variable is requested. my $aliases = $config->alias(); foreach my $k (keys %$aliases) { print "$k => $aliases->{ $k }\n"; } A large chunk of text can be defined using Perl's "heredoc" quoting style. scalar = <<BOUNDARY_STRING line 1 line 2: Space/linebreaks within a HERE document are kept. line 3: The last linebreak (\n) is stripped. BOUNDARY_STRING hash key1 = <<'FOO' * Quotes (['"]) around the boundary string are simply ignored. * Whether the variables in HERE document are expanded depends on the EXPAND option of the variable or global setting. FOO hash = key2 = <<"_bar_" Text within HERE document are kept as is. # comments are treated as a normal text. The same applies to line continuation. \ _bar_ Note that you cannot use HERE document as a key in a hash or a name of a variable. The '-' prefix can be used to reset a variable to its default value and the '+' prefix can be used to set it to 1 -verbose +debug Variable, environment variable and tilde (home directory) expansions Variable values may contain references to other AppConfig variables, environment variables and/or users' home directories. These will be expanded depending on the EXPAND value for each variable or the GLOBAL EXPAND value. Three different expansion types may be applied: bin = ~/bin # expand '~' to home dir if EXPAND_UID tmp = ~abw/tmp # as above, but home dir for user 'abw' perl = $bin/perl # expand value of 'bin' variable if EXPAND_VAR ripl = $(bin)/ripl # as above with explicit parens home = ${HOME} # expand HOME environment var if EXPAND_ENV See L<AppConfig::State> for more information on expanding variable values. The configuration files may have variables arranged in blocks. A block header, consisting of the block name in square brackets, introduces a configuration block. The block name and an underscore are then prefixed to the names of all variables subsequently referenced in that block. The block continues until the next block definition or to the end of the current file. [block1] foo = 10 # block1_foo = 10 [block2] foo = 20 # block2_foo = 20 =head1 AUTHOR Andy Wardley, E<lt>abw@wardley.orgE<gt> =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO AppConfig, AppConfig::State =cut perl5/AppConfig/Getopt.pm 0000444 00000020063 14711220314 0011233 0 ustar 00 #============================================================================ # # AppConfig::Getopt.pm # # Perl5 module to interface AppConfig::* to Johan Vromans' Getopt::Long # module. Getopt::Long implements the POSIX standard for command line # options, with GNU extensions, and also traditional one-letter options. # AppConfig::Getopt constructs the necessary Getopt:::Long configuration # from the internal AppConfig::State and delegates the parsing of command # line arguments to it. Internal variable values are updated by callback # from GetOptions(). # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. # #============================================================================ package AppConfig::Getopt; use 5.006; use strict; use warnings; use AppConfig::State; use Getopt::Long 2.17; our $VERSION = '1.71'; #------------------------------------------------------------------------ # new($state, \@args) # # Module constructor. The first, mandatory parameter should be a # reference to an AppConfig::State object to which all actions should # be applied. The second parameter may be a reference to a list of # command line arguments. This list reference is passed to parse() for # processing. # # Returns a reference to a newly created AppConfig::Getopt object. #------------------------------------------------------------------------ sub new { my $class = shift; my $state = shift; my $self = { STATE => $state, }; bless $self, $class; # call parse() to parse any arg list passed $self->parse(@_) if @_; return $self; } #------------------------------------------------------------------------ # parse(@$config, \@args) # # Constructs the appropriate configuration information and then delegates # the task of processing command line options to Getopt::Long. # # Returns 1 on success or 0 if one or more warnings were raised. #------------------------------------------------------------------------ sub parse { my $self = shift; my $state = $self->{ STATE }; my (@config, $args, $getopt); local $" = ', '; # we trap $SIG{__WARN__} errors and patch them into AppConfig::State local $SIG{__WARN__} = sub { my $msg = shift; # AppConfig::State doesn't expect CR terminated error messages # and it uses printf, so we protect any embedded '%' chars chomp($msg); $state->_error("%s", $msg); }; # slurp all config items into @config push(@config, shift) while defined $_[0] && ! ref($_[0]); # add debug status if appropriate (hmm...can't decide about this) # push(@config, 'debug') if $state->_debug(); # next parameter may be a reference to a list of args $args = shift; # copy any args explicitly specified into @ARGV @ARGV = @$args if defined $args; # we enclose in an eval block because constructor may die() eval { # configure Getopt::Long Getopt::Long::Configure(@config); # construct options list from AppConfig::State variables my @opts = $self->{ STATE }->_getopt_state(); # DEBUG if ($state->_debug()) { print STDERR "Calling GetOptions(@opts)\n"; print STDERR "\@ARGV = (@ARGV)\n"; }; # call GetOptions() with specifications constructed from the state $getopt = GetOptions(@opts); }; if ($@) { chomp($@); $state->_error("%s", $@); return 0; } # udpdate any args reference passed to include only that which is left # in @ARGV @$args = @ARGV if defined $args; return $getopt; } #======================================================================== # AppConfig::State #======================================================================== package AppConfig::State; #------------------------------------------------------------------------ # _getopt_state() # # Constructs option specs in the Getopt::Long format for each variable # definition. # # Returns a list of specification strings. #------------------------------------------------------------------------ sub _getopt_state { my $self = shift; my ($var, $spec, $args, $argcount, @specs); my $linkage = sub { $self->set(@_) }; foreach $var (keys %{ $self->{ VARIABLE } }) { $spec = join('|', $var, @{ $self->{ ALIASES }->{ $var } || [ ] }); # an ARGS value is used, if specified unless (defined ($args = $self->{ ARGS }->{ $var })) { # otherwise, construct a basic one from ARGCOUNT ARGCOUNT: { last ARGCOUNT unless defined ($argcount = $self->{ ARGCOUNT }->{ $var }); $args = "=s", last ARGCOUNT if $argcount eq ARGCOUNT_ONE; $args = "=s@", last ARGCOUNT if $argcount eq ARGCOUNT_LIST; $args = "=s%", last ARGCOUNT if $argcount eq ARGCOUNT_HASH; $args = "!"; } } $spec .= $args if defined $args; push(@specs, $spec, $linkage); } return @specs; } 1; __END__ =head1 NAME AppConfig::Getopt - Perl5 module for processing command line arguments via delegation to Getopt::Long. =head1 SYNOPSIS use AppConfig::Getopt; my $state = AppConfig::State->new(\%cfg); my $getopt = AppConfig::Getopt->new($state); $getopt->parse(\@args); # read args =head1 OVERVIEW AppConfig::Getopt is a Perl5 module which delegates to Johan Vroman's Getopt::Long module to parse command line arguments and update values in an AppConfig::State object accordingly. AppConfig::Getopt is distributed as part of the AppConfig bundle. =head1 DESCRIPTION =head2 USING THE AppConfig::Getopt MODULE To import and use the AppConfig::Getopt module the following line should appear in your Perl script: use AppConfig::Getopt; AppConfig::Getopt is used automatically if you use the AppConfig module and create an AppConfig::Getopt object through the getopt() method. AppConfig::Getopt is implemented using object-oriented methods. A new AppConfig::Getopt object is created and initialised using the new() method. This returns a reference to a new AppConfig::Getopt object. A reference to an AppConfig::State object should be passed in as the first parameter: my $state = AppConfig::State->new(); my $getopt = AppConfig::Getopt->new($state); This will create and return a reference to a new AppConfig::Getopt object. =head2 PARSING COMMAND LINE ARGUMENTS The C<parse()> method is used to read a list of command line arguments and update the state accordingly. The first (non-list reference) parameters may contain a number of configuration strings to pass to Getopt::Long::Configure. A reference to a list of arguments may additionally be passed or @ARGV is used by default. $getopt->parse(); # uses @ARGV $getopt->parse(\@myargs); $getopt->parse(qw(auto_abbrev debug)); # uses @ARGV $getopt->parse(qw(debug), \@myargs); See Getopt::Long for details of the configuartion options available. A Getopt::Long specification string is constructed for each variable defined in the AppConfig::State. This consists of the name, any aliases and the ARGS value for the variable. These specification string are then passed to Getopt::Long, the arguments are parsed and the values in the AppConfig::State updated. See AppConfig for information about using the AppConfig::Getopt module via the getopt() method. =head1 AUTHOR Andy Wardley, E<lt>abw@wardley.orgE<gt> =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 ACKNOWLEDGMENTS Many thanks are due to Johan Vromans for the Getopt::Long module. He was kind enough to offer assistance and access to early releases of his code to enable this module to be written. =head1 SEE ALSO AppConfig, AppConfig::State, AppConfig::Args, Getopt::Long =cut perl5/AppConfig/State.pm 0000444 00000134414 14711220315 0011060 0 ustar 00 #============================================================================ # # AppConfig::State.pm # # Perl5 module in which configuration information for an application can # be stored and manipulated. AppConfig::State objects maintain knowledge # about variables; their identities, options, aliases, targets, callbacks # and so on. This module is used by a number of other AppConfig::* modules. # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. # #---------------------------------------------------------------------------- # # TODO # # * Change varlist() to varhash() and provide another varlist() method # which returns a list. Multiple parameters passed implies a hash # slice/list grep, a single parameter should indicate a regex. # # * Perhaps allow a callback to be installed which is called *instead* of # the get() and set() methods (or rather, is called by them). # # * Maybe CMDARG should be in there to specify extra command-line only # options that get added to the AppConfig::GetOpt alias construction, # but not applied in config files, general usage, etc. The GLOBAL # CMDARG might be specified as a format, e.g. "-%c" where %s = name, # %c = first character, %u - first unique sequence(?). Will # GetOpt::Long handle --long to -l application automagically? # # * ..and an added thought is that CASE sensitivity may be required for the # command line (-v vs -V, -r vs -R, for example), but not for parsing # config files where you may wish to treat "Name", "NAME" and "name" alike. # #============================================================================ package AppConfig::State; use 5.006; use strict; use warnings; our $VERSION = '1.71'; our $DEBUG = 0; our $AUTOLOAD; # need access to AppConfig::ARGCOUNT_* use AppConfig ':argcount'; # internal per-variable hashes that AUTOLOAD should provide access to my %METHVARS; @METHVARS{ qw( EXPAND ARGS ARGCOUNT ) } = (); # internal values that AUTOLOAD should provide access to my %METHFLAGS; @METHFLAGS{ qw( PEDANTIC ) } = (); # variable attributes that may be specified in GLOBAL; my @GLOBAL_OK = qw( DEFAULT EXPAND VALIDATE ACTION ARGS ARGCOUNT ); #------------------------------------------------------------------------ # new(\%config, @vars) # # Module constructor. A reference to a hash array containing # configuration options may be passed as the first parameter. This is # passed off to _configure() for processing. See _configure() for # information about configurarion options. The remaining parameters # may be variable definitions and are passed en masse to define() for # processing. # # Returns a reference to a newly created AppConfig::State object. #------------------------------------------------------------------------ sub new { my $class = shift; my $self = { # internal hash arrays to store variable specification information VARIABLE => { }, # variable values DEFAULT => { }, # default values ALIAS => { }, # known aliases ALIAS => VARIABLE ALIASES => { }, # reverse alias lookup VARIABLE => ALIASES ARGCOUNT => { }, # arguments expected ARGS => { }, # specific argument pattern (AppConfig::Getopt) EXPAND => { }, # variable expansion (AppConfig::File) VALIDATE => { }, # validation regexen or functions ACTION => { }, # callback functions for when variable is set GLOBAL => { }, # default global settings for new variables # other internal data CREATE => 0, # auto-create variables when set CASE => 0, # case sensitivity flag (1 = sensitive) PEDANTIC => 0, # return immediately on parse warnings EHANDLER => undef, # error handler (let's hope we don't need it!) ERROR => '', # error message }; bless $self, $class; # configure if first param is a config hash ref $self->_configure(shift) if ref($_[0]) eq 'HASH'; # call define(@_) to handle any variables definitions $self->define(@_) if @_; return $self; } #------------------------------------------------------------------------ # define($variable, \%cfg, [$variable, \%cfg, ...]) # # Defines one or more variables. The first parameter specifies the # variable name. The following parameter may reference a hash of # configuration options for the variable. Further variables and # configuration hashes may follow and are processed in turn. If the # parameter immediately following a variable name isn't a hash reference # then it is ignored and the variable is defined without a specific # configuration, although any default parameters as specified in the # GLOBAL option will apply. # # The $variable value may contain an alias/args definition in compact # format, such as "Foo|Bar=1". # # A warning is issued (via _error()) if an invalid option is specified. #------------------------------------------------------------------------ sub define { my $self = shift; my ($var, $args, $count, $opt, $val, $cfg, @names); while (@_) { $var = shift; $cfg = ref($_[0]) eq 'HASH' ? shift : { }; # variable may be specified in compact format, 'foo|bar=i@' if ($var =~ s/(.+?)([!+=:].*)/$1/) { # anything coming after the name|alias list is the ARGS $cfg->{ ARGS } = $2 if length $2; } # examine any ARGS option if (defined ($args = $cfg->{ ARGS })) { ARGGCOUNT: { $count = ARGCOUNT_NONE, last if $args =~ /^!/; $count = ARGCOUNT_LIST, last if $args =~ /@/; $count = ARGCOUNT_HASH, last if $args =~ /%/; $count = ARGCOUNT_ONE; } $cfg->{ ARGCOUNT } = $count; } # split aliases out @names = split(/\|/, $var); $var = shift @names; $cfg->{ ALIAS } = [ @names ] if @names; # variable name gets folded to lower unless CASE sensitive $var = lc $var unless $self->{ CASE }; # activate $variable (so it does 'exist()') $self->{ VARIABLE }->{ $var } = undef; # merge GLOBAL and variable-specific configurations $cfg = { %{ $self->{ GLOBAL } }, %$cfg }; # examine each variable configuration parameter while (($opt, $val) = each %$cfg) { $opt = uc $opt; # DEFAULT, VALIDATE, EXPAND, ARGS and ARGCOUNT are stored as # they are; $opt =~ /^DEFAULT|VALIDATE|EXPAND|ARGS|ARGCOUNT$/ && do { $self->{ $opt }->{ $var } = $val; next; }; # CMDARG has been deprecated $opt eq 'CMDARG' && do { $self->_error("CMDARG has been deprecated. " . "Please use an ALIAS if required."); next; }; # ACTION should be a code ref $opt eq 'ACTION' && do { unless (ref($val) eq 'CODE') { $self->_error("'$opt' value is not a code reference"); next; }; # store code ref, forcing keyword to upper case $self->{ ACTION }->{ $var } = $val; next; }; # ALIAS creates alias links to the variable name $opt eq 'ALIAS' && do { # coerce $val to an array if not already so $val = [ split(/\|/, $val) ] unless ref($val) eq 'ARRAY'; # fold to lower case unless CASE sensitivity set unless ($self->{ CASE }) { @$val = map { lc } @$val; } # store list of aliases... $self->{ ALIASES }->{ $var } = $val; # ...and create ALIAS => VARIABLE lookup hash entries foreach my $a (@$val) { $self->{ ALIAS }->{ $a } = $var; } next; }; # default $self->_error("$opt is not a valid configuration item"); } # set variable to default value $self->_default($var); # DEBUG: dump new variable definition if ($DEBUG) { print STDERR "Variable defined:\n"; $self->_dump_var($var); } } } #------------------------------------------------------------------------ # get($variable) # # Returns the value of the variable specified, $variable. Returns undef # if the variable does not exists or is undefined and send a warning # message to the _error() function. #------------------------------------------------------------------------ sub get { my $self = shift; my $variable = shift; my $negate = 0; my $value; # _varname returns variable name after aliasing and case conversion # $negate indicates if the name got converted from "no<var>" to "<var>" $variable = $self->_varname($variable, \$negate); # check the variable has been defined unless (exists($self->{ VARIABLE }->{ $variable })) { $self->_error("$variable: no such variable"); return undef; } # DEBUG print STDERR "$self->get($variable) => ", defined $self->{ VARIABLE }->{ $variable } ? $self->{ VARIABLE }->{ $variable } : "<undef>", "\n" if $DEBUG; # return variable value, possibly negated if the name was "no<var>" $value = $self->{ VARIABLE }->{ $variable }; return $negate ? !$value : $value; } #------------------------------------------------------------------------ # set($variable, $value) # # Assigns the value, $value, to the variable specified. # # Returns 1 if the variable is successfully updated or 0 if the variable # does not exist. If an ACTION sub-routine exists for the variable, it # will be executed and its return value passed back. #------------------------------------------------------------------------ sub set { my $self = shift; my $variable = shift; my $value = shift; my $negate = 0; my $create; # _varname returns variable name after aliasing and case conversion # $negate indicates if the name got converted from "no<var>" to "<var>" $variable = $self->_varname($variable, \$negate); # check the variable exists if (exists($self->{ VARIABLE }->{ $variable })) { # variable found, so apply any value negation $value = $value ? 0 : 1 if $negate; } else { # auto-create variable if CREATE is 1 or a pattern matching # the variable name (real name, not an alias) $create = $self->{ CREATE }; if (defined $create && ($create eq '1' || $variable =~ /$create/)) { $self->define($variable); print STDERR "Auto-created $variable\n" if $DEBUG; } else { $self->_error("$variable: no such variable"); return 0; } } # call the validate($variable, $value) method to perform any validation unless ($self->_validate($variable, $value)) { $self->_error("$variable: invalid value: $value"); return 0; } # DEBUG print STDERR "$self->set($variable, ", defined $value ? $value : "<undef>", ")\n" if $DEBUG; # set the variable value depending on its ARGCOUNT my $argcount = $self->{ ARGCOUNT }->{ $variable }; $argcount = AppConfig::ARGCOUNT_ONE unless defined $argcount; if ($argcount eq AppConfig::ARGCOUNT_LIST) { # push value onto the end of the list push(@{ $self->{ VARIABLE }->{ $variable } }, $value); } elsif ($argcount eq AppConfig::ARGCOUNT_HASH) { # insert "<key>=<value>" data into hash my ($k, $v) = split(/\s*=\s*/, $value, 2); # strip quoting $v =~ s/^(['"])(.*)\1$/$2/ if defined $v; $self->{ VARIABLE }->{ $variable }->{ $k } = $v; } else { # set simple variable $self->{ VARIABLE }->{ $variable } = $value; } # call any ACTION function bound to this variable return &{ $self->{ ACTION }->{ $variable } }($self, $variable, $value) if (exists($self->{ ACTION }->{ $variable })); # ...or just return 1 (ok) return 1; } #------------------------------------------------------------------------ # varlist($criteria, $filter) # # Returns a hash array of all variables and values whose real names # match the $criteria regex pattern passed as the first parameter. # If $filter is set to any true value, the keys of the hash array # (variable names) will have the $criteria part removed. This allows # the caller to specify the variables from one particular [block] and # have the "block_" prefix removed, for example. # # TODO: This should be changed to varhash(). varlist() should return a # list. Also need to consider specification by list rather than regex. # #------------------------------------------------------------------------ sub varlist { my $self = shift; my $criteria = shift; my $strip = shift; $criteria = "" unless defined $criteria; # extract relevant keys and slice out corresponding values my @keys = grep(/$criteria/, keys %{ $self->{ VARIABLE } }); my @vals = @{ $self->{ VARIABLE } }{ @keys }; my %set; # clean off the $criteria part if $strip is set @keys = map { s/$criteria//; $_ } @keys if $strip; # slice values into the target hash @set{ @keys } = @vals; return %set; } #------------------------------------------------------------------------ # AUTOLOAD # # Autoload function called whenever an unresolved object method is # called. If the method name relates to a defined VARIABLE, we patch # in $self->get() and $self->set() to magically update the varaiable # (if a parameter is supplied) and return the previous value. # # Thus the function can be used in the folowing ways: # $state->variable(123); # set a new value # $foo = $state->variable(); # get the current value # # Returns the current value of the variable, taken before any new value # is set. Prints a warning if the variable isn't defined (i.e. doesn't # exist rather than exists with an undef value) and returns undef. #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my ($variable, $attrib); # splat the leading package name ($variable = $AUTOLOAD) =~ s/.*:://; # ignore destructor $variable eq 'DESTROY' && return; # per-variable attributes and internal flags listed as keys in # %METHFLAGS and %METHVARS respectively can be accessed by a # method matching the attribute or flag name in lower case with # a leading underscore_ if (($attrib = $variable) =~ s/_//g) { $attrib = uc $attrib; if (exists $METHFLAGS{ $attrib }) { return $self->{ $attrib }; } if (exists $METHVARS{ $attrib }) { # next parameter should be variable name $variable = shift; $variable = $self->_varname($variable); # check we've got a valid variable # $self->_error("$variable: no such variable or method"), # return undef # unless exists($self->{ VARIABLE }->{ $variable }); # return attribute return $self->{ $attrib }->{ $variable }; } } # set a new value if a parameter was supplied or return the old one return defined($_[0]) ? $self->set($variable, shift) : $self->get($variable); } #======================================================================== # ----- PRIVATE METHODS ----- #======================================================================== #------------------------------------------------------------------------ # _configure(\%cfg) # # Sets the various configuration options using the values passed in the # hash array referenced by $cfg. #------------------------------------------------------------------------ sub _configure { my $self = shift; my $cfg = shift || return; # construct a regex to match values which are ok to be found in GLOBAL my $global_ok = join('|', @GLOBAL_OK); foreach my $opt (keys %$cfg) { # GLOBAL must be a hash ref $opt =~ /^GLOBALS?$/i && do { unless (ref($cfg->{ $opt }) eq 'HASH') { $self->_error("\U$opt\E parameter is not a hash ref"); next; } # we check each option is ok to be in GLOBAL, but we don't do # any error checking on the values they contain (but should?). foreach my $global ( keys %{ $cfg->{ $opt } } ) { # continue if the attribute is ok to be GLOBAL next if ($global =~ /(^$global_ok$)/io); $self->_error( "\U$global\E parameter cannot be GLOBAL"); } $self->{ GLOBAL } = $cfg->{ $opt }; next; }; # CASE, CREATE and PEDANTIC are stored as they are $opt =~ /^CASE|CREATE|PEDANTIC$/i && do { $self->{ uc $opt } = $cfg->{ $opt }; next; }; # ERROR triggers $self->_ehandler() $opt =~ /^ERROR$/i && do { $self->_ehandler($cfg->{ $opt }); next; }; # DEBUG triggers $self->_debug() $opt =~ /^DEBUG$/i && do { $self->_debug($cfg->{ $opt }); next; }; # warn about invalid options $self->_error("\U$opt\E is not a valid configuration option"); } } #------------------------------------------------------------------------ # _varname($variable, \$negated) # # Variable names are treated case-sensitively or insensitively, depending # on the value of $self->{ CASE }. When case-insensitive ($self->{ CASE } # != 0), all variable names are converted to lower case. Variable values # are not converted. This function simply converts the parameter # (variable) to lower case if $self->{ CASE } isn't set. _varname() also # expands a variable alias to the name of the target variable. # # Variables with an ARGCOUNT of ARGCOUNT_ZERO may be specified as # "no<var>" in which case, the intended value should be negated. The # leading "no" part is stripped from the variable name. A reference to # a scalar value can be passed as the second parameter and if the # _varname() method identified such a variable, it will negate the value. # This allows the intended value or a simple negate flag to be passed by # reference and be updated to indicate any negation activity taking place. # # The (possibly modified) variable name is returned. #------------------------------------------------------------------------ sub _varname { my $self = shift; my $variable = shift; my $negated = shift; # convert to lower case if case insensitive $variable = $self->{ CASE } ? $variable : lc $variable; # get the actual name if this is an alias $variable = $self->{ ALIAS }->{ $variable } if (exists($self->{ ALIAS }->{ $variable })); # if the variable doesn't exist, we can try to chop off a leading # "no" and see if the remainder matches an ARGCOUNT_ZERO variable unless (exists($self->{ VARIABLE }->{ $variable })) { # see if the variable is specified as "no<var>" if ($variable =~ /^no(.*)/) { # see if the real variable (minus "no") exists and it # has an ARGOUNT of ARGCOUNT_NONE (or no ARGCOUNT at all) my $novar = $self->_varname($1); if (exists($self->{ VARIABLE }->{ $novar }) && ! $self->{ ARGCOUNT }->{ $novar }) { # set variable name and negate value $variable = $novar; $$negated = ! $$negated if defined $negated; } } } # return the variable name $variable; } #------------------------------------------------------------------------ # _default($variable) # # Sets the variable specified to the default value or undef if it doesn't # have a default. The default value is returned. #------------------------------------------------------------------------ sub _default { my $self = shift; my $variable = shift; # _varname returns variable name after aliasing and case conversion $variable = $self->_varname($variable); # check the variable exists if (exists($self->{ VARIABLE }->{ $variable })) { # set variable value to the default scalar, an empty list or empty # hash array, depending on its ARGCOUNT value my $argcount = $self->{ ARGCOUNT }->{ $variable }; $argcount = AppConfig::ARGCOUNT_ONE unless defined $argcount; if ($argcount == AppConfig::ARGCOUNT_NONE) { return $self->{ VARIABLE }->{ $variable } = $self->{ DEFAULT }->{ $variable } || 0; } elsif ($argcount == AppConfig::ARGCOUNT_LIST) { my $deflist = $self->{ DEFAULT }->{ $variable }; return $self->{ VARIABLE }->{ $variable } = [ ref $deflist eq 'ARRAY' ? @$deflist : ( ) ]; } elsif ($argcount == AppConfig::ARGCOUNT_HASH) { my $defhash = $self->{ DEFAULT }->{ $variable }; return $self->{ VARIABLE }->{ $variable } = { ref $defhash eq 'HASH' ? %$defhash : () }; } else { return $self->{ VARIABLE }->{ $variable } = $self->{ DEFAULT }->{ $variable }; } } else { $self->_error("$variable: no such variable"); return 0; } } #------------------------------------------------------------------------ # _exists($variable) # # Returns 1 if the variable specified exists or 0 if not. #------------------------------------------------------------------------ sub _exists { my $self = shift; my $variable = shift; # _varname returns variable name after aliasing and case conversion $variable = $self->_varname($variable); # check the variable has been defined return exists($self->{ VARIABLE }->{ $variable }); } #------------------------------------------------------------------------ # _validate($variable, $value) # # Uses any validation rules or code defined for the variable to test if # the specified value is acceptable. # # Returns 1 if the value passed validation checks, 0 if not. #------------------------------------------------------------------------ sub _validate { my $self = shift; my $variable = shift; my $value = shift; my $validator; # _varname returns variable name after aliasing and case conversion $variable = $self->_varname($variable); # return OK unless there is a validation function return 1 unless defined($validator = $self->{ VALIDATE }->{ $variable }); # # the validation performed is based on the validator type; # # CODE ref: code executed, returning 1 (ok) or 0 (failed) # SCALAR : a regex which should match the value # # CODE ref ref($validator) eq 'CODE' && do { # run the validation function and return the result return &$validator($variable, $value); }; # non-ref (i.e. scalar) ref($validator) || do { # not a ref - assume it's a regex return $value =~ /$validator/; }; # validation failed return 0; } #------------------------------------------------------------------------ # _error($format, @params) # # Checks for the existence of a user defined error handling routine and # if defined, passes all variable straight through to that. The routine # is expected to handle a string format and optional parameters as per # printf(3C). If no error handler is defined, the message is formatted # and passed to warn() which prints it to STDERR. #------------------------------------------------------------------------ sub _error { my $self = shift; my $format = shift; # user defined error handler? if (ref($self->{ EHANDLER }) eq 'CODE') { &{ $self->{ EHANDLER } }($format, @_); } else { warn(sprintf("$format\n", @_)); } } #------------------------------------------------------------------------ # _ehandler($handler) # # Allows a new error handler to be installed. The current value of # the error handler is returned. # # This is something of a kludge to allow other AppConfig::* modules to # install their own error handlers to format error messages appropriately. # For example, AppConfig::File appends a message of the form # "at $file line $line" to each error message generated while parsing # configuration files. The previous handler is returned (and presumably # stored by the caller) to allow new error handlers to chain control back # to any user-defined handler, and also restore the original handler when # done. #------------------------------------------------------------------------ sub _ehandler { my $self = shift; my $handler = shift; # save previous value my $previous = $self->{ EHANDLER }; # update internal reference if a new handler vas provide if (defined $handler) { # check this is a code reference if (ref($handler) eq 'CODE') { $self->{ EHANDLER } = $handler; # DEBUG print STDERR "installed new ERROR handler: $handler\n" if $DEBUG; } else { $self->_error("ERROR handler parameter is not a code ref"); } } return $previous; } #------------------------------------------------------------------------ # _debug($debug) # # Sets the package debugging variable, $AppConfig::State::DEBUG depending # on the value of the $debug parameter. 1 turns debugging on, 0 turns # debugging off. # # May be called as an object method, $state->_debug(1), or as a package # function, AppConfig::State::_debug(1). Returns the previous value of # $DEBUG, before any new value was applied. #------------------------------------------------------------------------ sub _debug { # object reference may not be present if called as a package function my $self = shift if ref($_[0]); my $newval = shift; # save previous value my $oldval = $DEBUG; # update $DEBUG if a new value was provided $DEBUG = $newval if defined $newval; # return previous value $oldval; } #------------------------------------------------------------------------ # _dump_var($var) # # Displays the content of the specified variable, $var. #------------------------------------------------------------------------ sub _dump_var { my $self = shift; my $var = shift; return unless defined $var; # $var may be an alias, so we resolve the real variable name my $real = $self->_varname($var); if ($var eq $real) { print STDERR "$var\n"; } else { print STDERR "$real ('$var' is an alias)\n"; $var = $real; } # for some bizarre reason, the variable VALUE is stored in VARIABLE # (it made sense at some point in time) printf STDERR " VALUE => %s\n", defined($self->{ VARIABLE }->{ $var }) ? $self->{ VARIABLE }->{ $var } : "<undef>"; # the rest of the values can be read straight out of their hashes foreach my $param (qw( DEFAULT ARGCOUNT VALIDATE ACTION EXPAND )) { printf STDERR " %-12s => %s\n", $param, defined($self->{ $param }->{ $var }) ? $self->{ $param }->{ $var } : "<undef>"; } # summarise all known aliases for this variable print STDERR " ALIASES => ", join(", ", @{ $self->{ ALIASES }->{ $var } }), "\n" if defined $self->{ ALIASES }->{ $var }; } #------------------------------------------------------------------------ # _dump() # # Dumps the contents of the Config object and all stored variables. #------------------------------------------------------------------------ sub _dump { my $self = shift; my $var; print STDERR "=" x 71, "\n"; print STDERR "Status of AppConfig::State (version $VERSION) object:\n\t$self\n"; print STDERR "- " x 36, "\nINTERNAL STATE:\n"; foreach (qw( CREATE CASE PEDANTIC EHANDLER ERROR )) { printf STDERR " %-12s => %s\n", $_, defined($self->{ $_ }) ? $self->{ $_ } : "<undef>"; } print STDERR "- " x 36, "\nVARIABLES:\n"; foreach $var (keys %{ $self->{ VARIABLE } }) { $self->_dump_var($var); } print STDERR "- " x 36, "\n", "ALIASES:\n"; foreach $var (keys %{ $self->{ ALIAS } }) { printf(" %-12s => %s\n", $var, $self->{ ALIAS }->{ $var }); } print STDERR "=" x 72, "\n"; } 1; __END__ =head1 NAME AppConfig::State - application configuration state =head1 SYNOPSIS use AppConfig::State; my $state = AppConfig::State->new(\%cfg); $state->define("foo"); # very simple variable definition $state->define("bar", \%varcfg); # variable specific configuration $state->define("foo|bar=i@"); # compact format $state->set("foo", 123); # trivial set/get examples $state->get("foo"); $state->foo(); # shortcut variable access $state->foo(456); # shortcut variable update =head1 OVERVIEW AppConfig::State is a Perl5 module to handle global configuration variables for perl programs. It maintains the state of any number of variables, handling default values, aliasing, validation, update callbacks and option arguments for use by other AppConfig::* modules. AppConfig::State is distributed as part of the AppConfig bundle. =head1 DESCRIPTION =head2 USING THE AppConfig::State MODULE To import and use the AppConfig::State module the following line should appear in your Perl script: use AppConfig::State; The AppConfig::State module is loaded automatically by the new() constructor of the AppConfig module. AppConfig::State is implemented using object-oriented methods. A new AppConfig::State object is created and initialised using the new() method. This returns a reference to a new AppConfig::State object. my $state = AppConfig::State->new(); This will create a reference to a new AppConfig::State with all configuration options set to their default values. You can initialise the object by passing a reference to a hash array containing configuration options: $state = AppConfig::State->new( { CASE => 1, ERROR => \&my_error, } ); The new() constructor of the AppConfig module automatically passes all parameters to the AppConfig::State new() constructor. Thus, any global configuration values and variable definitions for AppConfig::State are also applicable to AppConfig. The following configuration options may be specified. =over 4 =item CASE Determines if the variable names are treated case sensitively. Any non-zero value makes case significant when naming variables. By default, CASE is set to 0 and thus "Variable", "VARIABLE" and "VaRiAbLe" are all treated as "variable". =item CREATE By default, CREATE is turned off meaning that all variables accessed via set() (which includes access via shortcut such as C<$state-E<gt>variable($value)> which delegates to set()) must previously have been defined via define(). When CREATE is set to 1, calling set($variable, $value) on a variable that doesn't exist will cause it to be created automatically. When CREATE is set to any other non-zero value, it is assumed to be a regular expression pattern. If the variable name matches the regex, the variable is created. This can be used to specify configuration file blocks in which variables should be created, for example: $state = AppConfig::State->new( { CREATE => '^define_', } ); In a config file: [define] name = fred # define_name gets created automatically [other] name = john # other_name doesn't - warning raised Note that a regex pattern specified in CREATE is applied to the real variable name rather than any alias by which the variables may be accessed. =item PEDANTIC The PEDANTIC option determines what action the configuration file (AppConfig::File) or argument parser (AppConfig::Args) should take on encountering a warning condition (typically caused when trying to set an undeclared variable). If PEDANTIC is set to any true value, the parsing methods will immediately return a value of 0 on encountering such a condition. If PEDANTIC is not set, the method will continue to parse the remainder of the current file(s) or arguments, returning 0 when complete. If no warnings or errors are encountered, the method returns 1. In the case of a system error (e.g. unable to open a file), the method returns undef immediately, regardless of the PEDANTIC option. =item ERROR Specifies a user-defined error handling routine. When the handler is called, a format string is passed as the first parameter, followed by any additional values, as per printf(3C). =item DEBUG Turns debugging on or off when set to 1 or 0 accordingly. Debugging may also be activated by calling _debug() as an object method (C<$state-E<gt>_debug(1)>) or as a package function (C<AppConfig::State::_debug(1)>), passing in a true/false value to set the debugging state accordingly. The package variable $AppConfig::State::DEBUG can also be set directly. The _debug() method returns the current debug value. If a new value is passed in, the internal value is updated, but the previous value is returned. Note that any AppConfig::File or App::Config::Args objects that are instantiated with a reference to an App::State will inherit the DEBUG (and also PEDANTIC) values of the state at that time. Subsequent changes to the AppConfig::State debug value will not affect them. =item GLOBAL The GLOBAL option allows default values to be set for the DEFAULT, ARGCOUNT, EXPAND, VALIDATE and ACTION options for any subsequently defined variables. $state = AppConfig::State->new({ GLOBAL => { DEFAULT => '<undef>', # default value for new vars ARGCOUNT => 1, # vars expect an argument ACTION => \&my_set_var, # callback when vars get set } }); Any attributes specified explicitly when a variable is defined will override any GLOBAL values. See L<DEFINING VARIABLES> below which describes these options in detail. =back =head2 DEFINING VARIABLES The C<define()> function is used to pre-declare a variable and specify its configuration. $state->define("foo"); In the simple example above, a new variable called "foo" is defined. A reference to a hash array may also be passed to specify configuration information for the variable: $state->define("foo", { DEFAULT => 99, ALIAS => 'metavar1', }); Any variable-wide GLOBAL values passed to the new() constructor in the configuration hash will also be applied. Values explicitly specified in a variable's define() configuration will override the respective GLOBAL values. The following configuration options may be specified =over 4 =item DEFAULT The DEFAULT value is used to initialise the variable. $state->define("drink", { DEFAULT => 'coffee', }); print $state->drink(); # prints "coffee" =item ALIAS The ALIAS option allows a number of alternative names to be specified for this variable. A single alias should be specified as a string. Multiple aliases can be specified as a reference to an array of alternatives or as a string of names separated by vertical bars, '|'. e.g.: # either $state->define("name", { ALIAS => 'person', }); # or $state->define("name", { ALIAS => [ 'person', 'user', 'uid' ], }); # or $state->define("name", { ALIAS => 'person|user|uid', }); $state->user('abw'); # equivalent to $state->name('abw'); =item ARGCOUNT The ARGCOUNT option specifies the number of arguments that should be supplied for this variable. By default, no additional arguments are expected for variables (ARGCOUNT_NONE). The ARGCOUNT_* constants can be imported from the AppConfig module: use AppConfig ':argcount'; $state->define('foo', { ARGCOUNT => ARGCOUNT_ONE }); or can be accessed directly from the AppConfig package: use AppConfig; $state->define('foo', { ARGCOUNT => AppConfig::ARGCOUNT_ONE }); The following values for ARGCOUNT may be specified. =over 4 =item ARGCOUNT_NONE (0) Indicates that no additional arguments are expected. If the variable is identified in a confirguration file or in the command line arguments, it is set to a value of 1 regardless of whatever arguments follow it. =item ARGCOUNT_ONE (1) Indicates that the variable expects a single argument to be provided. The variable value will be overwritten with a new value each time it is encountered. =item ARGCOUNT_LIST (2) Indicates that the variable expects multiple arguments. The variable value will be appended to the list of previous values each time it is encountered. =item ARGCOUNT_HASH (3) Indicates that the variable expects multiple arguments and that each argument is of the form "key=value". The argument will be split into a key/value pair and inserted into the hash of values each time it is encountered. =back =item ARGS The ARGS option can also be used to specify advanced command line options for use with AppConfig::Getopt, which itself delegates to Getopt::Long. See those two modules for more information on the format and meaning of these options. $state->define("name", { ARGS => "=i@", }); =item EXPAND The EXPAND option specifies how the AppConfig::File processor should expand embedded variables in the configuration file values it reads. By default, EXPAND is turned off (EXPAND_NONE) and no expansion is made. The EXPAND_* constants can be imported from the AppConfig module: use AppConfig ':expand'; $state->define('foo', { EXPAND => EXPAND_VAR }); or can be accessed directly from the AppConfig package: use AppConfig; $state->define('foo', { EXPAND => AppConfig::EXPAND_VAR }); The following values for EXPAND may be specified. Multiple values should be combined with vertical bars , '|', e.g. C<EXPAND_UID | EXPAND_VAR>). =over 4 =item EXPAND_NONE Indicates that no variable expansion should be attempted. =item EXPAND_VAR Indicates that variables embedded as $var or $(var) should be expanded to the values of the relevant AppConfig::State variables. =item EXPAND_UID Indicates that '~' or '~uid' patterns in the string should be expanded to the current users ($<), or specified user's home directory. In the first case, C<~> is expanded to the value of the C<HOME> environment variable. In the second case, the C<getpwnam()> method is used if it is available on your system (which it isn't on Win32). =item EXPAND_ENV Inidicates that variables embedded as ${var} should be expanded to the value of the relevant environment variable. =item EXPAND_ALL Equivalent to C<EXPAND_VARS | EXPAND_UIDS | EXPAND_ENVS>). =item EXPAND_WARN Indicates that embedded variables that are not defined should raise a warning. If PEDANTIC is set, this will cause the read() method to return 0 immediately. =back =item VALIDATE Each variable may have a sub-routine or regular expression defined which is used to validate the intended value for a variable before it is set. If VALIDATE is defined as a regular expression, it is applied to the value and deemed valid if the pattern matches. In this case, the variable is then set to the new value. A warning message is generated if the pattern match fails. VALIDATE may also be defined as a reference to a sub-routine which takes as its arguments the name of the variable and its intended value. The sub-routine should return 1 or 0 to indicate that the value is valid or invalid, respectively. An invalid value will cause a warning error message to be generated. If the GLOBAL VALIDATE variable is set (see GLOBAL in L<DESCRIPTION> above) then this value will be used as the default VALIDATE for each variable unless otherwise specified. $state->define("age", { VALIDATE => '\d+', }); $state->define("pin", { VALIDATE => \&check_pin, }); =item ACTION The ACTION option allows a sub-routine to be bound to a variable as a callback that is executed whenever the variable is set. The ACTION is passed a reference to the AppConfig::State object, the name of the variable and the value of the variable. The ACTION routine may be used, for example, to post-process variable data, update the value of some other dependant variable, generate a warning message, etc. Example: $state->define("foo", { ACTION => \&my_notify }); sub my_notify { my $state = shift; my $var = shift; my $val = shift; print "$variable set to $value"; } $state->foo(42); # prints "foo set to 42" Be aware that calling C<$state-E<gt>set()> to update the same variable from within the ACTION function will cause a recursive loop as the ACTION function is repeatedly called. =back =head2 DEFINING VARIABLES USING THE COMPACT FORMAT Variables may be defined in a compact format which allows any ALIAS and ARGS values to be specified as part of the variable name. This is designed to mimic the behaviour of Johan Vromans' Getopt::Long module. Aliases for a variable should be specified after the variable name, separated by vertical bars, '|'. Any ARGS parameter should be appended after the variable name(s) and/or aliases. The following examples are equivalent: $state->define("foo", { ALIAS => [ 'bar', 'baz' ], ARGS => '=i', }); $state->define("foo|bar|baz=i"); =head2 READING AND MODIFYING VARIABLE VALUES AppConfig::State defines two methods to manipulate variable values: set($variable, $value); get($variable); Both functions take the variable name as the first parameter and C<set()> takes an additional parameter which is the new value for the variable. C<set()> returns 1 or 0 to indicate successful or unsuccessful update of the variable value. If there is an ACTION routine associated with the named variable, the value returned will be passed back from C<set()>. The C<get()> function returns the current value of the variable. Once defined, variables may be accessed directly as object methods where the method name is the same as the variable name. i.e. $state->set("verbose", 1); is equivalent to $state->verbose(1); Without parameters, the current value of the variable is returned. If a parameter is specified, the variable is set to that value and the result of the set() operation is returned. $state->age(29); # sets 'age' to 29, returns 1 (ok) =head2 VARLIST The varlist() method can be used to extract a number of variables into a hash array. The first parameter should be a regular expression used for matching against the variable names. my %vars = $state->varlist("^file"); # all "file*" variables A second parameter may be specified (any true value) to indicate that the part of the variable name matching the regex should be removed when copied to the target hash. $state->file_name("/tmp/file"); $state->file_path("/foo:/bar:/baz"); my %vars = $state->varlist("^file_", 1); # %vars: # name => /tmp/file # path => "/foo:/bar:/baz" =head2 INTERNAL METHODS The interal (private) methods of the AppConfig::State class are listed below. They aren't intended for regular use and potential users should consider the fact that nothing about the internal implementation is guaranteed to remain the same. Having said that, the AppConfig::State class is intended to co-exist and work with a number of other modules and these are considered "friend" classes. These methods are provided, in part, as services to them. With this acknowledged co-operation in mind, it is safe to assume some stability in this core interface. The _varname() method can be used to determine the real name of a variable from an alias: $varname->_varname($alias); Note that all methods that take a variable name, including those listed below, can accept an alias and automatically resolve it to the correct variable name. There is no need to call _varname() explicitly to do alias expansion. The _varname() method will fold all variables names to lower case unless CASE sensititvity is set. The _exists() method can be used to check if a variable has been defined: $state->_exists($varname); The _default() method can be used to reset a variable to its default value: $state->_default($varname); The _expand() method can be used to determine the EXPAND value for a variable: print "$varname EXPAND: ", $state->_expand($varname), "\n"; The _argcount() method returns the value of the ARGCOUNT attribute for a variable: print "$varname ARGCOUNT: ", $state->_argcount($varname), "\n"; The _validate() method can be used to determine if a new value for a variable meets any validation criteria specified for it. The variable name and intended value should be passed in. The methods returns a true/false value depending on whether or not the validation succeeded: print "OK\n" if $state->_validate($varname, $value); The _pedantic() method can be called to determine the current value of the PEDANTIC option. print "pedantic mode is ", $state->_pedantic() ? "on" ; "off", "\n"; The _debug() method can be used to turn debugging on or off (pass 1 or 0 as a parameter). It can also be used to check the debug state, returning the current internal value of $AppConfig::State::DEBUG. If a new debug value is provided, the debug state is updated and the previous state is returned. $state->_debug(1); # debug on, returns previous value The _dump_var($varname) and _dump() methods may also be called for debugging purposes. $state->_dump_var($varname); # show variable state $state->_dump(); # show internal state and all vars =head1 AUTHOR Andy Wardley, E<lt>abw@wardley.orgE<gt> =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO AppConfig, AppConfig::File, AppConfig::Args, AppConfig::Getopt =cut perl5/AppConfig/CGI.pm 0000444 00000015416 14711220320 0010376 0 ustar 00 #============================================================================ # # AppConfig::CGI.pm # # Perl5 module to provide a CGI interface to AppConfig. Internal variables # may be set through the CGI "arguments" appended to a URL. # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. # #============================================================================ package AppConfig::CGI; use 5.006; use strict; use warnings; use AppConfig::State; our $VERSION = '1.71'; #------------------------------------------------------------------------ # new($state, $query) # # Module constructor. The first, mandatory parameter should be a # reference to an AppConfig::State object to which all actions should # be applied. The second parameter may be a string containing a CGI # QUERY_STRING which is then passed to parse() to process. If no second # parameter is specifiied then the parse() process is skipped. # # Returns a reference to a newly created AppConfig::CGI object. #------------------------------------------------------------------------ sub new { my $class = shift; my $state = shift; my $self = { STATE => $state, # AppConfig::State ref DEBUG => $state->_debug(), # store local copy of debug PEDANTIC => $state->_pedantic, # and pedantic flags }; bless $self, $class; # call parse(@_) to parse any arg list passed $self->parse(@_) if @_; return $self; } #------------------------------------------------------------------------ # parse($query) # # Method used to parse a CGI QUERY_STRING and set internal variable # values accordingly. If a query is not passed as the first parameter, # then _get_cgi_query() is called to try to determine the query by # examing the environment as per CGI protocol. # # Returns 0 if one or more errors or warnings were raised or 1 if the # string parsed successfully. #------------------------------------------------------------------------ sub parse { my $self = shift; my $query = shift; my $warnings = 0; my ($variable, $value, $nargs); # take a local copy of the state to avoid much hash dereferencing my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) }; # get the cgi query if not defined $query = $ENV{ QUERY_STRING } unless defined $query; # no query to process return 1 unless defined $query; # we want to install a custom error handler into the AppConfig::State # which appends filename and line info to error messages and then # calls the previous handler; we start by taking a copy of the # current handler.. my $errhandler = $state->_ehandler(); # install a closure as a new error handler $state->_ehandler( sub { # modify the error message my $format = shift; $format =~ s/</</g; $format =~ s/>/>/g; $format = "<p>\n<b>[ AppConfig::CGI error: </b>$format<b> ] </b>\n<p>\n"; # send error to stdout for delivery to web client printf($format, @_); } ); PARAM: foreach (split('&', $query)) { # extract parameter and value from query token ($variable, $value) = map { _unescape($_) } split('='); # check an argument was provided if one was expected if ($nargs = $state->_argcount($variable)) { unless (defined $value) { $state->_error("$variable expects an argument"); $warnings++; last PARAM if $pedantic; next; } } # default an undefined value to 1 if ARGCOUNT_NONE else { $value = 1 unless defined $value; } # set the variable, noting any error unless ($state->set($variable, $value)) { $warnings++; last PARAM if $pedantic; } } # restore original error handler $state->_ehandler($errhandler); # return $warnings => 0, $success => 1 return $warnings ? 0 : 1; } # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # The following sub-routine was lifted from Lincoln Stein's CGI.pm # module, version 2.36. Name has been prefixed by a '_'. # unescape URL-encoded data sub _unescape { my($todecode) = @_; $todecode =~ tr/+/ /; # pluses become spaces $todecode =~ s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge; return $todecode; } # # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 1; __END__ =head1 NAME AppConfig::CGI - Perl5 module for processing CGI script parameters. =head1 SYNOPSIS use AppConfig::CGI; my $state = AppConfig::State->new(\%cfg); my $cgi = AppConfig::CGI->new($state); $cgi->parse($cgi_query); $cgi->parse(); # looks for CGI query in environment =head1 OVERVIEW AppConfig::CGI is a Perl5 module which implements a CGI interface to AppConfig. It examines the QUERY_STRING environment variable, or a string passed explicitly by parameter, which represents the additional parameters passed to a CGI query. This is then used to update variable values in an AppConfig::State object accordingly. AppConfig::CGI is distributed as part of the AppConfig bundle. =head1 DESCRIPTION =head2 USING THE AppConfig::CGI MODULE To import and use the AppConfig::CGI module the following line should appear in your Perl script: use AppConfig::CGI; AppConfig::CGI is used automatically if you use the AppConfig module and create an AppConfig::CGI object through the cgi() method. AppConfig::CGI is implemented using object-oriented methods. A new AppConfig::CGI object is created and initialised using the new() method. This returns a reference to a new AppConfig::CGI object. A reference to an AppConfig::State object should be passed in as the first parameter: my $state = AppConfig::State->new(); my $cgi = AppConfig::CGI->new($state); This will create and return a reference to a new AppConfig::CGI object. =head2 PARSING CGI QUERIES The C<parse()> method is used to parse a CGI query which can be specified explicitly, or is automatically extracted from the "QUERY_STRING" CGI environment variable. This currently limits the module to only supporting the GET method. See AppConfig for information about using the AppConfig::CGI module via the cgi() method. =head1 AUTHOR Andy Wardley, C<E<lt>abw@wardley.org<gt>> =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO AppConfig, AppConfig::State =cut perl5/AppConfig/Args.pm 0000444 00000016761 14711220321 0010675 0 ustar 00 #============================================================================ # # AppConfig::Args.pm # # Perl5 module to read command line argument and update the variable # values in an AppConfig::State object accordingly. # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. #============================================================================ package AppConfig::Args; use 5.006; use strict; use warnings; use AppConfig::State; our $VERSION = '1.71'; #------------------------------------------------------------------------ # new($state, \@args) # # Module constructor. The first, mandatory parameter should be a # reference to an AppConfig::State object to which all actions should # be applied. The second parameter may be a reference to a list of # command line arguments. This list reference is passed to args() for # processing. # # Returns a reference to a newly created AppConfig::Args object. #------------------------------------------------------------------------ sub new { my $class = shift; my $state = shift; my $self = { STATE => $state, # AppConfig::State ref DEBUG => $state->_debug(), # store local copy of debug PEDANTIC => $state->_pedantic, # and pedantic flags }; bless $self, $class; # call parse() to parse any arg list passed $self->parse(shift) if @_; return $self; } #------------------------------------------------------------------------ # parse(\@args) # # Examines the argument list and updates the contents of the # AppConfig::State referenced by $self->{ STATE } accordingly. If # no argument list is provided then the method defaults to examining # @ARGV. The method reports any warning conditions (such as undefined # variables) by calling $self->{ STATE }->_error() and then continues to # examine the rest of the list. If the PEDANTIC option is set in the # AppConfig::State object, this behaviour is overridden and the method # returns 0 immediately on any parsing error. # # Returns 1 on success or 0 if one or more warnings were raised. #------------------------------------------------------------------------ sub parse { my $self = shift; my $argv = shift || \@ARGV; my $warnings = 0; my ($arg, $nargs, $variable, $value); # take a local copy of the state to avoid much hash dereferencing my ($state, $debug, $pedantic) = @$self{ qw( STATE DEBUG PEDANTIC ) }; # loop around arguments ARG: while (@$argv && $argv->[0] =~ /^-/) { $arg = shift(@$argv); # '--' indicates the end of the options last if $arg eq '--'; # strip leading '-'; ($variable = $arg) =~ s/^-(-)?//; # test for '--' prefix and push back any '=value' item if (defined $1) { ($variable, $value) = split(/=/, $variable); unshift(@$argv, $value) if defined $value; } # check the variable exists if ($state->_exists($variable)) { # see if it expects any mandatory arguments $nargs = $state->_argcount($variable); if ($nargs) { # check there's another arg and it's not another '-opt' if(defined($argv->[0])) { $value = shift(@$argv); } else { $state->_error("$arg expects an argument"); $warnings++; last ARG if $pedantic; next; } } else { # set a value of 1 if option doesn't expect an argument $value = 1; } # set the variable with the new value $state->set($variable, $value); } else { $state->_error("$arg: invalid option"); $warnings++; last ARG if $pedantic; } } # return status return $warnings ? 0 : 1; } 1; __END__ =head1 NAME AppConfig::Args - Perl5 module for reading command line arguments. =head1 SYNOPSIS use AppConfig::Args; my $state = AppConfig::State->new(\%cfg); my $cfgargs = AppConfig::Args->new($state); $cfgargs->parse(\@args); # read args =head1 OVERVIEW AppConfig::Args is a Perl5 module which reads command line arguments and uses the options therein to update variable values in an AppConfig::State object. AppConfig::File is distributed as part of the AppConfig bundle. =head1 DESCRIPTION =head2 USING THE AppConfig::Args MODULE To import and use the AppConfig::Args module the following line should appear in your Perl script: use AppConfig::Args; AppConfig::Args is used automatically if you use the AppConfig module and create an AppConfig::Args object through the parse() method. AppConfig::File is implemented using object-oriented methods. A new AppConfig::Args object is created and initialised using the new() method. This returns a reference to a new AppConfig::File object. A reference to an AppConfig::State object should be passed in as the first parameter: my $state = AppConfig::State->new(); my $cfgargs = AppConfig::Args->new($state); This will create and return a reference to a new AppConfig::Args object. =head2 PARSING COMMAND LINE ARGUMENTS The C<parse()> method is used to read a list of command line arguments and update the STATE accordingly. A reference to the list of arguments should be passed in. $cfgargs->parse(\@ARGV); If the method is called without a reference to an argument list then it will examine and manipulate @ARGV. If the PEDANTIC option is turned off in the AppConfig::State object, any parsing errors (invalid variables, unvalidated values, etc) will generate warnings, but not cause the method to return. Having processed all arguments, the method will return 1 if processed without warning or 0 if one or more warnings were raised. When the PEDANTIC option is turned on, the method generates a warning and immediately returns a value of 0 as soon as it encounters any parsing error. The method continues parsing arguments until it detects the first one that does not start with a leading dash, '-'. Arguments that constitute values for other options are not examined in this way. =head1 FUTURE DEVELOPMENT This module was developed to provide backwards compatibility (to some degree) with the preceeding App::Config module. The argument parsing it provides is basic but offers a quick and efficient solution for those times when simple option handling is all that is required. If you require more flexibility in parsing command line arguments, then you should consider using the AppConfig::Getopt module. This is loaded and used automatically by calling the AppConfig getopt() method. The AppConfig::Getopt module provides considerably extended functionality over the AppConfig::Args module by delegating out the task of argument parsing to Johan Vromans' Getopt::Long module. For advanced command-line parsing, this module (either Getopt::Long by itself, or in conjunction with AppConfig::Getopt) is highly recommended. =head1 AUTHOR Andy Wardley, E<lt>abw@wardley.orgE<gt> =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO AppConfig, AppConfig::State, AppConfig::Getopt, Getopt::Long =cut perl5/AppConfig/Sys.pm 0000444 00000017451 14711220321 0010554 0 ustar 00 #============================================================================ # # AppConfig::Sys.pm # # Perl5 module providing platform-specific information and operations as # required by other AppConfig::* modules. # # Written by Andy Wardley <abw@wardley.org> # # Copyright (C) 1997-2003 Andy Wardley. All Rights Reserved. # Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. # # $Id: Sys.pm,v 1.61 2004/02/04 10:11:23 abw Exp $ # #============================================================================ package AppConfig::Sys; use 5.006; use strict; use warnings; use POSIX qw( getpwnam getpwuid ); our $VERSION = '1.71'; our ($AUTOLOAD, $OS, %CAN, %METHOD); BEGIN { # define the methods that may be available if($^O =~ m/win32/i) { $METHOD{ getpwuid } = sub { return wantarray() ? ( (undef) x 7, getlogin() ) : getlogin(); }; $METHOD{ getpwnam } = sub { die("Can't getpwnam on win32"); }; } else { $METHOD{ getpwuid } = sub { getpwuid( defined $_[0] ? shift : $< ); }; $METHOD{ getpwnam } = sub { getpwnam( defined $_[0] ? shift : '' ); }; } # try out each METHOD to see if it's supported on this platform; # it's important we do this before defining AUTOLOAD which would # otherwise catch the unresolved call foreach my $method (keys %METHOD) { eval { &{ $METHOD{ $method } }() }; $CAN{ $method } = ! $@; } } #------------------------------------------------------------------------ # new($os) # # Module constructor. An optional operating system string may be passed # to explicitly define the platform type. # # Returns a reference to a newly created AppConfig::Sys object. #------------------------------------------------------------------------ sub new { my $class = shift; my $self = { METHOD => \%METHOD, CAN => \%CAN, }; bless $self, $class; $self->_configure(@_); return $self; } #------------------------------------------------------------------------ # AUTOLOAD # # Autoload function called whenever an unresolved object method is # called. If the method name relates to a METHODS entry, then it is # called iff the corresponding CAN_$method is set true. If the # method name relates to a CAN_$method value then that is returned. #------------------------------------------------------------------------ sub AUTOLOAD { my $self = shift; my $method; # splat the leading package name ($method = $AUTOLOAD) =~ s/.*:://; # ignore destructor $method eq 'DESTROY' && return; # can_method() if ($method =~ s/^can_//i && exists $self->{ CAN }->{ $method }) { return $self->{ CAN }->{ $method }; } # method() elsif (exists $self->{ METHOD }->{ $method }) { if ($self->{ CAN }->{ $method }) { return &{ $self->{ METHOD }->{ $method } }(@_); } else { return undef; } } # variable elsif (exists $self->{ uc $method }) { return $self->{ uc $method }; } else { warn("AppConfig::Sys->", $method, "(): no such method or variable\n"); } return undef; } #------------------------------------------------------------------------ # _configure($os) # # Uses the first parameter, $os, the package variable $AppConfig::Sys::OS, # the value of $^O, or as a last resort, the value of # $Config::Config('osname') to determine the current operating # system/platform. Sets internal variables accordingly. #------------------------------------------------------------------------ sub _configure { my $self = shift; # operating system may be defined as a parameter or in $OS my $os = shift || $OS; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # The following was lifted (and adapated slightly) from Lincoln Stein's # CGI.pm module, version 2.36... # # FIGURE OUT THE OS WE'RE RUNNING UNDER # Some systems support the $^O variable. If not # available then require() the Config library unless ($os) { unless ($os = $^O) { require Config; $os = $Config::Config{'osname'}; } } if ($os =~ /win32/i) { $os = 'WINDOWS'; } elsif ($os =~ /vms/i) { $os = 'VMS'; } elsif ($os =~ /mac/i) { $os = 'MACINTOSH'; } elsif ($os =~ /os2/i) { $os = 'OS2'; } else { $os = 'UNIX'; } # The path separator is a slash, backslash or semicolon, depending # on the platform. my $ps = { UNIX => '/', OS2 => '\\', WINDOWS => '\\', MACINTOSH => ':', VMS => '\\' }->{ $os }; # # Thanks Lincoln! # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - $self->{ OS } = $os; $self->{ PATHSEP } = $ps; } #------------------------------------------------------------------------ # _dump() # # Dump internals for debugging. #------------------------------------------------------------------------ sub _dump { my $self = shift; print "=" x 71, "\n"; print "Status of AppConfig::Sys (Version $VERSION) object: $self\n"; print " Operating System : ", $self->{ OS }, "\n"; print " Path Separator : ", $self->{ PATHSEP }, "\n"; print " Available methods :\n"; foreach my $can (keys %{ $self->{ CAN } }) { printf "%20s : ", $can; print $self->{ CAN }->{ $can } ? "yes" : "no", "\n"; } print "=" x 71, "\n"; } 1; __END__ =pod =head1 NAME AppConfig::Sys - Perl5 module defining platform-specific information and methods for other AppConfig::* modules. =head1 SYNOPSIS use AppConfig::Sys; my $sys = AppConfig::Sys->new(); @fields = $sys->getpwuid($userid); @fields = $sys->getpwnam($username); =head1 OVERVIEW AppConfig::Sys is a Perl5 module provides platform-specific information and operations as required by other AppConfig::* modules. AppConfig::Sys is distributed as part of the AppConfig bundle. =head1 DESCRIPTION =head2 USING THE AppConfig::Sys MODULE To import and use the AppConfig::Sys module the following line should appear in your Perl script: use AppConfig::Sys; AppConfig::Sys is implemented using object-oriented methods. A new AppConfig::Sys object is created and initialised using the AppConfig::Sys->new() method. This returns a reference to a new AppConfig::Sys object. my $sys = AppConfig::Sys->new(); This will attempt to detect your operating system and create a reference to a new AppConfig::Sys object that is applicable to your platform. You may explicitly specify an operating system name to override this automatic detection: $unix_sys = AppConfig::Sys->new("Unix"); Alternatively, the package variable $AppConfig::Sys::OS can be set to an operating system name. The valid operating system names are: Win32, VMS, Mac, OS2 and Unix. They are not case-specific. =head2 AppConfig::Sys METHODS AppConfig::Sys defines the following methods: =over 4 =item getpwnam() Calls the system function getpwnam() if available and returns the result. Returns undef if not available. The can_getpwnam() method can be called to determine if this function is available. =item getpwuid() Calls the system function getpwuid() if available and returns the result. Returns undef if not available. The can_getpwuid() method can be called to determine if this function is available. =back =head1 AUTHOR Andy Wardley, E<lt>abw@wardley.orgE<gt> =head1 COPYRIGHT Copyright (C) 1997-2007 Andy Wardley. All Rights Reserved. Copyright (C) 1997,1998 Canon Research Centre Europe Ltd. This module is free software; you can redistribute it and/or modify it under the term of the Perl Artistic License. =head1 SEE ALSO AppConfig, AppConfig::File =cut perl5/Types/Serialiser/Error.pm 0000444 00000000703 14711220322 0012420 0 ustar 00 =head1 NAME Types::Serialiser::Error - dummy module for Types::Serialiser =head1 SYNOPSIS # do not "use" yourself =head1 DESCRIPTION This module exists only to provide overload resolution for Storable and similar modules that assume that class name equals module name. See L<Types::Serialiser> for more info about this class. =cut use Types::Serialiser (); =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://home.schmorp.de/ =cut 1 perl5/Types/Serialiser.pm 0000444 00000021674 14711220322 0011341 0 ustar 00 =head1 NAME Types::Serialiser - simple data types for common serialisation formats =encoding utf-8 =head1 SYNOPSIS =head1 DESCRIPTION This module provides some extra datatypes that are used by common serialisation formats such as JSON or CBOR. The idea is to have a repository of simple/small constants and containers that can be shared by different implementations so they become interoperable between each other. =cut package Types::Serialiser; use common::sense; # required to suppress annoying warnings our $VERSION = '1.01'; =head1 SIMPLE SCALAR CONSTANTS Simple scalar constants are values that are overloaded to act like simple Perl values, but have (class) type to differentiate them from normal Perl scalars. This is necessary because these have different representations in the serialisation formats. In the following, functions with zero or one arguments have a prototype of C<()> and C<($)>, respectively, so act as constants and unary operators. =head2 BOOLEANS (Types::Serialiser::Boolean class) This type has only two instances, true and false. A natural representation for these in Perl is C<1> and C<0>, but serialisation formats need to be able to differentiate between them and mere numbers. =over 4 =item $Types::Serialiser::true, Types::Serialiser::true This value represents the "true" value. In most contexts is acts like the number C<1>. It is up to you whether you use the variable form (C<$Types::Serialiser::true>) or the constant form (C<Types::Serialiser::true>). The constant is represented as a reference to a scalar containing C<1> - implementations are allowed to directly test for this. =item $Types::Serialiser::false, Types::Serialiser::false This value represents the "false" value. In most contexts is acts like the number C<0>. It is up to you whether you use the variable form (C<$Types::Serialiser::false>) or the constant form (C<Types::Serialiser::false>). The constant is represented as a reference to a scalar containing C<0> - implementations are allowed to directly test for this. =item Types::Serialiser::as_bool $value Converts a Perl scalar into a boolean, which is useful syntactic sugar. Strictly equivalent to: $value ? $Types::Serialiser::true : $Types::Serialiser::false =item $is_bool = Types::Serialiser::is_bool $value Returns true iff the C<$value> is either C<$Types::Serialiser::true> or C<$Types::Serialiser::false>. For example, you could differentiate between a perl true value and a C<Types::Serialiser::true> by using this: $value && Types::Serialiser::is_bool $value =item $is_true = Types::Serialiser::is_true $value Returns true iff C<$value> is C<$Types::Serialiser::true>. =item $is_false = Types::Serialiser::is_false $value Returns false iff C<$value> is C<$Types::Serialiser::false>. =back =head2 ERROR (Types::Serialiser::Error class) This class has only a single instance, C<error>. It is used to signal an encoding or decoding error. In CBOR for example, and object that couldn't be encoded will be represented by a CBOR undefined value, which is represented by the error value in Perl. =over 4 =item $Types::Serialiser::error, Types::Serialiser::error This value represents the "error" value. Accessing values of this type will throw an exception. The constant is represented as a reference to a scalar containing C<undef> - implementations are allowed to directly test for this. =item $is_error = Types::Serialiser::is_error $value Returns false iff C<$value> is C<$Types::Serialiser::error>. =back =cut BEGIN { # for historical reasons, and to avoid extra dependencies in JSON::PP, # we alias *Types::Serialiser::Boolean with JSON::PP::Boolean. package JSON::PP::Boolean; *Types::Serialiser::Boolean:: = *JSON::PP::Boolean::; } { # this must done before blessing to work around bugs # in perl < 5.18 (it seems to be fixed in 5.18). package Types::Serialiser::BooleanBase; use overload "0+" => sub { ${$_[0]} }, "++" => sub { $_[0] = ${$_[0]} + 1 }, "--" => sub { $_[0] = ${$_[0]} - 1 }, fallback => 1; @Types::Serialiser::Boolean::ISA = Types::Serialiser::BooleanBase::; } our $true = do { bless \(my $dummy = 1), Types::Serialiser::Boolean:: }; our $false = do { bless \(my $dummy = 0), Types::Serialiser::Boolean:: }; our $error = do { bless \(my $dummy ), Types::Serialiser::Error:: }; sub true () { $true } sub false () { $false } sub error () { $error } sub as_bool($) { $_[0] ? $true : $false } sub is_bool ($) { UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: } sub is_true ($) { $_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: } sub is_false ($) { !$_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: } sub is_error ($) { UNIVERSAL::isa $_[0], Types::Serialiser::Error:: } package Types::Serialiser::Error; sub error { require Carp; Carp::croak ("caught attempt to use the Types::Serialiser::error value"); }; use overload "0+" => \&error, "++" => \&error, "--" => \&error, fallback => 1; =head1 NOTES FOR XS USERS The recommended way to detect whether a scalar is one of these objects is to check whether the stash is the C<Types::Serialiser::Boolean> or C<Types::Serialiser::Error> stash, and then follow the scalar reference to see if it's C<1> (true), C<0> (false) or C<undef> (error). While it is possible to use an isa test, directly comparing stash pointers is faster and guaranteed to work. For historical reasons, the C<Types::Serialiser::Boolean> stash is just an alias for C<JSON::PP::Boolean>. When printed, the classname with usually be C<JSON::PP::Boolean>, but isa tests and stash pointer comparison will normally work correctly (i.e. Types::Serialiser::true ISA JSON::PP::Boolean, but also ISA Types::Serialiser::Boolean). =head1 A GENERIC OBJECT SERIALIATION PROTOCOL This section explains the object serialisation protocol used by L<CBOR::XS>. It is meant to be generic enough to support any kind of generic object serialiser. This protocol is called "the Types::Serialiser object serialisation protocol". =head2 ENCODING When the encoder encounters an object that it cannot otherwise encode (for example, L<CBOR::XS> can encode a few special types itself, and will first attempt to use the special C<TO_CBOR> serialisation protocol), it will look up the C<FREEZE> method on the object. Note that the C<FREEZE> method will normally be called I<during> encoding, and I<MUST NOT> change the data structure that is being encoded in any way, or it might cause memory corruption or worse. If it exists, it will call it with two arguments: the object to serialise, and a constant string that indicates the name of the data model. For example L<CBOR::XS> uses C<CBOR>, and the L<JSON> and L<JSON::XS> modules (or any other JSON serialiser), would use C<JSON> as second argument. The C<FREEZE> method can then return zero or more values to identify the object instance. The serialiser is then supposed to encode the class name and all of these return values (which must be encodable in the format) using the relevant form for Perl objects. In CBOR for example, there is a registered tag number for encoded perl objects. The values that C<FREEZE> returns must be serialisable with the serialiser that calls it. Therefore, it is recommended to use simple types such as strings and numbers, and maybe array references and hashes (basically, the JSON data model). You can always use a more complex format for a specific data model by checking the second argument, the data model. The "data model" is not the same as the "data format" - the data model indicates what types and kinds of return values can be returned from C<FREEZE>. For example, in C<CBOR> it is permissible to return tagged CBOR values, while JSON does not support these at all, so C<JSON> would be a valid (but too limited) data model name for C<CBOR::XS>. similarly, a serialising format that supports more or less the same data model as JSON could use C<JSON> as data model without losing anything. =head2 DECODING When the decoder then encounters such an encoded perl object, it should look up the C<THAW> method on the stored classname, and invoke it with the classname, the constant string to identify the data model/data format, and all the return values returned by C<FREEZE>. =head2 EXAMPLES See the C<OBJECT SERIALISATION> section in the L<CBOR::XS> manpage for more details, an example implementation, and code examples. Here is an example C<FREEZE>/C<THAW> method pair: sub My::Object::FREEZE { my ($self, $model) = @_; ($self->{type}, $self->{id}, $self->{variant}) } sub My::Object::THAW { my ($class, $model, $type, $id, $variant) = @_; $class->new (type => $type, id => $id, variant => $variant) } =head1 BUGS The use of L<overload> makes this module much heavier than it should be (on my system, this module: 4kB RSS, overload: 260kB RSS). =head1 SEE ALSO Currently, L<JSON::XS> and L<CBOR::XS> use these types. =head1 AUTHOR Marc Lehmann <schmorp@schmorp.de> http://home.schmorp.de/ =cut 1
| ver. 1.4 |
Github
|
.
| PHP 7.4.33 | Генерация страницы: 7.46 |
proxy
|
phpinfo
|
Настройка