diff options
Diffstat (limited to 'gnu/usr.bin/perl/cpan')
326 files changed, 7554 insertions, 13192 deletions
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm index 093579a6c29..af6786ee519 100644 --- a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm +++ b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar.pm @@ -27,11 +27,11 @@ use vars qw[$DEBUG $error $VERSION $WARN $FOLLOW_SYMLINK $CHOWN $CHMOD ]; @ISA = qw[Exporter]; -@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP ]; +@EXPORT = qw[ COMPRESS_GZIP COMPRESS_BZIP COMPRESS_XZ ]; $DEBUG = 0; $WARN = 1; $FOLLOW_SYMLINK = 0; -$VERSION = "2.32"; +$VERSION = "2.36"; $CHOWN = 1; $CHMOD = 1; $SAME_PERMISSIONS = $> == 0 ? 1 : 0; @@ -76,6 +76,7 @@ Archive::Tar - module for manipulations of tar archives $tar->write('files.tar'); # plain tar $tar->write('files.tgz', COMPRESS_GZIP); # gzip compressed $tar->write('files.tbz', COMPRESS_BZIP); # bzip2 compressed + $tar->write('files.txz', COMPRESS_XZ); # xz compressed =head1 DESCRIPTION @@ -147,12 +148,13 @@ backwards compatibility. Archive::Tar now looks at the file magic to determine what class should be used to open the file and will transparently Do The Right Thing. -Archive::Tar will warn if you try to pass a bzip2 compressed file and the -IO::Zlib / IO::Uncompress::Bunzip2 modules are not available and simply return. +Archive::Tar will warn if you try to pass a bzip2 / xz compressed file and the +IO::Uncompress::Bunzip2 / IO::Uncompress::UnXz are not available and simply return. Note that you can currently B<not> pass a C<gzip> compressed filehandle, which is not opened with C<IO::Zlib>, a C<bzip2> compressed -filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, nor a string +filehandle, which is not opened with C<IO::Uncompress::Bunzip2>, a C<xz> compressed +filehandle, which is not opened with C<IO::Uncompress::UnXz>, nor a string containing the full archive information (either compressed or uncompressed). These are worth while features, but not currently implemented. See the C<TODO> section. @@ -246,16 +248,40 @@ sub _get_handle { return; }; - ### read the first 4 bites of the file to figure out which class to + ### read the first 6 bytes of the file to figure out which class to ### use to open the file. - sysread( $tmp, $magic, 4 ); + sysread( $tmp, $magic, 6 ); close $tmp; } + ### is it xz? + ### if you asked specifically for xz compression, or if we're in + ### read mode and the magic numbers add up, use xz + if( XZ and ( + ($compress eq COMPRESS_XZ) or + ( MODE_READ->($mode) and $magic =~ XZ_MAGIC_NUM ) + ) + ) { + if( MODE_READ->($mode) ) { + $fh = IO::Uncompress::UnXz->new( $file ) or do { + $self->_error( qq[Could not read '$file': ] . + $IO::Uncompress::UnXz::UnXzError + ); + return; + }; + } else { + $fh = IO::Compress::Xz->new( $file ) or do { + $self->_error( qq[Could not write to '$file': ] . + $IO::Compress::Xz::XzError + ); + return; + }; + } + ### is it bzip? ### if you asked specifically for bzip compression, or if we're in ### read mode and the magic numbers add up, use bzip - if( BZIP and ( + } elsif( BZIP and ( ($compress eq COMPRESS_BZIP) or ( MODE_READ->($mode) and $magic =~ BZIP_MAGIC_NUM ) ) @@ -1246,8 +1272,8 @@ Write the in-memory archive to disk. The first argument can either be the name of a file or a reference to an already open filehandle (a GLOB reference). -The second argument is used to indicate compression. You can either -compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed +The second argument is used to indicate compression. You can +compress using C<gzip>, C<bzip2> or C<xz>. If you pass a digit, it's assumed to be the C<gzip> compression level (between 1 and 9), but the use of constants is preferred: @@ -1257,10 +1283,13 @@ constants is preferred: # write a bzip compressed file $tar->write( 'out.tbz', COMPRESS_BZIP ); + # write a xz compressed file + $tar->write( 'out.txz', COMPRESS_XZ ); + Note that when you pass in a filehandle, the compression argument is ignored, as all files are printed verbatim to your filehandle. If you wish to enable compression with filehandles, use an -C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead. +C<IO::Zlib>, C<IO::Compress::Bzip2> or C<IO::Compress::Xz> filehandle instead. The third argument is an optional prefix. All files will be tucked away in the directory you specify as prefix. So if you have files @@ -1696,8 +1725,8 @@ Creates a tar file from the list of files provided. The first argument can either be the name of the tar file to create or a reference to an open file handle (e.g. a GLOB reference). -The second argument is used to indicate compression. You can either -compress using C<gzip> or C<bzip2>. If you pass a digit, it's assumed +The second argument is used to indicate compression. You can +compress using C<gzip>, C<bzip2> or C<xz>. If you pass a digit, it's assumed to be the C<gzip> compression level (between 1 and 9), but the use of constants is preferred: @@ -1707,10 +1736,13 @@ constants is preferred: # write a bzip compressed file Archive::Tar->create_archive( 'out.tbz', COMPRESS_BZIP, @filelist ); + # write a xz compressed file + Archive::Tar->create_archive( 'out.txz', COMPRESS_XZ, @filelist ); + Note that when you pass in a filehandle, the compression argument is ignored, as all files are printed verbatim to your filehandle. If you wish to enable compression with filehandles, use an -C<IO::Zlib> or C<IO::Compress::Bzip2> filehandle instead. +C<IO::Zlib>, C<IO::Compress::Bzip2> or C<IO::Compress::Xz> filehandle instead. The remaining arguments list the files to be included in the tar file. These files must all exist. Any files which don't exist or can't be @@ -1915,11 +1947,19 @@ Returns true if C<Archive::Tar> can extract C<bzip2> compressed archives sub has_bzip2_support { return BZIP } +=head2 $bool = Archive::Tar->has_xz_support + +Returns true if C<Archive::Tar> can extract C<xz> compressed archives + +=cut + +sub has_xz_support { return XZ } + =head2 Archive::Tar->can_handle_compressed_files A simple checking routine, which will return true if C<Archive::Tar> -is able to uncompress compressed archives on the fly with C<IO::Zlib> -and C<IO::Compress::Bzip2> or false if not both are installed. +is able to uncompress compressed archives on the fly with C<IO::Zlib>, +C<IO::Compress::Bzip2> and C<IO::Compress::Xz> or false if not both are installed. You can use this as a shortcut to determine whether C<Archive::Tar> will do what you think before passing compressed archives to its diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm index a48968d9e04..398c4799a5c 100644 --- a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm +++ b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/Constant.pm @@ -3,7 +3,7 @@ package Archive::Tar::Constant; BEGIN { require Exporter; - $VERSION = '2.32'; + $VERSION = '2.36'; @ISA = qw[Exporter]; require Time::Local if $^O eq "MacOS"; @@ -32,6 +32,7 @@ use constant BLOCK => 512; use constant COMPRESS_GZIP => 9; use constant COMPRESS_BZIP => 'bzip2'; +use constant COMPRESS_XZ => 'xz'; use constant BLOCK_SIZE => sub { my $n = int($_[0]/BLOCK); $n++ if $_[0] % BLOCK; $n * BLOCK }; use constant TAR_PAD => sub { my $x = shift || return; return "\0" x (BLOCK - ($x % BLOCK) ) }; @@ -58,7 +59,7 @@ use constant PACK => 'a100 a8 a8 a8 a12 a12 A8 a1 a100 a6 a2 a32 a32 a use constant NAME_LENGTH => 100; use constant PREFIX_LENGTH => 155; -use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,70) : 0; +use constant TIME_OFFSET => ($^O eq "MacOS") ? Time::Local::timelocal(0,0,0,1,0,1970) : 0; use constant MAGIC => "ustar"; use constant TAR_VERSION => "00"; use constant LONGLINK_NAME => '././@LongLink'; @@ -77,8 +78,16 @@ use constant BZIP => do { !$ENV{'PERL5_AT_NO_BZIP'} and $ENV{'PERL5_AT_NO_BZIP'} || $@ ? 0 : 1 }; + ### allow XZ to be turned off using ENV: DEBUG only +use constant XZ => do { !$ENV{'PERL5_AT_NO_XZ'} and + eval { require IO::Compress::Xz; + require IO::Uncompress::UnXz; }; + $ENV{'PERL5_AT_NO_XZ'} || $@ ? 0 : 1 + }; + use constant GZIP_MAGIC_NUM => qr/^(?:\037\213|\037\235)/; use constant BZIP_MAGIC_NUM => qr/^BZh\d/; +use constant XZ_MAGIC_NUM => qr/^\xFD\x37\x7A\x58\x5A\x00/; use constant CAN_CHOWN => sub { ($> == 0 and $^O ne "MacOS" and $^O ne "MSWin32") }; use constant CAN_READLINK => ($^O ne 'MSWin32' and $^O !~ /RISC(?:[ _])?OS/i and $^O ne 'VMS'); diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm index 3efa3159d94..0887a923bd3 100644 --- a/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm +++ b/gnu/usr.bin/perl/cpan/Archive-Tar/lib/Archive/Tar/File.pm @@ -13,7 +13,7 @@ use Archive::Tar::Constant; use vars qw[@ISA $VERSION]; #@ISA = qw[Archive::Tar]; -$VERSION = '2.32'; +$VERSION = '2.36'; ### set value to 1 to oct() it during the unpack ### diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm index 80c3efec433..b563addf527 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/App/Cpan.pm @@ -6,7 +6,7 @@ use vars qw($VERSION); use if $] < 5.008 => 'IO::Scalar'; -$VERSION = '1.672'; +$VERSION = '1.675'; =head1 NAME @@ -414,13 +414,13 @@ sub _process_options # if no arguments, just drop into the shell if( 0 == @ARGV ) { CPAN::shell(); exit 0 } - else + elsif (Getopt::Std::getopts( + join( '', @option_order ), \%options )) { - Getopt::Std::getopts( - join( '', @option_order ), \%options ); \%options; } - } + else { exit 1 } +} sub _process_setup_options { @@ -431,8 +431,7 @@ sub _process_setup_options $Method_table{j}[ $Method_table_index{code} ]->( $options->{j} ); delete $options->{j}; } - else - { + elsif ( ! $options->{h} ) { # h "ignores all of the other options and arguments" # this is what CPAN.pm would do otherwise local $CPAN::Be_Silent = 1; CPAN::HandleConfig->load( @@ -542,15 +541,23 @@ sub run return $return_value; } +my $LEVEL; { package Local::Null::Logger; # hide from PAUSE +my @LOGLEVELS = qw(TRACE DEBUG INFO WARN ERROR FATAL); +$LEVEL = uc($ENV{CPANSCRIPT_LOGLEVEL} || 'INFO'); +my %LL = map { $LOGLEVELS[$_] => $_ } 0..$#LOGLEVELS; +unless (defined $LL{$LEVEL}){ + warn "Unsupported loglevel '$LEVEL', setting to INFO"; + $LEVEL = 'INFO'; +} sub new { bless \ my $x, $_[0] } sub AUTOLOAD { my $autoload = our $AUTOLOAD; $autoload =~ s/.*://; - return if $autoload =~ /^(debug|trace)$/; + return if $LL{uc $autoload} < $LL{$LEVEL}; $CPAN::Frontend->mywarn(">($autoload): $_\n") for split /[\r\n]+/, $_[1]; } @@ -579,8 +586,6 @@ sub _init_logger return $logger; } - my $LEVEL = $ENV{CPANSCRIPT_LOGLEVEL} || 'INFO'; - Log::Log4perl::init( \ <<"HERE" ); log4perl.rootLogger=$LEVEL, A1 log4perl.appender.A1=Log::Log4perl::Appender::Screen @@ -676,7 +681,7 @@ sub _hook_into_CPANpm_report *CPAN::Shell::myprint = sub { my($self,$what) = @_; - $scalar .= $what; + $scalar .= $what if defined $what; $self->print_ornamented($what, $CPAN::Config->{colorize_print}||'bold blue on_white', ); @@ -794,7 +799,14 @@ sub _turn_off_testing { sub _print_help { $logger->info( "Use perldoc to read the documentation" ); - exec "perldoc $0"; + my $HAVE_PERLDOC = eval { require Pod::Perldoc; 1; }; + if ($HAVE_PERLDOC) { + system qq{"$^X" -e "require Pod::Perldoc; Pod::Perldoc->run()" $0}; + exit; + } else { + warn "Please install Pod::Perldoc, maybe try 'cpan -i Pod::Perldoc'\n"; + return HEY_IT_WORKED; + } } sub _print_version # -v @@ -1698,3 +1710,10 @@ Copyright (c) 2001-2018, brian d foy, All Rights Reserved. You may redistribute this under the same terms as Perl itself. =cut + +# Local Variables: +# mode: cperl +# indent-tabs-mode: t +# cperl-indent-level: 8 +# cperl-continued-statement-offset: 8 +# End: diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm index 0c9b9f5b09f..2d87f47f8b9 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN.pm @@ -2,7 +2,7 @@ # vim: ts=4 sts=4 sw=4: use strict; package CPAN; -$CPAN::VERSION = '2.22'; +$CPAN::VERSION = '2.27'; $CPAN::VERSION =~ s/_//; # we need to run chdir all over and we would get at wrong libraries @@ -286,7 +286,10 @@ sub shell { } if (my $histfile = $CPAN::Config->{'histfile'}) {{ unless ($term->can("AddHistory")) { - $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n\nTo fix enter> install Term::ReadLine::Perl\n\n"); + $CPAN::Frontend->mywarn("Terminal does not support AddHistory.\n"); + unless ($CPAN::META->has_inst('Term::ReadLine::Perl')) { + $CPAN::Frontend->mywarn("\nTo fix that, maybe try> install Term::ReadLine::Perl\n\n"); + } last; } $META->readhist($term,$histfile); @@ -1028,7 +1031,10 @@ sub has_usable { $usable = { # - # these subroutines die if they believe the installed version is unusable; + # most of these subroutines warn on the frontend, then + # die if the installed version is unusable for some + # reason; has_usable() then returns false when it caught + # an exception, otherwise returns true and caches that; # 'CPAN::Meta' => [ sub { @@ -1059,6 +1065,23 @@ sub has_usable { }, ], + 'CPAN::Reporter' => [ + sub { + if (defined $CPAN::Reporter::VERSION + && CPAN::Version->vlt($CPAN::Reporter::VERSION, "1.2011") + ) { + delete $INC{"CPAN/Reporter.pm"}; + } + require CPAN::Reporter; + unless (CPAN::Version->vge(CPAN::Reporter->VERSION, "1.2011")) { + for ("Will not use CPAN::Reporter, need version 1.2011\n") { + $CPAN::Frontend->mywarn($_); + die $_; + } + } + }, + ], + LWP => [ # we frequently had "Can't locate object # method "new" via package "LWP::UserAgent" at # (eval 69) line 2006 @@ -1445,11 +1468,12 @@ sub set_perl5lib { $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; } else { my $cnt = keys %{$self->{is_tested}}; - $CPAN::Frontend->optprint('perl5lib', "Prepending blib/arch and blib/lib of ". - "$cnt build dirs to PERL5LIB; ". - "for '$for'\n" + my $newenv = join $Config::Config{path_sep}, @dirs, @env; + $CPAN::Frontend->optprint('perl5lib', sprintf ("Prepending blib/arch and blib/lib of ". + "%d build dirs to PERL5LIB, reaching size %d; ". + "for '%s'\n", $cnt, length($newenv), $for) ); - $ENV{PERL5LIB} = join $Config::Config{path_sep}, @dirs, @env; + $ENV{PERL5LIB} = $newenv; } }} @@ -2121,6 +2145,12 @@ where WORD is any valid config variable or a regular expression. The following keys in the hash reference $CPAN::Config are currently defined: + allow_installing_module_downgrades + allow or disallow installing module downgrades + allow_installing_outdated_dists + allow or disallow installing modules that are + indexed in the cpan index pointing to a distro + with a higher distro-version number applypatch path to external prg auto_commit commit all changes to config variables to disk build_cache size of cache for directories to build modules @@ -2134,7 +2164,8 @@ currently defined: check_sigs if signatures should be verified cleanup_after_install remove build directory immediately after a - successful install + successful install and remember that for the + duration of the session colorize_debug Term::ANSIColor attributes for debugging output colorize_output boolean if Term::ANSIColor should colorize output colorize_print Term::ANSIColor attributes for normal output @@ -2238,6 +2269,10 @@ currently defined: CPAN::Reporter history) unzip location of external program unzip urllist arrayref to nearby CPAN sites (or equivalent locations) + urllist_ping_external + use external ping command when autoselecting mirrors + urllist_ping_verbose + increase verbosity when autoselecting mirrors use_prompt_default set PERL_MM_USE_DEFAULT for configure/make/test/install use_sqlite use CPAN::SQLite for metadata storage (fast and lean) username your username if you CPAN server wants one @@ -2378,11 +2413,48 @@ installed. It is only built and tested, and then kept in the list of tested but uninstalled modules. As such, it is available during the build of the dependent module by integrating the path to the C<blib/arch> and C<blib/lib> directories in the environment variable -PERL5LIB. If C<build_requires_install_policy> is set ti C<yes>, then +PERL5LIB. If C<build_requires_install_policy> is set to C<yes>, then both modules declared as C<requires> and those declared as C<build_requires> are treated alike. By setting to C<ask/yes> or C<ask/no>, CPAN.pm asks the user and sets the default accordingly. +=head2 Configuration of the allow_installing_* parameters + +The C<allow_installing_*> parameters are evaluated during +the C<make> phase. If set to C<yes>, they allow the testing and the installation of +the current distro and otherwise have no effect. If set to C<no>, they +may abort the build (preventing testing and installing), depending on the contents of the +C<blib/> directory. The C<blib/> directory is the directory that holds +all the files that would usually be installed in the C<install> phase. + +C<allow_installing_outdated_dists> compares the C<blib/> directory with the CPAN index. +If it finds something there that belongs, according to the index, to a different +dist, it aborts the current build. + +C<allow_installing_module_downgrades> compares the C<blib/> directory +with already installed modules, actually their version numbers, as +determined by ExtUtils::MakeMaker or equivalent. If a to-be-installed +module would downgrade an already installed module, the current build +is aborted. + +An interesting twist occurs when a distroprefs document demands the +installation of an outdated dist via goto while +C<allow_installing_outdated_dists> forbids it. Without additional +provisions, this would let the C<allow_installing_outdated_dists> +win and the distroprefs lose. So the proper arrangement in such a case +is to write a second distroprefs document for the distro that C<goto> +points to and overrule the C<cpanconfig> there. E.g.: + + --- + match: + distribution: "^MAUKE/Keyword-Simple-0.04.tar.gz" + goto: "MAUKE/Keyword-Simple-0.03.tar.gz" + --- + match: + distribution: "^MAUKE/Keyword-Simple-0.03.tar.gz" + cpanconfig: + allow_installing_outdated_dists: yes + =head2 Configuration for individual distributions (I<Distroprefs>) (B<Note:> This feature has been introduced in CPAN.pm 1.8854) @@ -3922,6 +3994,25 @@ directory) or exit the CPAN shell, respectively. If you never start up the CPAN shell, you probably also have to clean up the build directory yourself. +=item 19) + +How can I switch to sudo instead of local::lib? + +The following 5 environment veriables need to be reset to the previous +values: PATH, PERL5LIB, PERL_LOCAL_LIB_ROOT, PERL_MB_OPT, PERL_MM_OPT; +and these two CPAN.pm config variables must be reconfigured: +make_install_make_command and mbuild_install_build_command. The five +env variables have probably been overwritten in your $HOME/.bashrc or +some equivalent. You either find them there and delete their traces +and logout/login or you override them temporarily, depending on your +exact desire. The two cpanpm config variables can be set with: + + o conf init /install_.*_command/ + +probably followed by + + o conf commit + =back =head1 COMPATIBILITY diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm index 3b4e93d8bf6..99c95ac4d6e 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Bundle.pm @@ -8,7 +8,7 @@ use CPAN::Module; use vars qw( $VERSION ); -$VERSION = "5.5003"; +$VERSION = "5.5005"; sub look { my $self = shift; @@ -87,11 +87,11 @@ sub contains { # Try to get at it in the cpan directory $self->debug("no inst_file") if $CPAN::DEBUG; my $cpan_file; - $CPAN::Frontend->mydie("I don't know a bundle with ID $id\n") unless + $CPAN::Frontend->mydie("I don't know a bundle with ID '$id'\n") unless $cpan_file = $self->cpan_file; if ($cpan_file eq "N/A") { - $CPAN::Frontend->mydie("Bundle $id not found on disk and not on CPAN. - Maybe stale symlink? Maybe removed during session? Giving up.\n"); + $CPAN::Frontend->mywarn("Bundle '$id' not found on disk and not on CPAN. Maybe stale symlink? Maybe removed during session?\n"); + return; } my $dist = $CPAN::META->instance('CPAN::Distribution', $self->cpan_file); @@ -103,7 +103,12 @@ sub contains { @me = split /::/, $self->id; $me[-1] .= ".pm"; $me = File::Spec->catfile(@me); - $from = $self->find_bundle_file($dist->{build_dir},join('/',@me)); + my $build_dir; + unless ($build_dir = $dist->{build_dir}) { + $CPAN::Frontend->mywarn("Warning: cannot determine bundle content without a build_dir.\n"); + return; + } + $from = $self->find_bundle_file($build_dir,join('/',@me)); $to = File::Spec->catfile($todir,$me); File::Path::mkpath(File::Basename::dirname($to)); File::Copy::copy($from, $to) @@ -238,6 +243,7 @@ Going to $meth that. $self->debug("type[$type] s[$s]") if $CPAN::DEBUG; my $obj = $CPAN::META->instance($type,$s); $obj->{reqtype} = $self->{reqtype}; + $obj->{viabundle} ||= { id => $id, reqtype => $self->{reqtype}, optional => !$self->{mandatory}}; # $obj->$meth(); # XXX should optional be based on whether bundle was optional? -- xdg, 2012-04-01 # A: Sure, what could demand otherwise? --andk, 2013-11-25 diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm index 717c9aa0e45..34121085395 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Distribution.pm @@ -6,9 +6,12 @@ use Cwd qw(chdir); use CPAN::Distroprefs; use CPAN::InfoObj; use File::Path (); +use POSIX ":sys_wait_h"; @CPAN::Distribution::ISA = qw(CPAN::InfoObj); use vars qw($VERSION); -$VERSION = "2.22"; +$VERSION = "2.27"; + +my $run_allow_installing_within_test = 1; # boolean; either in test or in install, there is no third option # no prepare, because prepare is not a command on the shell command line # TODO: clear instance cache on reload @@ -317,6 +320,17 @@ sub called_for { sub shortcut_get { my ($self) = @_; + if (exists $self->{cleanup_after_install_done}) { + if ($self->{force_update}) { + delete $self->{cleanup_after_install_done}; + } else { + my $id = $self->{CALLED_FOR} || $self->pretty_id; + return $self->success( + "Has already been *installed and cleaned up in the staging area* within this session, will not work on it again; if you really want to start over, try something like `force get $id`" + ); + } + } + if (my $why = $self->check_disabled) { $self->{unwrapped} = CPAN::Distrostatus->new("NO $why"); # XXX why is this goodbye() instead of just print/warn? @@ -366,10 +380,12 @@ sub get { $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { + $self->post_get(); return $self->goto($goto); } if ( defined( my $sc = $self->shortcut_get) ) { + $self->post_get(); return $sc; } @@ -388,15 +404,22 @@ sub get { # is already checked in shortcut_get() -- xdg, 2012-04-05 unless ($self->{build_dir} && -d $self->{build_dir}) { $self->get_file_onto_local_disk; - return if $CPAN::Signal; + if ($CPAN::Signal){ + $self->post_get(); + return; + } $self->check_integrity; - return if $CPAN::Signal; + if ($CPAN::Signal){ + $self->post_get(); + return; + } (my $packagedir,$local_file) = $self->run_preps_on_packagedir; # XXX why is this check here? -- xdg, 2012-04-08 if (exists $self->{writemakefile} && ref $self->{writemakefile} && $self->{writemakefile}->can("failed") && $self->{writemakefile}->failed) { # + $self->post_get(); return; } $packagedir ||= $self->{build_dir}; @@ -408,9 +431,13 @@ sub get { # a $CPAN::Signal check -- xdg, 2012-04-05 if ($CPAN::Signal) { $self->safe_chdir($sub_wd); + $self->post_get(); + return; + } + unless ($self->patch){ + $self->post_get(); return; } - return unless $self->patch; $self->store_persistent_state; $self->post_get(); @@ -529,9 +556,10 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n"); if (@readdir == 1 && -d $readdir[0]) { $tdir_base = $readdir[0]; $from_dir = File::Spec->catdir(File::Spec->curdir,$readdir[0]); + my($mode) = (stat $from_dir)[2]; + chmod $mode | 00755, $from_dir; # JONATHAN/Math-Calculus-TaylorSeries-0.1.tar.gz has 0644 my $dh2; unless ($dh2 = DirHandle->new($from_dir)) { - my($mode) = (stat $from_dir)[2]; my $why = sprintf ( "Couldn't opendir '%s', mode '%o': %s", @@ -554,10 +582,6 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n"); $from_dir = File::Spec->curdir; @dirents = @readdir; } - eval { File::Path::mkpath $builddir; }; - if ($@) { - $CPAN::Frontend->mydie("Cannot create directory $builddir: $@"); - } my $packagedir; my $eexist = ($CPAN::META->has_usable("Errno") && defined &Errno::EEXIST) ? &Errno::EEXIST : undef; @@ -572,6 +596,8 @@ See also http://rt.cpan.org/Ticket/Display.html?id=38932\n"); my $f; for $f (@dirents) { # is already without "." and ".." my $from = File::Spec->catfile($from_dir,$f); + my($mode) = (stat $from)[2]; + chmod $mode | 00755, $from if -d $from; # OTTO/Pod-Trial-LinkImg-0.005.tgz my $to = File::Spec->catfile($packagedir,$f); unless (File::Copy::move($from,$to)) { my $err = $!; @@ -1217,10 +1243,10 @@ sub untar_me { sub unzip_me { my($self,$ct) = @_; $self->{archived} = "zip"; - if ($ct->unzip()) { + if (eval { $ct->unzip() }) { $self->{unwrapped} = CPAN::Distrostatus->new("YES"); } else { - $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed"); + $self->{unwrapped} = CPAN::Distrostatus->new("NO -- unzip failed during unzip"); } return; } @@ -1637,23 +1663,28 @@ sub force { "prefs", "prefs_file", "prefs_file_doc", + "cleanup_after_install_done", ], make => [ "writemakefile", "make", "modulebuild", "prereq_pm", + "cleanup_after_install_done", ], test => [ "badtestcnt", "make_test", - ], + "cleanup_after_install_done", + ], install => [ "install", + "cleanup_after_install_done", ], unknown => [ "reqtype", "yaml_content", + "cleanup_after_install_done", ], ); my $methodmatch = 0; @@ -1830,7 +1861,9 @@ sub prepare { ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # prepare $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls @@ -1992,7 +2025,9 @@ sub prepare { ($output, $ret) = eval { CPAN::Reporter::record_command($system) }; if (! defined $output or $@) { my $err = $@ || "Unknown error"; - $CPAN::Frontend->mywarn("Error while running PL phase: $err"); + $CPAN::Frontend->mywarn("Error while running PL phase: $err\n"); + $self->{writemakefile} = CPAN::Distrostatus + ->new("NO '$system' returned status $ret and no output"); return $self->goodbye("$system -- NOT OK"); } CPAN::Reporter::grade_PL( $self, $system, $output, $ret ); @@ -2062,8 +2097,14 @@ sub make { $self->pre_make(); + if (exists $self->{cleanup_after_install_done}) { + $self->post_make(); + return $self->get; + } + $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { + $self->post_make(); return $self->goto($goto); } # Emergency brake if they said install Pippi and get newest perl @@ -2100,19 +2141,24 @@ is part of the perl-%s distribution. To install that, you need to run )); $self->{make} = CPAN::Distrostatus->new("NO isa perl"); $CPAN::Frontend->mysleep(1); + $self->post_make(); return; } } - $self->prepare - or return; + unless ($self->prepare){ + $self->post_make(); + return; + } if ( defined( my $sc = $self->shortcut_make) ) { + $self->post_make(); return $sc; } if ($CPAN::Signal) { delete $self->{force_update}; + $self->post_make(); return; } @@ -2121,6 +2167,7 @@ is part of the perl-%s distribution. To install that, you need to run unless (chdir $builddir) { $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!"); + $self->post_make(); return; } @@ -2130,17 +2177,21 @@ is part of the perl-%s distribution. To install that, you need to run ? $ENV{PERL5LIB} : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # make $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls if ($CPAN::Signal) { delete $self->{force_update}; + $self->post_make(); return; } if ($^O eq 'MacOS') { Mac::BuildTools::make($self); + $self->post_make(); return; } @@ -2151,16 +2202,23 @@ is part of the perl-%s distribution. To install that, you need to run } local @ENV{keys %env} = values %env; my $satisfied = eval { $self->satisfy_requires }; - return $self->goodbye($@) if $@; - return unless $satisfied ; + if ($@) { + return $self->goodbye($@); + } + unless ($satisfied){ + $self->post_make(); + return; + } if ($CPAN::Signal) { delete $self->{force_update}; + $self->post_make(); return; } # need to chdir again, because $self->satisfy_requires might change the directory unless (chdir $builddir) { $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!"); + $self->post_make(); return; } @@ -2794,12 +2852,16 @@ sub prereqs_for_slot { if ($self->{CALLED_FOR} =~ /^( CPAN::Meta::Requirements + |CPAN::DistnameInfo |version |parent |ExtUtils::MakeMaker |Test::Harness )$/x) { - $CPAN::Frontend->mywarn("Setting requirements to nil as a workaround\n"); + $CPAN::Frontend->mywarn("Please install CPAN::Meta::Requirements ". + "as soon as possible; it is needed for a reliable operation of ". + "the cpan shell; setting requirements to nil for '$1' for now ". + "to prevent deadlock during bootstrapping\n"); return; } $before = " before $self->{CALLED_FOR}"; @@ -2956,7 +3018,8 @@ sub unsat_prereq { next NEED; } } elsif ( - $self->{reqtype} =~ /^(r|c)$/ + $self->{reqtype} # e.g. maybe we came via goto? + && $self->{reqtype} =~ /^(r|c)$/ && ( exists $prereq_pm->{requires}{$need_module} || exists $prereq_pm->{opt_requires}{$need_module} ) && $nmo @@ -3531,21 +3594,31 @@ sub test { $self->pre_test(); + if (exists $self->{cleanup_after_install_done}) { + $self->post_test(); + return $self->make; + } + $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { + $self->post_test(); return $self->goto($goto); } - $self->make - or return; + unless ($self->make){ + $self->post_test(); + return; + } if ( defined( my $sc = $self->shortcut_test ) ) { + $self->post_test(); return $sc; } if ($CPAN::Signal) { - delete $self->{force_update}; - return; + delete $self->{force_update}; + $self->post_test(); + return; } # warn "XDEBUG: checking for notest: $self->{notest} $self"; my $make = $self->{modulebuild} ? "Build" : "make"; @@ -3555,12 +3628,26 @@ sub test { : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # test $CPAN::META->set_perl5lib; local $ENV{MAKEFLAGS}; # protect us from outer make calls local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default}; local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default}; + if ($run_allow_installing_within_test) { + my($allow_installing, $why) = $self->_allow_installing; + if (! $allow_installing) { + $CPAN::Frontend->mywarn("Testing/Installation stopped: $why\n"); + $self->introduce_myself; + $self->{make_test} = CPAN::Distrostatus->new("NO -- testing/installation stopped due $why"); + $CPAN::Frontend->mywarn(" [testing] -- NOT OK\n"); + delete $self->{force_update}; + $self->post_test(); + return; + } + } $CPAN::Frontend->myprint(sprintf "Running %s test for %s\n", $make, $self->pretty_id); my $builddir = $self->dir or @@ -3568,6 +3655,7 @@ sub test { unless (chdir $builddir) { $CPAN::Frontend->mywarn("Couldn't chdir to '$builddir': $!"); + $self->post_test(); return; } @@ -3576,6 +3664,7 @@ sub test { if ($^O eq 'MacOS') { Mac::BuildTools::make_test($self); + $self->post_test(); return; } @@ -3587,9 +3676,10 @@ sub test { # Test::Harness 3.0 self-tests, so that should be 'unless # installing Test::Harness' unless ($self->id eq $thm->distribution->id) { - $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only + $CPAN::Frontend->mywarn(qq{The version of your Test::Harness is only '$v', you need at least '2.62'. Please upgrade your Test::Harness.\n}); $self->{make_test} = CPAN::Distrostatus->new("NO Test::Harness too old"); + $self->post_test(); return; } } @@ -3611,12 +3701,14 @@ sub test { $CPAN::META->is_tested($self->{build_dir},$self->{make_test}{TIME}); } $CPAN::Frontend->myprint("Found prior test report -- OK\n"); + $self->post_test(); return; } elsif ( $reports[-1]->{grade} =~ /^(?:FAIL|NA)$/ ) { $self->{make_test} = CPAN::Distrostatus->new("NO"); $self->{badtestcnt}++; $CPAN::Frontend->mywarn("Found prior test report -- NOT OK\n"); + $self->post_test(); return; } } @@ -3660,18 +3752,45 @@ sub test { "testing without\n"); } } - if ($want_expect) { - if ($self->_should_report('test')) { - $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". - "not supported when distroprefs specify ". - "an interactive test\n"); + + FORK: { + my $pid = fork; + if (! defined $pid) { # contention + warn "Contention '$!', sleeping 2"; + sleep 2; + redo FORK; + } elsif ($pid) { # parent + if ($^O eq "MSWin32") { + wait; + } else { + SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) { + if ($CPAN::Signal) { + kill 9, -$pid; + } + sleep 1; + } + } + $tests_ok = !$?; + } else { # child + POSIX::setsid() unless $^O eq "MSWin32"; + my $c_ok; + $|=1; + if ($want_expect) { + if ($self->_should_report('test')) { + $CPAN::Frontend->mywarn("Reporting via CPAN::Reporter is currently ". + "not supported when distroprefs specify ". + "an interactive test\n"); + } + $c_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; + } elsif ( $self->_should_report('test') ) { + $c_ok = CPAN::Reporter::test($self, $system); + } else { + $c_ok = system($system) == 0; + } + exit !$c_ok; } - $tests_ok = $self->_run_via_expect($system,'test',$expect_model) == 0; - } elsif ( $self->_should_report('test') ) { - $tests_ok = CPAN::Reporter::test($self, $system); - } else { - $tests_ok = system($system) == 0; - } + } # FORK + $self->introduce_myself; my $but = $self->_make_test_illuminate_prereqs(); if ( $tests_ok ) { @@ -3679,6 +3798,7 @@ sub test { $CPAN::Frontend->mywarn("Tests succeeded but $but\n"); $self->{make_test} = CPAN::Distrostatus->new("NO $but"); $self->store_persistent_state; + $self->post_test(); return $self->goodbye("[dependencies] -- NA"); } $CPAN::Frontend->myprint(" $system -- OK\n"); @@ -3696,6 +3816,8 @@ sub test { $self->{make_test} = CPAN::Distrostatus->new( "NO but failure ignored because 'force' in effect" ); + } elsif ($CPAN::Signal) { + $self->{make_test} = CPAN::Distrostatus->new("NO -- Interrupted"); } else { $self->{make_test} = CPAN::Distrostatus->new("NO"); } @@ -3745,7 +3867,7 @@ sub _make_test_illuminate_prereqs { if $CPAN::DEBUG; } else { push @prereq, $m - if $m_obj->{mandatory}; + unless $self->is_locally_optional(undef, $m); } } my $but; @@ -3895,7 +4017,12 @@ sub goto { # and run where we left off my($method) = (caller(1))[3]; - CPAN->instance("CPAN::Distribution",$goto)->$method(); + my $goto_do = CPAN->instance("CPAN::Distribution",$goto); + $goto_do->called_for($self->called_for) unless $goto_do->called_for; + $goto_do->{mandatory} ||= $self->{mandatory}; + $goto_do->{reqtype} ||= $self->{reqtype}; + $goto_do->{coming_from} = $self->pretty_id; + $goto_do->$method(); CPAN::Queue->delete_first($goto); # XXX delete_first returns undef; is that what this should return # up the call stack, eg. return $sefl->goto($goto) -- xdg, 2012-04-04 @@ -3932,12 +4059,36 @@ sub shortcut_install { return undef; } +#-> sub CPAN::Distribution::is_being_sponsored ; + +# returns true if we find a distro object in the queue that has +# sponsored this one +sub is_being_sponsored { + my($self) = @_; + my $iterator = CPAN::Queue->iterator; + QITEM: while (my $q = $iterator->()) { + my $s = $q->as_string; + my $obj = CPAN::Shell->expandany($s) or next QITEM; + my $type = ref $obj; + if ( $type eq 'CPAN::Distribution' ){ + for my $module (sort keys %{$obj->{sponsored_mods} || {}}) { + return 1 if grep { $_ eq $module } $self->containsmods; + } + } + } + return 0; +} + #-> sub CPAN::Distribution::install ; sub install { my($self) = @_; $self->pre_install(); + if (exists $self->{cleanup_after_install_done}) { + return $self->test; + } + $self->debug("checking goto id[$self->{ID}]") if $CPAN::DEBUG; if (my $goto = $self->prefs->{goto}) { $self->goto($goto); @@ -4039,11 +4190,31 @@ sub install { : ($ENV{PERLLIB} || ""); local $ENV{PERL5OPT} = defined $ENV{PERL5OPT} ? $ENV{PERL5OPT} : ""; - local $ENV{PERL_USE_UNSAFE_INC} = exists $ENV{PERL_USE_UNSAFE_INC} ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install + local $ENV{PERL_USE_UNSAFE_INC} = + exists $ENV{PERL_USE_UNSAFE_INC} && defined $ENV{PERL_USE_UNSAFE_INC} + ? $ENV{PERL_USE_UNSAFE_INC} : 1; # install $CPAN::META->set_perl5lib; local $ENV{PERL_MM_USE_DEFAULT} = 1 if $CPAN::Config->{use_prompt_default}; local $ENV{NONINTERACTIVE_TESTING} = 1 if $CPAN::Config->{use_prompt_default}; + my $install_env; + if ($self->prefs->{install}) { + $install_env = $self->prefs->{install}{env}; + } + local @ENV{keys %$install_env} = values %$install_env if $install_env; + + if (! $run_allow_installing_within_test) { + my($allow_installing, $why) = $self->_allow_installing; + if (! $allow_installing) { + $CPAN::Frontend->mywarn("Installation stopped: $why\n"); + $self->introduce_myself; + $self->{install} = CPAN::Distrostatus->new("NO -- installation stopped due $why"); + $CPAN::Frontend->mywarn(" $system -- NOT OK\n"); + delete $self->{force_update}; + $self->post_install(); + return; + } + } my($pipe) = FileHandle->new("$system $stderr |"); unless ($pipe) { $CPAN::Frontend->mywarn("Can't execute $system: $!"); @@ -4069,7 +4240,8 @@ sub install { $CPAN::META->is_installed($self->{build_dir}); $self->{install} = CPAN::Distrostatus->new("YES"); if ($CPAN::Config->{'cleanup_after_install'} - && ! $self->is_dot_dist) { + && ! $self->is_dot_dist + && ! $self->is_being_sponsored) { my $parent = File::Spec->catdir( $self->{build_dir}, File::Spec->updir ); chdir $parent or $CPAN::Frontend->mydie("Couldn't chdir to $parent: $!\n"); File::Path::rmtree($self->{build_dir}); @@ -4077,6 +4249,7 @@ sub install { if (-e $yml) { unlink $yml or $CPAN::Frontend->mydie("Couldn't unlink $yml: $!\n"); } + $self->{cleanup_after_install_done}=1; } } else { $self->{install} = CPAN::Distrostatus->new("NO"); @@ -4113,6 +4286,162 @@ sub install { return !! $close_ok; } +sub blib_pm_walk { + my @queue = grep { -e $_ } File::Spec->catdir("blib","lib"), File::Spec->catdir("blib","arch"); + return sub { + LOOP: { + if (@queue) { + my $file = shift @queue; + if (-d $file) { + my $dh; + opendir $dh, $file or next; + my @newfiles = map { + my @ret; + my $maybedir = File::Spec->catdir($file, $_); + if (-d $maybedir) { + unless (File::Spec->catdir("blib","arch","auto") eq $maybedir) { + # prune the blib/arch/auto directory, no pm files there + @ret = $maybedir; + } + } elsif (/\.pm$/) { + my $mustbefile = File::Spec->catfile($file, $_); + if (-f $mustbefile) { + @ret = $mustbefile; + } + } + @ret; + } grep { + $_ ne "." + && $_ ne ".." + } readdir $dh; + push @queue, @newfiles; + redo LOOP; + } else { + return $file; + } + } else { + return; + } + } + }; +} + +sub _allow_installing { + my($self) = @_; + my $id = my $pretty_id = $self->pretty_id; + if ($self->{CALLED_FOR}) { + $id .= " (called for $self->{CALLED_FOR})"; + } + my $allow_down = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_module_downgrades}); + $allow_down ||= "ask/yes"; + my $allow_outdd = CPAN::HandleConfig->prefs_lookup($self,q{allow_installing_outdated_dists}); + $allow_outdd ||= "ask/yes"; + return 1 if + $allow_down eq "yes" + && $allow_outdd eq "yes"; + if (($allow_outdd ne "yes") && ! $CPAN::META->has_inst('CPAN::DistnameInfo')) { + return 1 if grep { $_ eq 'CPAN::DistnameInfo'} $self->containsmods; + if ($allow_outdd ne "yes") { + $CPAN::Frontend->mywarn("The current configuration of allow_installing_outdated_dists is '$allow_outdd', but for this option we would need 'CPAN::DistnameInfo' installed. Please install 'CPAN::DistnameInfo' as soon as possible. As long as we are not equipped with 'CPAN::DistnameInfo' this option does not take effect\n"); + $allow_outdd = "yes"; + } + } + return 1 if + $allow_down eq "yes" + && $allow_outdd eq "yes"; + my($dist_version, $dist_dist); + if ($allow_outdd ne "yes"){ + my $dni = CPAN::DistnameInfo->new($pretty_id); + $dist_version = $dni->version; + $dist_dist = $dni->dist; + } + my $iterator = blib_pm_walk(); + my(@down,@outdd); + while (my $file = $iterator->()) { + my $version = CPAN::Module->parse_version($file); + my($volume, $directories, $pmfile) = File::Spec->splitpath( $file ); + my @dirs = File::Spec->splitdir( $directories ); + my(@blib_plus1) = splice @dirs, 0, 2; + my($pmpath) = File::Spec->catfile(grep { length($_) } @dirs, $pmfile); + unless ($allow_down eq "yes") { + if (my $inst_file = $self->_file_in_path($pmpath, \@INC)) { + my $inst_version = CPAN::Module->parse_version($inst_file); + my $cmp = CPAN::Version->vcmp($version, $inst_version); + if ($cmp) { + if ($cmp < 0) { + push @down, { pmpath => $pmpath, version => $version, inst_version => $inst_version }; + } + } + if (@down) { + my $why = "allow_installing_module_downgrades: $id contains downgrading module(s) (e.g. '$down[0]{pmpath}' would downgrade installed '$down[0]{inst_version}' to '$down[0]{version}')"; + if (my($default) = $allow_down =~ m|^ask/(.+)|) { + $default = "yes" unless $default =~ /^(y|n)/i; + my $answer = CPAN::Shell::colorable_makemaker_prompt + ("$why. Do you want to allow installing it?", + $default, "colorize_warn"); + $allow_down = $answer =~ /^\s*y/i ? "yes" : "no"; + } + if ($allow_down eq "no") { + return (0, $why); + } + } + } + } + unless ($allow_outdd eq "yes") { + my @pmpath = (@dirs, $pmfile); + $pmpath[-1] =~ s/\.pm$//; + my $mo = CPAN::Shell->expand("Module",join "::", grep { length($_) } @pmpath); + if ($mo) { + my $cpan_version = $mo->cpan_version; + my $is_lower = CPAN::Version->vlt($version, $cpan_version); + my $other_dist; + if (my $mo_dist = $mo->distribution) { + $other_dist = $mo_dist->pretty_id; + my $dni = CPAN::DistnameInfo->new($other_dist); + if ($dni->dist eq $dist_dist){ + if (CPAN::Version->vgt($dni->version, $dist_version)) { + push @outdd, { + pmpath => $pmpath, + cpan_path => $dni->pathname, + dist_version => $dni->version, + dist_dist => $dni->dist, + }; + } + } + } + } + if (@outdd && $allow_outdd ne "yes") { + my $why = "allow_installing_outdated_dists: $id contains module(s) that are indexed on the CPAN with a different distro: (e.g. '$outdd[0]{pmpath}' is indexed with '$outdd[0]{cpan_path}')"; + if ($outdd[0]{dist_dist} eq $dist_dist) { + $why .= ", and this has a higher distribution-version, i.e. version '$outdd[0]{dist_version}' is higher than '$dist_version')"; + } + if (my($default) = $allow_outdd =~ m|^ask/(.+)|) { + $default = "yes" unless $default =~ /^(y|n)/i; + my $answer = CPAN::Shell::colorable_makemaker_prompt + ("$why. Do you want to allow installing it?", + $default, "colorize_warn"); + $allow_outdd = $answer =~ /^\s*y/i ? "yes" : "no"; + } + if ($allow_outdd eq "no") { + return (0, $why); + } + } + } + } + return 1; +} + +sub _file_in_path { # similar to CPAN::Module::_file_in_path + my($self,$pmpath,$incpath) = @_; + my($dir,@packpath); + foreach $dir (@$incpath) { + my $pmfile = File::Spec->catfile($dir,$pmpath); + if (-f $pmfile) { + return $pmfile; + } + } + return; +} sub introduce_myself { my($self) = @_; $CPAN::Frontend->myprint(sprintf(" %s\n",$self->pretty_id)); @@ -4361,6 +4690,8 @@ sub _should_report { die "_should_report() requires a 'phase' argument" if ! defined $phase; + return unless $CPAN::META->has_usable("CPAN::Reporter"); + # configured my $test_report = CPAN::HandleConfig->prefs_lookup($self, q{test_report}); diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm index 6d9800e31b1..1688a118e4c 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FTP.pm @@ -15,7 +15,7 @@ use vars qw($connect_to_internet_ok $Ua $Thesite $ThesiteURL $Themethod); use vars qw( $VERSION ); -$VERSION = "5.5011"; +$VERSION = "5.5012"; sub _plus_append_open { my($fh, $file) = @_; @@ -23,7 +23,7 @@ sub _plus_append_open { mkpath $parent_dir; my($cnt); until (open $fh, "+>>$file") { - next if $! == Errno::EAGAIN; # don't increment on EAGAIN + next if exists &Errno::EAGAIN && $! == &Errno::EAGAIN; # don't increment on EAGAIN $CPAN::Frontend->mydie("Could not open '$file' after 10000 tries: $!") if ++$cnt > 100000; sleep 0.0001; mkpath $parent_dir; @@ -34,6 +34,8 @@ sub _plus_append_open { # if they want to rewrite, they need to pass in a filehandle sub _ftp_statistics { my($self,$fh) = @_; + my $ftpstats_size = $CPAN::Config->{ftpstats_size}; + return if defined $ftpstats_size && $ftpstats_size <= 0; my $locktype = $fh ? LOCK_EX : LOCK_SH; # XXX On Windows flock() implements mandatory locking, so we can # XXX only use shared locking to still allow _yaml_load_file() to @@ -120,18 +122,23 @@ sub _add_to_statistics { my @debug; @debug = $time if $sdebug; my $fullstats = $self->_ftp_statistics($fh); - close $fh; + close $fh if $fh && defined(fileno($fh)); $fullstats->{history} ||= []; push @debug, scalar @{$fullstats->{history}} if $sdebug; push @debug, time if $sdebug; push @{$fullstats->{history}}, $stats; # YAML.pm 0.62 is unacceptably slow with 999; # YAML::Syck 0.82 has no noticable performance problem with 999; - my $ftpstats_size = $CPAN::Config->{ftpstats_size} || 99; + my $ftpstats_size = $CPAN::Config->{ftpstats_size}; + $ftpstats_size = 99 unless defined $ftpstats_size; my $ftpstats_period = $CPAN::Config->{ftpstats_period} || 14; while ( - @{$fullstats->{history}} > $ftpstats_size - || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period + @{$fullstats->{history} || []} + && + ( + @{$fullstats->{history}} > $ftpstats_size + || $time - $fullstats->{history}[0]{start} > 86400*$ftpstats_period + ) ) { shift @{$fullstats->{history}} } diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm index 49fa8ab7b95..af4a6d77591 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/FirstTime.pm @@ -9,8 +9,9 @@ use File::Basename (); use File::Path (); use File::Spec (); use CPAN::Mirrors (); +use CPAN::Version (); use vars qw($VERSION $auto_config); -$VERSION = "5.5311"; +$VERSION = "5.5314"; =head1 NAME @@ -37,6 +38,34 @@ my @podpara = split /\n\n/, <<'=back'; =over 2 +=item allow_installing_module_downgrades + +The CPAN shell can watch the C<blib/> directories that are built up +before running C<make test> to determine whether the current +distribution will end up with modules being overwritten with decreasing module version numbers. It +can then let the build of this distro fail when it discovers a +downgrade. + +Do you want to allow installing distros with decreasing module +versions compared to what you have installed (yes, no, ask/yes, +ask/no)? + +=item allow_installing_outdated_dists + +The CPAN shell can watch the C<blib/> directories that are built up +before running C<make test> to determine whether the current +distribution contains modules that are indexed with a distro with a +higher distro-version number than the current one. It can +then let the build of this distro fail when it would not represent the +most up-to-date version of the distro. + +Note: choosing anyhing but 'yes' for this option will need +Devel::DistnameInfo being installed for taking effect. + +Do you want to allow installing distros that are not indexed as the +highest distro-version for all contained modules (yes, no, ask/yes, +ask/no)? + =item auto_commit Normally CPAN.pm keeps config variables in memory and changes need to @@ -192,7 +221,8 @@ How many days shall we keep statistics about downloads? =item ftpstats_size Statistics about downloads are truncated by size and period -simultaneously. +simultaneously. Setting this to zero or negative disables download +statistics. How many items shall we keep in the statistics about downloads? @@ -567,6 +597,23 @@ regardless of the history using "force". Do you want to rely on the test report history (yes/no)? +=item urllist_ping_external + +When automatic selection of the nearest cpan mirrors is performed, +turn on the use of the external ping via Net::Ping::External. This is +recommended in the case the local network has a transparent proxy. + +Do you want to use the external ping command when autoselecting +mirrors? + +=item urllist_ping_verbose + +When automatic selection of the nearest cpan mirrors is performed, +this option can be used to turn on verbosity during the selection +process. + +Do you want to see verbosity turned on when autoselecting mirrors? + =item use_prompt_default When this is true, CPAN will set PERL_MM_USE_DEFAULT to a true @@ -1088,6 +1135,14 @@ sub init { my_dflt_prompt(mbuild_install_arg => "", $matcher); + for my $o (qw( + allow_installing_outdated_dists + allow_installing_module_downgrades + )) { + my_prompt_loop($o => 'ask/no', $matcher, + 'yes|no|ask/yes|ask/no'); + } + # #== use_prompt_default # @@ -1263,6 +1318,12 @@ sub init { # Allow matching but don't show during manual config if ($matcher) { + if ("urllist_ping_external" =~ $matcher) { + my_yn_prompt(urllist_ping_external => 0, $matcher); + } + if ("urllist_ping_verbose" =~ $matcher) { + my_yn_prompt(urllist_ping_verbose => 0, $matcher); + } if ("randomize_urllist" =~ $matcher) { my_dflt_prompt(randomize_urllist => 0, $matcher); } @@ -1450,7 +1511,7 @@ sub _do_pick_mirrors { $CPAN::Frontend->myprint($prompts{urls_intro}); # Only prompt for auto-pick if Net::Ping is new enough to do timings my $_conf = 'n'; - if ( $CPAN::META->has_usable("Net::Ping") && Net::Ping->VERSION gt '2.13') { + if ( $CPAN::META->has_usable("Net::Ping") && CPAN::Version->vgt(Net::Ping->VERSION, '2.13')) { $_conf = prompt($prompts{auto_pick}, "yes"); } else { prompt("Autoselection disabled due to Net::Ping missing or insufficient. Please press ENTER"); @@ -1678,7 +1739,6 @@ sub my_yn_prompt { my $default; defined($default = $CPAN::Config->{$item}) or $default = $dflt; - # $DB::single = 1; if (!$auto_config && (!$m || $item =~ /$m/)) { if (my $intro = $prompts{$item . "_intro"}) { $CPAN::Frontend->myprint($intro); @@ -1697,7 +1757,8 @@ sub my_prompt_loop { my $ans; if (!$auto_config && (!$m || $item =~ /$m/)) { - $CPAN::Frontend->myprint($prompts{$item . "_intro"}); + my $intro = $prompts{$item . "_intro"}; + $CPAN::Frontend->myprint($intro) if defined $intro; $CPAN::Frontend->myprint(" <$item>\n"); do { $ans = prompt($prompts{$item}, $default); } until $ans =~ /$ok/; @@ -1915,17 +1976,25 @@ sub auto_mirrored_by { my $mirrors = CPAN::Mirrors->new($local); my $cnt = 0; + my $callback_was_active = 0; my @best = $mirrors->best_mirrors( how_many => 3, callback => sub { + $callback_was_active++; $CPAN::Frontend->myprint("."); if ($cnt++>60) { $cnt=0; $CPAN::Frontend->myprint("\n"); } }, + $CPAN::Config->{urllist_ping_external} ? (external_ping => 1) : (), + $CPAN::Config->{urllist_ping_verbose} ? (verbose => 1) : (), ); - my $urllist = [ map { $_->http } @best ]; + my $urllist = [ + map { $_->http } + grep { $_ && ref $_ && $_->can('http') } + @best + ]; push @$urllist, grep { /^file:/ } @{$CPAN::Config->{urllist}}; - $CPAN::Frontend->myprint(" done!\n\n"); + $CPAN::Frontend->myprint(" done!\n\n") if $callback_was_active; return $urllist } diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm index c72439f92cb..e24a969c11f 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/HandleConfig.pm @@ -12,7 +12,7 @@ CPAN::HandleConfig - internal configuration handling for CPAN.pm =cut -$VERSION = "5.5008"; # see also CPAN::Config::VERSION at end of file +$VERSION = "5.5011"; # see also CPAN::Config::VERSION at end of file %can = ( commit => "Commit changes to disk", @@ -33,6 +33,8 @@ $VERSION = "5.5008"; # see also CPAN::Config::VERSION at end of file %keys = map { $_ => undef } ( + "allow_installing_module_downgrades", + "allow_installing_outdated_dists", "applypatch", "auto_commit", "build_cache", @@ -112,6 +114,8 @@ $VERSION = "5.5008"; # see also CPAN::Config::VERSION at end of file "trust_test_report_history", "unzip", "urllist", + "urllist_ping_verbose", + "urllist_ping_external", "use_prompt_default", "use_sqlite", "username", @@ -124,6 +128,8 @@ $VERSION = "5.5008"; # see also CPAN::Config::VERSION at end of file my %prefssupport = map { $_ => 1 } ( + "allow_installing_module_downgrades", + "allow_installing_outdated_dists", "build_requires_install_policy", "check_sigs", "make", @@ -751,7 +757,7 @@ sub prefs_lookup { return $distro->prefs->{cpanconfig}{$what}; } else { $CPAN::Frontend->mywarn("Warning: $what not yet officially ". - "supported for distroprefs, doing a normal lookup"); + "supported for distroprefs, doing a normal lookup\n"); return $CPAN::Config->{$what}; } } @@ -770,7 +776,7 @@ sub prefs_lookup { use strict; use vars qw($AUTOLOAD $VERSION); - $VERSION = "5.5008"; + $VERSION = "5.5011"; # formerly CPAN::HandleConfig was known as CPAN::Config sub AUTOLOAD { ## no critic diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm index 29bb7216ffc..721ead2a85d 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Mirrors.pm @@ -19,7 +19,7 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one my( $m ) = @_; printf "%s = %s\n", $m->hostname, $m->rtt }; - $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback ); + $mirrors->get_mirrors_timings( \@mirrors, $seen, $callback, %args ); @mirrors = sort { $a->rtt <=> $b->rtt } @mirrors; @@ -34,12 +34,13 @@ CPAN::Mirrors - Get CPAN mirror information and select a fast one package CPAN::Mirrors; use strict; use vars qw($VERSION $urllist $silent); -$VERSION = "2.21"; +$VERSION = "2.27"; use Carp; use FileHandle; use Fcntl ":flock"; use Net::Ping (); +use CPAN::Version; =item new( LOCAL_FILE_NAME ) @@ -82,7 +83,7 @@ Return a list of continents based on those defined in F<MIRRORED.BY>. sub continents { my ($self) = @_; - return sort keys %{$self->{geography}}; + return sort keys %{$self->{geography} || {}}; } =item countries( [CONTINENTS] ) @@ -99,7 +100,7 @@ sub countries { @continents = $self->continents unless @continents; my @countries; for my $c (@continents) { - push @countries, sort keys %{ $self->{geography}{$c} }; + push @countries, sort keys %{ $self->{geography}{$c} || {} }; } return @countries; } @@ -165,22 +166,25 @@ dynamic DNS to give a close mirror. =cut -sub default_mirror { 'http://www.cpan.org/' } +sub default_mirror { + CPAN::Mirrored::By->new({ http => 'http://www.cpan.org/'}); +} =item best_mirrors C<best_mirrors> checks for the best mirrors based on the list of continents you pass, or, without that, all continents, as defined by C<CPAN::Mirrored::By>. It pings each mirror, up to the value of -C<how_many>. In list context, it returns up to C<how_many> mirror. +C<how_many>. In list context, it returns up to C<how_many> mirrors. In scalar context, it returns the single best mirror. Arguments - how_many - the number of mirrors to return. Default: 1 - callback - a callback for find_best_continents - verbose - true or false on all the whining and moaning. Default: false - continents - an array ref of the continents to check + how_many - the number of mirrors to return. Default: 1 + callback - a callback for find_best_continents + verbose - true or false on all the whining and moaning. Default: false + continents - an array ref of the continents to check + external_ping - if true, use external ping via Net::Ping::External. Default: false If you don't specify the continents, C<best_mirrors> calls C<find_best_continents> to get the list of continents to check. @@ -188,6 +192,9 @@ C<find_best_continents> to get the list of continents to check. If you don't have L<Net::Ping> v2.13 or later, needed for timings, this returns the default mirror. +C<external_ping> should be set and then C<Net::Ping::External> needs +to be installed, if the local network has a transparent proxy. + =cut sub best_mirrors { @@ -197,10 +204,12 @@ sub best_mirrors { my $verbose = defined $args{verbose} ? $args{verbose} : 0; my $continents = $args{continents} || []; $continents = [$continents] unless ref $continents; + $args{external_ping} = 0 unless defined $args{external_ping}; + my $external_ping = $args{external_ping}; # Old Net::Ping did not do timings at all my $min_version = '2.13'; - unless( Net::Ping->VERSION gt $min_version ) { + unless( CPAN::Version->vgt(Net::Ping->VERSION, $min_version) ) { carp sprintf "Net::Ping version is %s (< %s). Returning %s", Net::Ping->VERSION, $min_version, $self->default_mirror; return $self->default_mirror; @@ -211,9 +220,10 @@ sub best_mirrors { if ( ! @$continents ) { print "Searching for the best continent ...\n" if $verbose; my @best_continents = $self->find_best_continents( - seen => $seen, - verbose => $verbose, - callback => $callback, + seen => $seen, + verbose => $verbose, + callback => $callback, + external_ping => $external_ping, ); # Only add enough continents to find enough mirrors @@ -225,12 +235,18 @@ sub best_mirrors { } } + return $self->default_mirror unless @$continents; print "Scanning " . join(", ", @$continents) . " ...\n" if $verbose; my $trial_mirrors = $self->get_n_random_mirrors_by_continents( 3 * $how_many, $continents->[0] ); - my $timings = $self->get_mirrors_timings( $trial_mirrors, $seen, $callback ); - return [] unless @$timings; + my $timings = $self->get_mirrors_timings( + $trial_mirrors, + $seen, + $callback, + %args, + ); + return $self->default_mirror unless @$timings; $how_many = @$timings if $how_many > @$timings; @@ -268,7 +284,7 @@ sub get_n_random_mirrors_by_continents { \@long_list; } -=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK ); +=item get_mirrors_timings( MIRROR_LIST, SEEN, CALLBACK, %ARGS ); Pings the listed mirrors and returns a list of mirrors sorted in ascending ping times. @@ -286,7 +302,7 @@ ping. =cut sub get_mirrors_timings { - my( $self, $mirror_list, $seen, $callback ) = @_; + my( $self, $mirror_list, $seen, $callback, %args ) = @_; $seen = {} unless defined $seen; croak "The mirror list argument must be an array reference" @@ -302,8 +318,9 @@ sub get_mirrors_timings { next unless eval{ $m->http }; if( $self->_try_a_ping( $seen, $m, ) ) { - my $ping = $m->ping; + my $ping = $m->ping(%args); next unless defined $ping; + # printf "m %s ping %s\n", $m, $ping; push @$timings, $m; $callback->( $m ) if $callback; } @@ -367,20 +384,21 @@ value. sub find_best_continents { my ($self, %args) = @_; - $args{n} ||= 3; + $args{n} ||= 3; $args{verbose} = 0 unless defined $args{verbose}; $args{seen} = {} unless defined $args{seen}; croak "The seen argument must be a hash reference" unless ref $args{seen} eq ref {}; $args{ping_cache_limit} = 24 * 60 * 60 - unless defined $args{ping_cache_time}; + unless defined $args{ping_cache_limit}; croak "callback must be a subroutine" if( defined $args{callback} and ref $args{callback} ne ref sub {} ); my %medians; CONT: for my $c ( $self->continents ) { - print "Testing $c\n" if $args{verbose}; my @mirrors = $self->mirrors( $self->countries($c) ); + printf "Testing %s (%d mirrors)\n", $c, scalar @mirrors + if $args{verbose}; next CONT unless @mirrors; my $n = (@mirrors < $args{n}) ? @mirrors : $args{n}; @@ -389,11 +407,18 @@ sub find_best_continents { my $tries = 0; RANDOM: while ( @mirrors && @tests < $n && $tries++ < 15 ) { my $m = splice( @mirrors, int(rand(@mirrors)), 1 ); - if( $self->_try_a_ping( $args{seen}, $m, $args{ping_cache_limit} ) ) { - $self->get_mirrors_timings( [ $m ], $args{seen}, $args{callback} ); + if( $self->_try_a_ping( + $args{seen}, $m, $args{ping_cache_limit} + )) { + $self->get_mirrors_timings( + [ $m ], + $args{seen}, + $args{callback}, + %args, + ); next RANDOM unless defined $args{seen}{$m->hostname}->rtt; } - printf "\t%s -> %0.2f ms\n", + printf "(%s -> %0.2f ms)", $m->hostname, join ' ', 1000 * $args{seen}{$m->hostname}->rtt if $args{verbose}; @@ -409,8 +434,12 @@ sub find_best_continents { if ( $args{verbose} ) { print "Median result by continent:\n"; - for my $c ( @best_cont ) { - printf( " %4d ms %s\n", int($medians{$c}*1000+.5), $c ); + if ( @best_cont ) { + for my $c ( @best_cont ) { + printf( " %7.2f ms %s\n", $medians{$c}*1000, $c ); + } + } else { + print " **** No results found ****\n" } } @@ -421,12 +450,14 @@ sub find_best_continents { sub _try_a_ping { my ($self, $seen, $mirror, $ping_cache_limit ) = @_; - ( ! exists $seen->{$mirror->hostname} ) + ( ! exists $seen->{$mirror->hostname} or - ( ! defined $seen->{$mirror->hostname}->rtt - or - time - $seen->{$mirror->hostname}->rtt > $ping_cache_limit + or + ! defined $ping_cache_limit + or + time - $seen->{$mirror->hostname}->ping_time + > $ping_cache_limit ) } @@ -445,7 +476,13 @@ sub _get_median_ping_time { } }; - printf "\t-->median time: %0.2f ms\n", $median * 1000 if $verbose; + if ($verbose){ + if ($median) { + printf " => median time: %.2f ms\n", $median * 1000 + } else { + printf " => **** no median time ****\n"; + } + } return $median; } @@ -546,9 +583,17 @@ sub url { } sub ping { - my $self = shift; + my($self, %args) = @_; - my $ping = Net::Ping->new($^O eq 'VMS' ? 'icmp' : 'tcp', 1); + my $external_ping = $args{external_ping}; + if ($external_ping) { + eval { require Net::Ping::External } + or die "Net::Ping::External required to use external ping command"; + } + my $ping = Net::Ping->new( + $external_ping ? 'external' : $^O eq 'VMS' ? 'icmp' : 'tcp', + 1 + ); my ($proto) = $self->url =~ m{^([^:]+)}; my $port = $proto eq 'http' ? 80 : 21; return unless $port; @@ -561,7 +606,11 @@ sub ping { } $ping->hires(1) if $ping->can('hires'); - my ($alive,$rtt) = $ping->ping($self->hostname); + my ($alive,$rtt) = eval { $ping->ping($self->hostname); }; + my $verbose = $args{verbose}; + if ($verbose && !$alive) { + printf "(host %s not alive)", $self->hostname; + } $self->{rtt} = $alive ? $rtt : undef; $self->{ping_time} = time; diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm index 8027d22d3b2..259e47e05f7 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Queue.pm @@ -72,7 +72,7 @@ package CPAN::Queue; # in CPAN::Distribution::rematein. use vars qw{ @All $VERSION }; -$VERSION = "5.5002"; +$VERSION = "5.5003"; # CPAN::Queue::queue_item ; sub queue_item { @@ -207,6 +207,17 @@ sub reqtype_of { return $best; } +sub iterator { + my $i = 0; + return sub { + until ($All[$i] || $i > $#All) { + $i++; + } + return if $i > $#All; + return $All[$i++] + }; +} + 1; __END__ diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm index b5d88924df9..4140fb8af23 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Shell.pm @@ -47,7 +47,7 @@ use vars qw( "CPAN/Tarzip.pm", "CPAN/Version.pm", ); -$VERSION = "5.5008"; +$VERSION = "5.5009"; # record the initial timestamp for reload. $reload = { map {$INC{$_} ? ($_,(stat $INC{$_})[9]) : ()} @relo }; @CPAN::Shell::ISA = qw(CPAN::Debug); @@ -1611,9 +1611,10 @@ sub mydie { # sub CPAN::Shell::colorable_makemaker_prompt ; sub colorable_makemaker_prompt { - my($foo,$bar) = @_; + my($foo,$bar,$ornament) = @_; + $ornament ||= "colorize_print"; if (CPAN::Shell->colorize_output) { - my $ornament = $CPAN::Config->{colorize_print}||'bold blue on_white'; + my $ornament = $CPAN::Config->{$ornament}||'bold blue on_white'; my $color_on = eval { Term::ANSIColor::color($ornament); } || ""; print $color_on; } @@ -1867,7 +1868,7 @@ to find objects with matching identifiers. } } if (UNIVERSAL::can($obj, 'called_for')) { - $obj->called_for($s); + $obj->called_for($s) unless $obj->called_for; } CPAN->debug(qq{pragma[@pragma]meth[$meth]}. qq{ID[$obj->{ID}]}) if $CPAN::DEBUG; diff --git a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm index f585a01bf72..6517cb8fd72 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm +++ b/gnu/usr.bin/perl/cpan/CPAN/lib/CPAN/Tarzip.pm @@ -4,7 +4,7 @@ use strict; use vars qw($VERSION @ISA $BUGHUNTING); use CPAN::Debug; use File::Basename qw(basename); -$VERSION = "5.5012"; +$VERSION = "5.5013"; # module is internal to CPAN.pm @ISA = qw(CPAN::Debug); ## no critic @@ -41,6 +41,11 @@ CPAN shell prompt to register it as external program. bless $me, $class; } +sub _zlib_ok () { + $CPAN::META->has_inst("Compress::Zlib") or return; + Compress::Zlib->can('gzopen'); +} + sub _my_which { my($what) = @_; if ($CPAN::Config->{$what}) { @@ -66,7 +71,7 @@ sub _my_which { sub gzip { my($self,$read) = @_; my $write = $self->{FILE}; - if ($CPAN::META->has_inst("Compress::Zlib")) { + if (_zlib_ok) { my($buffer,$fhw); $fhw = FileHandle->new($read) or $CPAN::Frontend->mydie("Could not open $read: $!"); @@ -89,7 +94,7 @@ sub gzip { sub gunzip { my($self,$write) = @_; my $read = $self->{FILE}; - if ($CPAN::META->has_inst("Compress::Zlib")) { + if (_zlib_ok) { my($buffer,$fhw); $fhw = FileHandle->new(">$write") or $CPAN::Frontend->mydie("Could not open >$write: $!"); @@ -120,7 +125,7 @@ sub gtest { my($buffer,$len); $len = 0; my $gz = Compress::Bzip2::bzopen($read, "rb") - or $CPAN::Frontend->mydie(sprintf("Cannot gzopen %s: %s\n", + or $CPAN::Frontend->mydie(sprintf("Cannot bzopen %s: %s\n", $read, $Compress::Bzip2::bzerrno)); while ($gz->bzread($buffer) > 0 ) { @@ -135,7 +140,7 @@ sub gtest { } $gz->gzclose(); CPAN->debug("err[$err]success[$success]") if $CPAN::DEBUG; - } elsif ( $read=~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib") ) { + } elsif ( $read=~/\.(?:gz|tgz)$/ && _zlib_ok ) { # After I had reread the documentation in zlib.h, I discovered that # uncompressed files do not lead to an gzerror (anymore?). my($buffer,$len); @@ -183,7 +188,7 @@ sub TIEHANDLE { $CPAN::Frontend->mydie("Could not bzopen $file"); $self->{GZ} = $gz; $class->debug("via Compress::Bzip2"); - } elsif ($file =~/\.(?:gz|tgz)$/ && $CPAN::META->has_inst("Compress::Zlib")) { + } elsif ($file =~/\.(?:gz|tgz)$/ && _zlib_ok) { my $gz = Compress::Zlib::gzopen($file,"rb") or $CPAN::Frontend->mydie("Could not gzopen $file"); $self->{GZ} = $gz; @@ -260,7 +265,7 @@ sub untar { } elsif ( $CPAN::META->has_usable("Archive::Tar") && - $CPAN::META->has_inst("Compress::Zlib") ) { + _zlib_ok ) { my $prefer_external_tar = $CPAN::Config->{prefer_external_tar}; unless (defined $prefer_external_tar) { if ($^O =~ /(MSWin32|solaris)/) { @@ -294,7 +299,7 @@ END_WARN $foundAT = "nothing"; } my $foundCZ; - if ($CPAN::META->has_inst("Compress::Zlib")) { + if (_zlib_ok) { $foundCZ = sprintf "'%s'", "Compress::Zlib::"->VERSION; } elsif ($foundAT) { $foundCZ = "nothing"; diff --git a/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan b/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan index 0041b8ab203..4e900b00547 100644 --- a/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan +++ b/gnu/usr.bin/perl/cpan/CPAN/scripts/cpan @@ -4,7 +4,12 @@ BEGIN { pop @INC if $INC[-1] eq '.' } use strict; use vars qw($VERSION); -use App::Cpan '1.64'; +use App::Cpan; +use CPAN::Version; +my $minver = '1.64'; +if ( CPAN::Version->vlt($App::Cpan::VERSION, $minver) ) { + warn "WARNING: your version of App::Cpan is $App::Cpan::VERSION while we would expect at least $minver"; +} $VERSION = '1.64'; my $rc = App::Cpan->run( @ARGV ); diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.c b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.c index aaf1b4005b0..137ba9f7d5d 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.c +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/bzlib.c @@ -102,12 +102,16 @@ static void* default_bzalloc ( void* opaque, Int32 items, Int32 size ) { void* v = malloc ( items * size ); + ((void)opaque); /* Silence unused parameter warning */ + return v; } static void default_bzfree ( void* opaque, void* addr ) { + ((void)opaque); /* Silence unused parameter warning */ + if (addr != NULL) free ( addr ); } diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/compress.c b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/compress.c index 5dfa00231b0..84e1574c914 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/compress.c +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/compress.c @@ -258,6 +258,7 @@ void sendMTFValues ( EState* s ) UInt16* mtfv = s->mtfv; + ((void)nBytes); /* Silence variable ‘nBytes’ set but not used warning */ if (s->verbosity >= 3) VPrintf3( " %d in block, %d after MTF & 1-2 coding, " "%d+2 syms in use\n", diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/decompress.c b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/decompress.c index 5afd6515788..1a01f1d9f2f 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/decompress.c +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/bzip2-src/decompress.c @@ -41,6 +41,7 @@ void makeMaps_d ( DState* s ) { retVal = rrr; goto save_state_and_return; }; #define GET_BITS(lll,vvv,nnn) \ + /* FALLTHROUGH */ \ case lll: s->state = lll; \ while (True) { \ if (s->bsLive >= nnn) { \ diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm index ce2ac2a398b..2aa14188d7e 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/lib/Compress/Raw/Bzip2.pm @@ -11,7 +11,7 @@ use Carp ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, $AUTOLOAD); -$VERSION = '2.089'; +$VERSION = '2.093'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm index 037782b9498..12fa26fd05f 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/private/MakeUtil.pm @@ -35,8 +35,7 @@ sub MY::libscan my $path = shift; return undef - if $path =~ /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/ || - $path =~ /(~|\.bak|_bak)$/ || + if $path =~ /(~|\.bak|_bak)$/ || $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/t/000prereq.t b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/t/000prereq.t index 8f66d402d0c..c390e5529d8 100755 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/t/000prereq.t +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/t/000prereq.t @@ -19,7 +19,7 @@ BEGIN if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - my $VERSION = '2.089'; + my $VERSION = '2.093'; my @NAMES = qw( ); diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm index 4c369738981..cf7126b4238 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/lib/Compress/Raw/Zlib.pm @@ -10,7 +10,7 @@ use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, %EXPORT_TAGS, @EXPORT_OK, $AUTOLOAD, %DEFLATE_CONSTANTS, @DEFLATE_CONSTANTS); -$VERSION = '2.084'; +$VERSION = '2.093'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -1557,6 +1557,12 @@ C<IO::Compress::RawDeflate>. All the I<zlib> constants are automatically imported when you make use of I<Compress::Raw::Zlib>. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/Compress-Raw-Zlib/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=Compress-Raw-Zlib>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm index 037782b9498..12fa26fd05f 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/private/MakeUtil.pm @@ -35,8 +35,7 @@ sub MY::libscan my $path = shift; return undef - if $path =~ /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/ || - $path =~ /(~|\.bak|_bak)$/ || + if $path =~ /(~|\.bak|_bak)$/ || $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/deflate.c b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/deflate.c index a74194f86f8..52c648fa1bb 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/deflate.c +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/deflate.c @@ -190,8 +190,11 @@ local const config configuration_table[10] = { * prev[] will be initialized on the fly. */ #define CLEAR_HASH(s) \ - s->head[s->hash_size-1] = NIL; \ - zmemzero((Bytef *)s->head, (unsigned)(s->hash_size-1)*sizeof(*s->head)); + do { \ + s->head[s->hash_size-1] = NIL; \ + zmemzero((Bytef *)s->head, \ + (unsigned)(s->hash_size-1)*sizeof(*s->head)); \ + } while (0) /* =========================================================================== * Slide the hash table when sliding the window down (could be avoided with 32 diff --git a/gnu/usr.bin/perl/cpan/DB_File/DB_File.pm b/gnu/usr.bin/perl/cpan/DB_File/DB_File.pm index 6ca1592aadc..a732ff41e09 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/DB_File.pm +++ b/gnu/usr.bin/perl/cpan/DB_File/DB_File.pm @@ -2,7 +2,7 @@ # # Written by Paul Marquess (pmqs@cpan.org) # -# Copyright (c) 1995-2018 Paul Marquess. All rights reserved. +# Copyright (c) 1995-2020 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -31,14 +31,14 @@ sub TIEHASH my $pkg = shift ; bless { VALID => { - bsize => 1, - ffactor => 1, - nelem => 1, - cachesize => 1, - hash => 2, - lorder => 1, - }, - GOT => {} + bsize => 1, + ffactor => 1, + nelem => 1, + cachesize => 1, + hash => 2, + lorder => 1, + }, + GOT => {} }, $pkg ; } @@ -65,8 +65,8 @@ sub STORE if ( $type ) { - croak "Key '$key' not associated with a code reference" - if $type == 2 && !ref $value && ref $value ne 'CODE'; + croak "Key '$key' not associated with a code reference" + if $type == 2 && !ref $value && ref $value ne 'CODE'; $self->{GOT}{$key} = $value ; return ; } @@ -122,9 +122,9 @@ sub TIEHASH my $pkg = shift ; bless { VALID => { map {$_, 1} - qw( bval cachesize psize flags lorder reclen bfname ) - }, - GOT => {}, + qw( bval cachesize psize flags lorder reclen bfname ) + }, + GOT => {}, }, $pkg ; } @@ -140,16 +140,16 @@ sub TIEHASH my $pkg = shift ; bless { VALID => { - flags => 1, - cachesize => 1, - maxkeypage => 1, - minkeypage => 1, - psize => 1, - compare => 2, - prefix => 2, - lorder => 1, - }, - GOT => {}, + flags => 1, + cachesize => 1, + maxkeypage => 1, + minkeypage => 1, + psize => 1, + compare => 2, + prefix => 2, + lorder => 1, + }, + GOT => {}, }, $pkg ; } @@ -165,7 +165,7 @@ use Carp; # Module not thread safe, so don't clone sub CLONE_SKIP { 1 } -$VERSION = "1.843" ; +$VERSION = "1.853" ; $VERSION = eval $VERSION; # needed for dev releases { @@ -203,34 +203,34 @@ push @ISA, qw(Tie::Hash Exporter); @EXPORT = qw( $DB_BTREE $DB_HASH $DB_RECNO - BTREEMAGIC - BTREEVERSION - DB_LOCK - DB_SHMEM - DB_TXN - HASHMAGIC - HASHVERSION - MAX_PAGE_NUMBER - MAX_PAGE_OFFSET - MAX_REC_NUMBER - RET_ERROR - RET_SPECIAL - RET_SUCCESS - R_CURSOR - R_DUP - R_FIRST - R_FIXEDLEN - R_IAFTER - R_IBEFORE - R_LAST - R_NEXT - R_NOKEY - R_NOOVERWRITE - R_PREV - R_RECNOSYNC - R_SETCURSOR - R_SNAPSHOT - __R_UNUSED + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED ); @@ -268,7 +268,7 @@ sub tie_hash_or_array if defined $arg[1] ; $arg[4] = tied %{ $arg[4] } - if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; + if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ; $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2]; $arg[3] = 0666 if @arg >=4 && ! defined $arg[3]; @@ -280,10 +280,10 @@ sub tie_hash_or_array } if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and - $arg[1] and ! -e $arg[1]) { - open(FH, ">$arg[1]") or return undef ; - close FH ; - chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; + $arg[1] and ! -e $arg[1]) { + open(FH, ">$arg[1]") or return undef ; + close FH ; + chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ; } DoTie_($tieHASH, @arg) ; @@ -325,9 +325,9 @@ sub STORESIZE my $current_length = $self->length() ; if ($length < $current_length) { - my $key ; + my $key ; for ($key = $current_length - 1 ; $key >= $length ; -- $key) - { $self->del($key) } + { $self->del($key) } } elsif ($length > $current_length) { $self->put($length-1, "") ; @@ -340,8 +340,8 @@ sub SPLICE my $self = shift; my $offset = shift; if (not defined $offset) { - warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); - $offset = 0; + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); + $offset = 0; } my $has_length = @_; @@ -358,47 +358,47 @@ sub SPLICE # the array.' # if ($offset < 0) { - my $new_offset = $size + $offset; - if ($new_offset < 0) { - die "Modification of non-creatable array value attempted, " - . "subscript $offset"; - } - $offset = $new_offset; + my $new_offset = $size + $offset; + if ($new_offset < 0) { + die "Modification of non-creatable array value attempted, " + . "subscript $offset"; + } + $offset = $new_offset; } if (not defined $length) { - warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); - $length = 0; + warnings::warnif('uninitialized', 'Use of uninitialized value in splice'); + $length = 0; } if ($offset > $size) { - $offset = $size; - warnings::warnif('misc', 'splice() offset past end of array') + $offset = $size; + warnings::warnif('misc', 'splice() offset past end of array') if $has_length ? $splice_end_array : $splice_end_array_no_length; } # 'If LENGTH is omitted, removes everything from OFFSET onward.' if (not defined $length) { - $length = $size - $offset; + $length = $size - $offset; } # 'If LENGTH is negative, leave that many elements off the end of # the array.' # if ($length < 0) { - $length = $size - $offset + $length; - - if ($length < 0) { - # The user must have specified a length bigger than the - # length of the array passed in. But perl's splice() - # doesn't catch this, it just behaves as for length=0. - # - $length = 0; - } + $length = $size - $offset + $length; + + if ($length < 0) { + # The user must have specified a length bigger than the + # length of the array passed in. But perl's splice() + # doesn't catch this, it just behaves as for length=0. + # + $length = 0; + } } if ($length > $size - $offset) { - $length = $size - $offset; + $length = $size - $offset; } # $num_elems holds the current number of elements in the database. @@ -409,94 +409,94 @@ sub SPLICE # my @removed = (); foreach (0 .. $length - 1) { - my $old; - my $status = $self->get($offset, $old); - if ($status != 0) { - my $msg = "error from Berkeley DB on get($offset, \$old)"; - if ($status == 1) { - $msg .= ' (no such element?)'; - } - else { - $msg .= ": error status $status"; - if (defined $! and $! ne '') { - $msg .= ", message $!"; - } - } - die $msg; - } - push @removed, $old; - - $status = $self->del($offset); - if ($status != 0) { - my $msg = "error from Berkeley DB on del($offset)"; - if ($status == 1) { - $msg .= ' (no such element?)'; - } - else { - $msg .= ": error status $status"; - if (defined $! and $! ne '') { - $msg .= ", message $!"; - } - } - die $msg; - } - - -- $num_elems; + my $old; + my $status = $self->get($offset, $old); + if ($status != 0) { + my $msg = "error from Berkeley DB on get($offset, \$old)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ": error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + push @removed, $old; + + $status = $self->del($offset); + if ($status != 0) { + my $msg = "error from Berkeley DB on del($offset)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ": error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + + -- $num_elems; } # ...'and replaces them with the elements of LIST, if any.' my $pos = $offset; while (defined (my $elem = shift @list)) { - my $old_pos = $pos; - my $status; - if ($pos >= $num_elems) { - $status = $self->put($pos, $elem); - } - else { - $status = $self->put($pos, $elem, $self->R_IBEFORE); - } - - if ($status != 0) { - my $msg = "error from Berkeley DB on put($pos, $elem, ...)"; - if ($status == 1) { - $msg .= ' (no such element?)'; - } - else { - $msg .= ", error status $status"; - if (defined $! and $! ne '') { - $msg .= ", message $!"; - } - } - die $msg; - } - - die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE" - if $old_pos != $pos; - - ++ $pos; - ++ $num_elems; + my $old_pos = $pos; + my $status; + if ($pos >= $num_elems) { + $status = $self->put($pos, $elem); + } + else { + $status = $self->put($pos, $elem, $self->R_IBEFORE); + } + + if ($status != 0) { + my $msg = "error from Berkeley DB on put($pos, $elem, ...)"; + if ($status == 1) { + $msg .= ' (no such element?)'; + } + else { + $msg .= ", error status $status"; + if (defined $! and $! ne '') { + $msg .= ", message $!"; + } + } + die $msg; + } + + die "pos unexpectedly changed from $old_pos to $pos with R_IBEFORE" + if $old_pos != $pos; + + ++ $pos; + ++ $num_elems; } if (wantarray) { - # 'In list context, returns the elements removed from the - # array.' - # - return @removed; + # 'In list context, returns the elements removed from the + # array.' + # + return @removed; } elsif (defined wantarray and not wantarray) { - # 'In scalar context, returns the last element removed, or - # undef if no elements are removed.' - # - if (@removed) { - my $last = pop @removed; - return "$last"; - } - else { - return undef; - } + # 'In scalar context, returns the last element removed, or + # undef if no elements are removed.' + # + if (@removed) { + my $last = pop @removed; + return "$last"; + } + else { + return undef; + } } elsif (not defined wantarray) { - # Void context + # Void context } else { die } } @@ -543,11 +543,11 @@ sub get_dup my $db = shift ; my $key = shift ; - my $flag = shift ; - my $value = 0 ; + my $flag = shift ; + my $value = 0 ; my $origkey = $key ; my $wantarray = wantarray ; - my %values = () ; + my %values = () ; my @values = () ; my $counter = 0 ; my $status = 0 ; @@ -555,16 +555,16 @@ sub get_dup # iterate through the database until either EOF ($status == 0) # or a different key is encountered ($key ne $origkey). for ($status = $db->seq($key, $value, R_CURSOR()) ; - $status == 0 and $key eq $origkey ; + $status == 0 and $key eq $origkey ; $status = $db->seq($key, $value, R_NEXT()) ) { # save the value or count number of matches if ($wantarray) { - if ($flag) + if ($flag) { ++ $values{$value} } - else + else { push (@values, $value) } - } + } else { ++ $counter } @@ -692,7 +692,7 @@ like version 1. This feature allows B<DB_File> scripts that were built with version 1 to be migrated to version 2 or greater without any changes. If you want to make use of the new features available in Berkeley DB -2.x or greater, use the Perl module B<BerkeleyDB> instead. +2.x or greater, use the Perl module L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> instead. B<Note:> The database file format has changed multiple times in Berkeley DB version 2, 3 and 4. If you cannot recreate your databases, you @@ -753,7 +753,7 @@ C<ffactor>, C<hash>, C<lorder> and C<nelem>. To change one of these elements, just assign to it like this: - $DB_HASH->{'cachesize'} = 10000 ; + $DB_HASH->{'cachesize'} = 10000 ; The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are usually adequate for most applications. If you do need to create extra @@ -809,12 +809,12 @@ to Perl subs. Below are templates for each of the subs: my ($data) = @_ ; ... # return the hash value for $data - return $hash ; + return $hash ; } sub compare { - my ($key, $key2) = @_ ; + my ($key, $key2) = @_ ; ... # return 0 if $key1 eq $key2 # -1 if $key1 lt $key2 @@ -824,7 +824,7 @@ to Perl subs. Below are templates for each of the subs: sub prefix { - my ($key, $key2) = @_ ; + my ($key, $key2) = @_ ; ... # return number of bytes of $key2 which are # necessary to determine that it is greater than $key1 @@ -1041,7 +1041,7 @@ code: $DB_BTREE->{'flags'} = R_DUP ; tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; # Add some key/value pairs to the file $h{'Wall'} = 'Larry' ; @@ -1096,7 +1096,7 @@ Here is the script above rewritten using the C<seq> API method. $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; # Add some key/value pairs to the file $h{'Wall'} = 'Larry' ; @@ -1167,7 +1167,7 @@ this: $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; my $cnt = $x->get_dup("Wall") ; print "Wall occurred $cnt times\n" ; @@ -1177,13 +1177,13 @@ this: print "There are $hash{'Brick'} Brick Walls\n" ; my @list = sort $x->get_dup("Wall") ; - print "Wall => [@list]\n" ; + print "Wall => [@list]\n" ; @list = $x->get_dup("Smith") ; - print "Smith => [@list]\n" ; + print "Smith => [@list]\n" ; @list = $x->get_dup("Dog") ; - print "Dog => [@list]\n" ; + print "Dog => [@list]\n" ; and it will print: @@ -1191,9 +1191,9 @@ and it will print: Wall occurred 3 times Larry is there There are 2 Brick Walls - Wall => [Brick Brick Larry] - Smith => [John] - Dog => [] + Wall => [Brick Brick Larry] + Smith => [John] + Dog => [] =head2 The find_dup() Method @@ -1217,7 +1217,7 @@ Assuming the database from the previous example: $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; print "Larry Wall is $found there\n" ; @@ -1256,7 +1256,7 @@ Again assuming the existence of the C<tree> database $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; $x->del_dup("Wall", "Larry") ; @@ -1321,10 +1321,10 @@ and print the first matching key/value pair given a partial key. $key = $value = 0 ; print "IN ORDER\n" ; for ($st = $x->seq($key, $value, R_FIRST) ; - $st == 0 ; + $st == 0 ; $st = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } + { print "$key -> $value\n" } print "\nPARTIAL MATCH\n" ; @@ -1625,12 +1625,12 @@ Berkeley DB documentation. To do this you need to store a copy of the object returned from the tie. - $db = tie %hash, "DB_File", "filename" ; + $db = tie %hash, "DB_File", "filename" ; Once you have done that, you can access the Berkeley DB API functions as B<DB_File> methods directly like this: - $db->put($key, $value, R_NOOVERWRITE) ; + $db->put($key, $value, R_NOOVERWRITE) ; B<Important:> If you have saved a copy of the object returned from C<tie>, the underlying database file will I<not> be closed until both @@ -2012,11 +2012,11 @@ not be used. =head2 Safe ways to lock a database Starting with version 2.x, Berkeley DB has internal support for locking. -The companion module to this one, B<BerkeleyDB>, provides an interface +The companion module to this one, L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB>, provides an interface to this locking functionality. If you are serious about locking -Berkeley DB databases, I strongly recommend using B<BerkeleyDB>. +Berkeley DB databases, I strongly recommend using L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB>. -If using B<BerkeleyDB> isn't an option, there are a number of modules +If using L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> isn't an option, there are a number of modules available on CPAN that can be used to implement locking. Each one implements locking differently and has different goals in mind. It is therefore worth knowing the difference, so that you can pick the right @@ -2298,6 +2298,12 @@ version 1.85 of Berkeley DB. I am sure there are bugs in the code. If you do find any, or can suggest any enhancements, I would welcome your comments. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/DB_File/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=DB_File>. + =head1 AVAILABILITY B<DB_File> comes with the standard Perl source distribution. Look in @@ -2307,11 +2313,11 @@ date, so the most recent version can always be found on CPAN (see L<perlmodlib/CPAN> for details), in the directory F<modules/by-module/DB_File>. -This version of B<DB_File> will work with either version 1.x, 2.x or -3.x of Berkeley DB, but is limited to the functionality provided by -version 1. +B<DB_File> is designed to work with any version of Berkeley DB, but is limited to the functionality provided by +version 1. If you want to make use of the new features available in Berkeley DB +2.x, or greater, use the Perl module L<BerkeleyDB|https://metacpan.org/pod/BerkeleyDB> instead. -The official web site for Berkeley DB is F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>. +The official web site for Berkeley DB is L<http://www.oracle.com/technology/products/berkeley-db/db/index.html>. All versions of Berkeley DB are available there. Alternatively, Berkeley DB version 1 is available at your nearest CPAN @@ -2319,7 +2325,7 @@ archive in F<src/misc/db.1.85.tar.gz>. =head1 COPYRIGHT -Copyright (c) 1995-2016 Paul Marquess. All rights reserved. This program +Copyright (c) 1995-2020 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -2328,7 +2334,7 @@ makes use of, namely Berkeley DB, is not. Berkeley DB has its own copyright and its own license. Please take the time to read it. Here are a few words taken from the Berkeley DB FAQ (at -F<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license: +L<http://www.oracle.com/technology/products/berkeley-db/db/index.html>) regarding the license: Do I have to license DB to use it in Perl scripts? diff --git a/gnu/usr.bin/perl/cpan/DB_File/DB_File.xs b/gnu/usr.bin/perl/cpan/DB_File/DB_File.xs index 6e6e154ffd4..ab95369b25f 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/DB_File.xs +++ b/gnu/usr.bin/perl/cpan/DB_File/DB_File.xs @@ -1,123 +1,123 @@ -/* +/* - DB_File.xs -- Perl 5 interface to Berkeley DB + DB_File.xs -- Perl 5 interface to Berkeley DB Written by Paul Marquess <pmqs@cpan.org> All comments/suggestions/problems are welcome - Copyright (c) 1995-2018 Paul Marquess. All rights reserved. + Copyright (c) 1995-2020 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Changes: - 0.1 - Initial Release - 0.2 - No longer bombs out if dbopen returns an error. - 0.3 - Added some support for multiple btree compares - 1.0 - Complete support for multiple callbacks added. - Fixed a problem with pushing a value onto an empty list. - 1.01 - Fixed a SunOS core dump problem. - The return value from TIEHASH wasn't set to NULL when - dbopen returned an error. - 1.02 - Use ALIAS to define TIEARRAY. - Removed some redundant commented code. - Merged OS2 code into the main distribution. - Allow negative subscripts with RECNO interface. - Changed the default flags to O_CREAT|O_RDWR - 1.03 - Added EXISTS - 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by - Dave Hammen, hammen@gothamcity.jsc.nasa.gov - 1.05 - Added logic to allow prefix & hash types to be specified via - Makefile.PL - 1.06 - Minor namespace cleanup: Localized PrintBtree. - 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". - 1.08 - No change to DB_File.xs - 1.09 - Default mode for dbopen changed to 0666 - 1.10 - Fixed fd method so that it still returns -1 for - in-memory files when db 1.86 is used. - 1.11 - No change to DB_File.xs - 1.12 - No change to DB_File.xs - 1.13 - Tidied up a few casts. - 1.14 - Made it illegal to tie an associative array to a RECNO - database and an ordinary array to a HASH or BTREE database. - 1.50 - Make work with both DB 1.x or DB 2.x - 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent - 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of - undefined value" warning with db_get and db_seq. - 1.53 - Added DB_RENUMBER to flags for recno. - 1.54 - Fixed bug in the fd method - 1.55 - Fix for AIX from Jarkko Hietaniemi - 1.56 - No change to DB_File.xs - 1.57 - added the #undef op to allow building with Threads support. - 1.58 - Fixed a problem with the use of sv_setpvn. When the - size is specified as 0, it does a strlen on the data. - This was ok for DB 1.x, but isn't for DB 2.x. - 1.59 - No change to DB_File.xs - 1.60 - Some code tidy up - 1.61 - added flagSet macro for DB 2.5.x - fixed typo in O_RDONLY test. - 1.62 - No change to DB_File.xs - 1.63 - Fix to alllow DB 2.6.x to build. - 1.64 - Tidied up the 1.x to 2.x flags mapping code. - Added a patch from Mark Kettenis <kettenis@wins.uva.nl> - to fix a flag mapping problem with O_RDONLY on the Hurd - 1.65 - Fixed a bug in the PUSH logic. - Added BOOT check that using 2.3.4 or greater - 1.66 - Added DBM filter code - 1.67 - Backed off the use of newSVpvn. - Fixed DBM Filter code for Perl 5.004. - Fixed a small memory leak in the filter code. - 1.68 - fixed backward compatibility bug with R_IAFTER & R_IBEFORE - merged in the 5.005_58 changes - 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. - Fixed the R_SETCURSOR bug introduced in 1.68 - Added a new Perl variable $DB_File::db_ver - 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with - GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. - Added a BOOT check to test for equivalent versions of db.h & - libdb.a/so. - 1.71 - Support for Berkeley DB version 3. - Support for Berkeley DB 2/3's backward compatibility mode. - Rewrote push - 1.72 - No change to DB_File.xs - 1.73 - No change to DB_File.xs - 1.74 - A call to open needed parenthesised to stop it clashing - with a win32 macro. - Added Perl core patches 7703 & 7801. - 1.75 - Fixed Perl core patch 7703. - Added support to allow DB_File to be built with - Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb - needed to be changed. - 1.76 - No change to DB_File.xs - 1.77 - Tidied up a few types used in calling newSVpvn. - 1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included. - 1.79 - NEXTKEY ignores the input key. - Added lots of casts - 1.800 - Moved backward compatibility code into ppport.h. - Use the new constants code. - 1.801 - No change to DB_File.xs - 1.802 - No change to DB_File.xs - 1.803 - FETCH, STORE & DELETE don't map the flags parameter - into the equivalent Berkeley DB function anymore. - 1.804 - no change. - 1.805 - recursion detection added to the callbacks - Support for 4.1.X added. - Filter code can now cope with read-only $_ - 1.806 - recursion detection beefed up. - 1.807 - no change - 1.808 - leak fixed in ParseOpenInfo - 1.809 - no change - 1.810 - no change - 1.811 - no change - 1.812 - no change - 1.813 - no change - 1.814 - no change - 1.814 - C++ casting fixes + 0.1 - Initial Release + 0.2 - No longer bombs out if dbopen returns an error. + 0.3 - Added some support for multiple btree compares + 1.0 - Complete support for multiple callbacks added. + Fixed a problem with pushing a value onto an empty list. + 1.01 - Fixed a SunOS core dump problem. + The return value from TIEHASH wasn't set to NULL when + dbopen returned an error. + 1.02 - Use ALIAS to define TIEARRAY. + Removed some redundant commented code. + Merged OS2 code into the main distribution. + Allow negative subscripts with RECNO interface. + Changed the default flags to O_CREAT|O_RDWR + 1.03 - Added EXISTS + 1.04 - fixed a couple of bugs in hash_cb. Patches supplied by + Dave Hammen, hammen@gothamcity.jsc.nasa.gov + 1.05 - Added logic to allow prefix & hash types to be specified via + Makefile.PL + 1.06 - Minor namespace cleanup: Localized PrintBtree. + 1.07 - Fixed bug with RECNO, where bval wasn't defaulting to "\n". + 1.08 - No change to DB_File.xs + 1.09 - Default mode for dbopen changed to 0666 + 1.10 - Fixed fd method so that it still returns -1 for + in-memory files when db 1.86 is used. + 1.11 - No change to DB_File.xs + 1.12 - No change to DB_File.xs + 1.13 - Tidied up a few casts. + 1.14 - Made it illegal to tie an associative array to a RECNO + database and an ordinary array to a HASH or BTREE database. + 1.50 - Make work with both DB 1.x or DB 2.x + 1.51 - Fixed a bug in mapping 1.x O_RDONLY flag to 2.x DB_RDONLY equivalent + 1.52 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of + undefined value" warning with db_get and db_seq. + 1.53 - Added DB_RENUMBER to flags for recno. + 1.54 - Fixed bug in the fd method + 1.55 - Fix for AIX from Jarkko Hietaniemi + 1.56 - No change to DB_File.xs + 1.57 - added the #undef op to allow building with Threads support. + 1.58 - Fixed a problem with the use of sv_setpvn. When the + size is specified as 0, it does a strlen on the data. + This was ok for DB 1.x, but isn't for DB 2.x. + 1.59 - No change to DB_File.xs + 1.60 - Some code tidy up + 1.61 - added flagSet macro for DB 2.5.x + fixed typo in O_RDONLY test. + 1.62 - No change to DB_File.xs + 1.63 - Fix to alllow DB 2.6.x to build. + 1.64 - Tidied up the 1.x to 2.x flags mapping code. + Added a patch from Mark Kettenis <kettenis@wins.uva.nl> + to fix a flag mapping problem with O_RDONLY on the Hurd + 1.65 - Fixed a bug in the PUSH logic. + Added BOOT check that using 2.3.4 or greater + 1.66 - Added DBM filter code + 1.67 - Backed off the use of newSVpvn. + Fixed DBM Filter code for Perl 5.004. + Fixed a small memory leak in the filter code. + 1.68 - fixed backward compatibility bug with R_IAFTER & R_IBEFORE + merged in the 5.005_58 changes + 1.69 - fixed a bug in push -- DB_APPEND wasn't working properly. + Fixed the R_SETCURSOR bug introduced in 1.68 + Added a new Perl variable $DB_File::db_ver + 1.70 - Initialise $DB_File::db_ver and $DB_File::db_version with + GV_ADD|GV_ADDMULT -- bug spotted by Nick Ing-Simmons. + Added a BOOT check to test for equivalent versions of db.h & + libdb.a/so. + 1.71 - Support for Berkeley DB version 3. + Support for Berkeley DB 2/3's backward compatibility mode. + Rewrote push + 1.72 - No change to DB_File.xs + 1.73 - No change to DB_File.xs + 1.74 - A call to open needed parenthesised to stop it clashing + with a win32 macro. + Added Perl core patches 7703 & 7801. + 1.75 - Fixed Perl core patch 7703. + Added support to allow DB_File to be built with + Berkeley DB 3.2 -- btree_compare, btree_prefix and hash_cb + needed to be changed. + 1.76 - No change to DB_File.xs + 1.77 - Tidied up a few types used in calling newSVpvn. + 1.78 - Core patch 10335, 10372, 10534, 10549, 11051 included. + 1.79 - NEXTKEY ignores the input key. + Added lots of casts + 1.800 - Moved backward compatibility code into ppport.h. + Use the new constants code. + 1.801 - No change to DB_File.xs + 1.802 - No change to DB_File.xs + 1.803 - FETCH, STORE & DELETE don't map the flags parameter + into the equivalent Berkeley DB function anymore. + 1.804 - no change. + 1.805 - recursion detection added to the callbacks + Support for 4.1.X added. + Filter code can now cope with read-only $_ + 1.806 - recursion detection beefed up. + 1.807 - no change + 1.808 - leak fixed in ParseOpenInfo + 1.809 - no change + 1.810 - no change + 1.811 - no change + 1.812 - no change + 1.813 - no change + 1.814 - no change + 1.814 - C++ casting fixes */ #define PERL_NO_GET_CONTEXT -#include "EXTERN.h" +#include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -178,10 +178,10 @@ int DB_File___unused() { return 0; } /* Ditto for dXSARGS. */ # undef dXSARGS -# define dXSARGS \ - dSP; dMARK; \ - I32 ax = mark - PL_stack_base + 1; \ - I32 items = sp - mark +# define dXSARGS \ + dSP; dMARK; \ + I32 ax = mark - PL_stack_base + 1; \ + I32 items = sp - mark # endif @@ -191,7 +191,7 @@ int DB_File___unused() { return 0; } #endif /* Perl >= 5.7 */ -#include <fcntl.h> +#include <fcntl.h> /* #define TRACE */ @@ -202,7 +202,7 @@ int DB_File___unused() { return 0; } #endif -#define DBT_clear(x) Zero(&x, 1, DBT) ; +#define DBT_clear(x) Zero(&x, 1, DBT) ; #ifdef DB_VERSION_MAJOR @@ -226,7 +226,7 @@ int DB_File___unused() { return 0; } # define AT_LEAST_DB_4_3 #endif -#if DB_VERSION_MAJOR >= 6 +#if DB_VERSION_MAJOR >= 6 # define AT_LEAST_DB_6_0 #endif @@ -239,23 +239,23 @@ int DB_File___unused() { return 0; } #ifdef DB_Prefix_t # undef DB_Prefix_t #endif -#define DB_Prefix_t size_t +#define DB_Prefix_t size_t #ifdef DB_Hash_t # undef DB_Hash_t #endif -#define DB_Hash_t u_int32_t +#define DB_Hash_t u_int32_t /* DBTYPE stays the same */ /* HASHINFO, RECNOINFO and BTREEINFO map to DB_INFO */ #if DB_VERSION_MAJOR == 2 - typedef DB_INFO INFO ; + typedef DB_INFO INFO ; #else /* DB_VERSION_MAJOR > 2 */ -# define DB_FIXEDLEN (0x8000) +# define DB_FIXEDLEN (0x8000) #endif /* DB_VERSION_MAJOR == 2 */ -/* version 2 has db_recno_t in place of recno_t */ -typedef db_recno_t recno_t; +/* version 2 has db_recno_t in place of recno_t */ +typedef db_recno_t recno_t; #define R_CURSOR DB_SET_RANGE @@ -268,53 +268,53 @@ typedef db_recno_t recno_t; #define R_PREV DB_PREV #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -# define R_SETCURSOR 0x800000 +# define R_SETCURSOR 0x800000 #else -# define R_SETCURSOR (DB_OPFLAGS_MASK) +# define R_SETCURSOR (DB_OPFLAGS_MASK) #endif #define R_RECNOSYNC 0 -#define R_FIXEDLEN DB_FIXEDLEN -#define R_DUP DB_DUP - - -#define db_HA_hash h_hash -#define db_HA_ffactor h_ffactor -#define db_HA_nelem h_nelem -#define db_HA_bsize db_pagesize -#define db_HA_cachesize db_cachesize -#define db_HA_lorder db_lorder - -#define db_BT_compare bt_compare -#define db_BT_prefix bt_prefix -#define db_BT_flags flags -#define db_BT_psize db_pagesize -#define db_BT_cachesize db_cachesize -#define db_BT_lorder db_lorder +#define R_FIXEDLEN DB_FIXEDLEN +#define R_DUP DB_DUP + + +#define db_HA_hash h_hash +#define db_HA_ffactor h_ffactor +#define db_HA_nelem h_nelem +#define db_HA_bsize db_pagesize +#define db_HA_cachesize db_cachesize +#define db_HA_lorder db_lorder + +#define db_BT_compare bt_compare +#define db_BT_prefix bt_prefix +#define db_BT_flags flags +#define db_BT_psize db_pagesize +#define db_BT_cachesize db_cachesize +#define db_BT_lorder db_lorder #define db_BT_maxkeypage #define db_BT_minkeypage -#define db_RE_reclen re_len -#define db_RE_flags flags -#define db_RE_bval re_pad -#define db_RE_bfname re_source -#define db_RE_psize db_pagesize -#define db_RE_cachesize db_cachesize -#define db_RE_lorder db_lorder +#define db_RE_reclen re_len +#define db_RE_flags flags +#define db_RE_bval re_pad +#define db_RE_bfname re_source +#define db_RE_psize db_pagesize +#define db_RE_cachesize db_cachesize +#define db_RE_lorder db_lorder -#define TXN NULL, +#define TXN NULL, -#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) +#define do_SEQ(db, key, value, flag) (db->cursor->c_get)(db->cursor, &key, &value, flag) -#define DBT_flags(x) x.flags = 0 -#define DB_flags(x, v) x |= v +#define DBT_flags(x) x.flags = 0 +#define DB_flags(x, v) x |= v #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 5 -# define flagSet(flags, bitmask) ((flags) & (bitmask)) +# define flagSet(flags, bitmask) ((flags) & (bitmask)) #else -# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (u_int)(bitmask)) +# define flagSet(flags, bitmask) (((flags) & DB_OPFLAGS_MASK) == (u_int)(bitmask)) #endif #else /* db version 1.x */ @@ -323,55 +323,55 @@ typedef db_recno_t recno_t; #define BERKELEY_DB_1_OR_2 typedef union INFO { - HASHINFO hash ; - RECNOINFO recno ; - BTREEINFO btree ; + HASHINFO hash ; + RECNOINFO recno ; + BTREEINFO btree ; } INFO ; -#ifdef mDB_Prefix_t +#ifdef mDB_Prefix_t # ifdef DB_Prefix_t # undef DB_Prefix_t # endif -# define DB_Prefix_t mDB_Prefix_t +# define DB_Prefix_t mDB_Prefix_t #endif #ifdef mDB_Hash_t # ifdef DB_Hash_t # undef DB_Hash_t # endif -# define DB_Hash_t mDB_Hash_t -#endif - -#define db_HA_hash hash.hash -#define db_HA_ffactor hash.ffactor -#define db_HA_nelem hash.nelem -#define db_HA_bsize hash.bsize -#define db_HA_cachesize hash.cachesize -#define db_HA_lorder hash.lorder - -#define db_BT_compare btree.compare -#define db_BT_prefix btree.prefix -#define db_BT_flags btree.flags -#define db_BT_psize btree.psize -#define db_BT_cachesize btree.cachesize -#define db_BT_lorder btree.lorder +# define DB_Hash_t mDB_Hash_t +#endif + +#define db_HA_hash hash.hash +#define db_HA_ffactor hash.ffactor +#define db_HA_nelem hash.nelem +#define db_HA_bsize hash.bsize +#define db_HA_cachesize hash.cachesize +#define db_HA_lorder hash.lorder + +#define db_BT_compare btree.compare +#define db_BT_prefix btree.prefix +#define db_BT_flags btree.flags +#define db_BT_psize btree.psize +#define db_BT_cachesize btree.cachesize +#define db_BT_lorder btree.lorder #define db_BT_maxkeypage btree.maxkeypage #define db_BT_minkeypage btree.minkeypage -#define db_RE_reclen recno.reclen -#define db_RE_flags recno.flags -#define db_RE_bval recno.bval -#define db_RE_bfname recno.bfname -#define db_RE_psize recno.psize -#define db_RE_cachesize recno.cachesize -#define db_RE_lorder recno.lorder +#define db_RE_reclen recno.reclen +#define db_RE_flags recno.flags +#define db_RE_bval recno.bval +#define db_RE_bfname recno.bfname +#define db_RE_psize recno.psize +#define db_RE_cachesize recno.cachesize +#define db_RE_lorder recno.lorder -#define TXN +#define TXN -#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) -#define DBT_flags(x) -#define DB_flags(x, v) +#define do_SEQ(db, key, value, flag) (db->dbp->seq)(db->dbp, &key, &value, flag) +#define DBT_flags(x) +#define DB_flags(x, v) #define flagSet(flags, bitmask) ((flags) & (bitmask)) #endif /* db version 1 */ @@ -387,16 +387,16 @@ typedef union INFO { #ifdef DB_VERSION_MAJOR #define db_DESTROY(db) (!db->aborted && ( db->cursor->c_close(db->cursor),\ - (db->dbp->close)(db->dbp, 0) )) -#define db_close(db) ((db->dbp)->close)(db->dbp, 0) -#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ - ? ((db->cursor)->c_del)(db->cursor, 0) \ - : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) + (db->dbp->close)(db->dbp, 0) )) +#define db_close(db) ((db->dbp)->close)(db->dbp, 0) +#define db_del(db, key, flags) (flagSet(flags, R_CURSOR) \ + ? ((db->cursor)->c_del)(db->cursor, 0) \ + : ((db->dbp)->del)(db->dbp, NULL, &key, flags) ) #else /* ! DB_VERSION_MAJOR */ #define db_DESTROY(db) (!db->aborted && ((db->dbp)->close)(db->dbp)) -#define db_close(db) ((db->dbp)->close)(db->dbp) +#define db_close(db) ((db->dbp)->close)(db->dbp) #define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags) #define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags) @@ -406,61 +406,77 @@ typedef union INFO { #define db_seq(db, key, value, flags) do_SEQ(db, key, value, flags) typedef struct { - DBTYPE type ; - DB * dbp ; - SV * compare ; - bool in_compare ; - SV * prefix ; - bool in_prefix ; - SV * hash ; - bool in_hash ; - bool aborted ; - int in_memory ; + DBTYPE type ; + DB * dbp ; + SV * compare ; + bool in_compare ; + SV * prefix ; + bool in_prefix ; + SV * hash ; + bool in_hash ; + bool aborted ; + int in_memory ; #ifdef BERKELEY_DB_1_OR_2 - INFO info ; -#endif + INFO info ; +#endif #ifdef DB_VERSION_MAJOR - DBC * cursor ; + DBC * cursor ; #endif - SV * filter_fetch_key ; - SV * filter_store_key ; - SV * filter_fetch_value ; - SV * filter_store_value ; - int filtering ; + SV * filter_fetch_key ; + SV * filter_store_key ; + SV * filter_fetch_value ; + SV * filter_store_value ; + int filtering ; - } DB_File_type; + } DB_File_type; typedef DB_File_type * DB_File ; typedef DBT DBTKEY ; #define my_sv_setpvn(sv, d, s) sv_setpvn(sv, (s ? d : (const char *)""), s) -#define OutputValue(arg, name) \ - { if (RETVAL == 0) { \ - SvGETMAGIC(arg) ; \ - my_sv_setpvn(arg, (const char *)name.data, name.size) ; \ - TAINT; \ - SvTAINTED_on(arg); \ - SvUTF8_off(arg); \ - DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ - } \ - } - -#define OutputKey(arg, name) \ - { if (RETVAL == 0) \ - { \ - SvGETMAGIC(arg) ; \ - if (db->type != DB_RECNO) { \ - my_sv_setpvn(arg, (const char *)name.data, name.size); \ - } \ - else \ - sv_setiv(arg, (I32)*(I32*)name.data - 1); \ - TAINT; \ - SvTAINTED_on(arg); \ - SvUTF8_off(arg); \ - DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ - } \ - } +#define OutputValue(arg, name) \ + { if (RETVAL == 0) { \ + SvGETMAGIC(arg) ; \ + my_sv_setpvn(arg, (const char *)name.data, name.size) ; \ + TAINT; \ + SvTAINTED_on(arg); \ + SvUTF8_off(arg); \ + DBM_ckFilter(arg, filter_fetch_value,"filter_fetch_value") ; \ + } \ + } + +#define OutputKey(arg, name) \ + { if (RETVAL == 0) \ + { \ + SvGETMAGIC(arg) ; \ + if (db->type != DB_RECNO) { \ + my_sv_setpvn(arg, (const char *)name.data, name.size); \ + } \ + else \ + sv_setiv(arg, (I32)*(I32*)name.data - 1); \ + TAINT; \ + SvTAINTED_on(arg); \ + SvUTF8_off(arg); \ + DBM_ckFilter(arg, filter_fetch_key,"filter_fetch_key") ; \ + } \ + } + +/* Macro err_close only for use in croak_and_free */ +#ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ +# define err_close(r) +#else +# define err_close(r) db_close(r) +#endif + +/* Macro croak_and_free only for use in ParseOpenInfo */ +#define croak_and_free(x) \ + do \ + { \ + if (RETVAL->dbp) err_close(RETVAL) ; \ + Safefree(RETVAL); \ + croak(x); \ + } while (0) #define my_SvUV32(sv) ((u_int32_t)SvUV(sv)) @@ -473,18 +489,18 @@ extern void __getBerkeleyDBInfo(void); #define MY_CXT_KEY "DB_File::_guts" XS_VERSION typedef struct { - recno_t x_Value; - recno_t x_zero; - DB_File x_CurrentDB; - DBTKEY x_empty; + recno_t x_Value; + recno_t x_zero; + DB_File x_CurrentDB; + DBTKEY x_empty; } my_cxt_t; START_MY_CXT -#define Value (MY_CXT.x_Value) -#define zero (MY_CXT.x_zero) -#define CurrentDB (MY_CXT.x_CurrentDB) -#define empty (MY_CXT.x_empty) +#define Value (MY_CXT.x_Value) +#define zero (MY_CXT.x_zero) +#define CurrentDB (MY_CXT.x_CurrentDB) +#define empty (MY_CXT.x_empty) #define ERR_BUFF "DB_File::Error" @@ -495,52 +511,51 @@ static int db_put(DB_File db, DBTKEY key, DBT value, u_int flags) #else db_put(db, key, value, flags) -DB_File db ; -DBTKEY key ; -DBT value ; -u_int flags ; +DB_File db ; +DBTKEY key ; +DBT value ; +u_int flags ; #endif { int status ; if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) { DBC * temp_cursor ; - DBT l_key, l_value; - + DBT l_key, l_value; + #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor) != 0) #else if (((db->dbp)->cursor)(db->dbp, NULL, &temp_cursor, 0) != 0) #endif - return (-1) ; + return (-1) ; + + memset(&l_key, 0, sizeof(l_key)); + l_key.data = key.data; + l_key.size = key.size; + memset(&l_value, 0, sizeof(l_value)); + l_value.data = value.data; + l_value.size = value.size; - memset(&l_key, 0, sizeof(l_key)); - l_key.data = key.data; - l_key.size = key.size; - memset(&l_value, 0, sizeof(l_value)); - l_value.data = value.data; - l_value.size = value.size; + if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { + (void)temp_cursor->c_close(temp_cursor); + return (-1); + } - if ( temp_cursor->c_get(temp_cursor, &l_key, &l_value, DB_SET) != 0) { - (void)temp_cursor->c_close(temp_cursor); - return (-1); - } + status = temp_cursor->c_put(temp_cursor, &key, &value, flags); + (void)temp_cursor->c_close(temp_cursor); - status = temp_cursor->c_put(temp_cursor, &key, &value, flags); - (void)temp_cursor->c_close(temp_cursor); - return (status) ; - } - - + } + + if (flagSet(flags, R_CURSOR)) { - return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); + return ((db->cursor)->c_put)(db->cursor, &key, &value, DB_CURRENT); } if (flagSet(flags, R_SETCURSOR)) { - if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) - return -1 ; + if ((db->dbp)->put(db->dbp, NULL, &key, &value, 0) != 0) + return -1 ; return ((db->cursor)->c_get)(db->cursor, &key, &value, DB_SET_RANGE); - } return ((db->dbp)->put)(db->dbp, NULL, &key, &value, flags) ; @@ -576,7 +591,7 @@ size_t* locp; btree_compare(DB * db, const DBT *key1, const DBT *key2) #else btree_compare(db, key1, key2) -DB * db ; +DB * db ; const DBT * key1 ; const DBT * key2 ; #endif /* CAN_PROTOTYPE */ @@ -597,13 +612,13 @@ const DBT * key2 ; { #ifdef dTHX dTHX; -#endif +#endif dSP ; dMY_CXT ; void * data1, * data2 ; int retval ; int count ; - + #ifdef AT_LEAST_DB_3_2 PERL_UNUSED_ARG(db); #endif @@ -620,15 +635,15 @@ const DBT * key2 ; data2 = (char *) key2->data ; #ifndef newSVpvn - /* As newSVpv will assume that the data pointer is a null terminated C - string if the size parameter is 0, make sure that data points to an + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an empty string if the length is 0 */ if (key1->size == 0) - data1 = "" ; + data1 = "" ; if (key2->size == 0) data2 = "" ; -#endif +#endif ENTER ; SAVETMPS; @@ -643,7 +658,7 @@ const DBT * key2 ; PUSHs(sv_2mortal(newSVpvn((const char*)data2,key2->size))); PUTBACK ; - count = perl_call_sv(CurrentDB->compare, G_SCALAR); + count = perl_call_sv(CurrentDB->compare, G_SCALAR); SPAGAIN ; @@ -688,13 +703,13 @@ const DBT * key2 ; { #ifdef dTHX dTHX; -#endif +#endif dSP ; dMY_CXT ; char * data1, * data2 ; int retval ; int count ; - + #ifdef AT_LEAST_DB_3_2 PERL_UNUSED_ARG(db); #endif @@ -708,15 +723,15 @@ const DBT * key2 ; data2 = (char *) key2->data ; #ifndef newSVpvn - /* As newSVpv will assume that the data pointer is a null terminated C - string if the size parameter is 0, make sure that data points to an + /* As newSVpv will assume that the data pointer is a null terminated C + string if the size parameter is 0, make sure that data points to an empty string if the length is 0 */ if (key1->size == 0) data1 = "" ; if (key2->size == 0) data2 = "" ; -#endif +#endif ENTER ; SAVETMPS; @@ -731,7 +746,7 @@ const DBT * key2 ; PUSHs(sv_2mortal(newSVpvn(data2,key2->size))); PUTBACK ; - count = perl_call_sv(CurrentDB->prefix, G_SCALAR); + count = perl_call_sv(CurrentDB->prefix, G_SCALAR); SPAGAIN ; @@ -739,9 +754,9 @@ const DBT * key2 ; tidyUp(CurrentDB); croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ; } - + retval = POPi ; - + PUTBACK ; FREETMPS ; LEAVE ; @@ -782,7 +797,7 @@ HASH_CB_SIZE_TYPE size ; { #ifdef dTHX dTHX; -#endif +#endif dSP ; dMY_CXT; int retval = 0; @@ -800,7 +815,7 @@ HASH_CB_SIZE_TYPE size ; #ifndef newSVpvn if (size == 0) data = "" ; -#endif +#endif /* DGH - Next two lines added to fix corrupted stack problem */ ENTER ; @@ -816,7 +831,7 @@ HASH_CB_SIZE_TYPE size ; XPUSHs(sv_2mortal(newSVpvn((char*)data,size))); PUTBACK ; - count = perl_call_sv(CurrentDB->hash, G_SCALAR); + count = perl_call_sv(CurrentDB->hash, G_SCALAR); SPAGAIN ; @@ -845,7 +860,7 @@ db_errcall_cb(const char * db_errpfx, char * buffer) { #ifdef dTHX dTHX; -#endif +#endif SV * sv = perl_get_sv(ERR_BUFF, FALSE) ; #ifdef AT_LEAST_DB_4_3 PERL_UNUSED_ARG(dbenv); @@ -856,7 +871,7 @@ db_errcall_cb(const char * db_errpfx, char * buffer) else sv_setpv(sv, buffer) ; } -} +} #endif #if defined(TRACE) && defined(BERKELEY_DB_1_OR_2) @@ -870,8 +885,8 @@ INFO * hash ; #endif { printf ("HASH Info\n") ; - printf (" hash = %s\n", - (hash->db_HA_hash != NULL ? "redefined" : "default")) ; + printf (" hash = %s\n", + (hash->db_HA_hash != NULL ? "redefined" : "default")) ; printf (" bsize = %d\n", hash->db_HA_bsize) ; printf (" ffactor = %d\n", hash->db_HA_ffactor) ; printf (" nelem = %d\n", hash->db_HA_nelem) ; @@ -907,10 +922,10 @@ INFO * btree ; #endif { printf ("BTREE Info\n") ; - printf (" compare = %s\n", - (btree->db_BT_compare ? "redefined" : "default")) ; - printf (" prefix = %s\n", - (btree->db_BT_prefix ? "redefined" : "default")) ; + printf (" compare = %s\n", + (btree->db_BT_compare ? "redefined" : "default")) ; + printf (" prefix = %s\n", + (btree->db_BT_prefix ? "redefined" : "default")) ; printf (" flags = %d\n", btree->db_BT_flags) ; printf (" cachesize = %d\n", btree->db_BT_cachesize) ; printf (" psize = %d\n", btree->db_BT_psize) ; @@ -938,9 +953,9 @@ GetArrayLength(db) DB_File db ; #endif { - DBT key ; - DBT value ; - int RETVAL ; + DBT key ; + DBT value ; + int RETVAL ; DBT_clear(key) ; DBT_clear(value) ; @@ -963,16 +978,16 @@ I32 value ; #endif { if (value < 0) { - /* Get the length of the array */ - I32 length = GetArrayLength(aTHX_ db) ; + /* Get the length of the array */ + I32 length = GetArrayLength(aTHX_ db) ; - /* check for attempt to write before start of array */ - if (length + value + 1 <= 0) { + /* check for attempt to write before start of array */ + if (length + value + 1 <= 0) { tidyUp(db); - croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; - } + croak("Modification of non-creatable array value attempted, subscript %ld", (long)value) ; + } - value = length + value + 1 ; + value = length + value + 1 ; } else ++ value ; @@ -996,29 +1011,29 @@ SV * sv ; #ifdef BERKELEY_DB_1_OR_2 /* Berkeley DB Version 1 or 2 */ - SV ** svp; - HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; - void * openinfo = NULL ; - INFO * info = &RETVAL->info ; - STRLEN n_a; + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + void * openinfo = NULL ; + INFO * info = &RETVAL->info ; + STRLEN n_a; dMY_CXT; -#ifdef TRACE - printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n", - name, flags, mode, sv == NULL) ; +#ifdef TRACE + printf("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n", + name, flags, mode, sv == NULL) ; #endif Zero(RETVAL, 1, DB_File_type) ; /* Default to HASH */ RETVAL->filtering = 0 ; - RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_key = RETVAL->filter_store_key = RETVAL->filter_fetch_value = RETVAL->filter_store_value = RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; /* DGH - Next line added to avoid SEGV on existing hash DB */ - CurrentDB = RETVAL; + CurrentDB = RETVAL; /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ RETVAL->in_memory = (name == NULL) ; @@ -1026,63 +1041,63 @@ SV * sv ; if (sv) { if (! SvROK(sv) ) - croak ("type parameter is not a reference") ; + croak_and_free("type parameter is not a reference") ; svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; if (svp && SvOK(*svp)) action = (HV*) SvRV(*svp) ; - else - croak("internal error") ; + else + croak_and_free("internal error") ; if (sv_isa(sv, "DB_File::HASHINFO")) { - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_HASH database") ; + if (!isHASH) + croak_and_free("DB_File can only tie an associative array to a DB_HASH database") ; RETVAL->type = DB_HASH ; openinfo = (void*)info ; - - svp = hv_fetch(action, "hash", 4, FALSE); + + svp = hv_fetch(action, "hash", 4, FALSE); if (svp && SvOK(*svp)) { info->db_HA_hash = hash_cb ; - RETVAL->hash = newSVsv(*svp) ; + RETVAL->hash = newSVsv(*svp) ; } else - info->db_HA_hash = NULL ; + info->db_HA_hash = NULL ; - svp = hv_fetch(action, "ffactor", 7, FALSE); - info->db_HA_ffactor = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "nelem", 5, FALSE); - info->db_HA_nelem = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "bsize", 5, FALSE); - info->db_HA_bsize = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "cachesize", 9, FALSE); - info->db_HA_cachesize = svp ? SvIV(*svp) : 0; - - svp = hv_fetch(action, "lorder", 6, FALSE); - info->db_HA_lorder = svp ? SvIV(*svp) : 0; + svp = hv_fetch(action, "ffactor", 7, FALSE); + info->db_HA_ffactor = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "nelem", 5, FALSE); + info->db_HA_nelem = svp ? SvIV(*svp) : 0; - PrintHash(info) ; + svp = hv_fetch(action, "bsize", 5, FALSE); + info->db_HA_bsize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "cachesize", 9, FALSE); + info->db_HA_cachesize = svp ? SvIV(*svp) : 0; + + svp = hv_fetch(action, "lorder", 6, FALSE); + info->db_HA_lorder = svp ? SvIV(*svp) : 0; + + PrintHash(info) ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_BTREE database"); + if (!isHASH) + croak_and_free("DB_File can only tie an associative array to a DB_BTREE database"); RETVAL->type = DB_BTREE ; openinfo = (void*)info ; - + svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { info->db_BT_compare = btree_compare ; - RETVAL->compare = newSVsv(*svp) ; + RETVAL->compare = newSVsv(*svp) ; } else info->db_BT_compare = NULL ; @@ -1091,127 +1106,127 @@ SV * sv ; if (svp && SvOK(*svp)) { info->db_BT_prefix = btree_prefix ; - RETVAL->prefix = newSVsv(*svp) ; + RETVAL->prefix = newSVsv(*svp) ; } else info->db_BT_prefix = NULL ; svp = hv_fetch(action, "flags", 5, FALSE); info->db_BT_flags = svp ? SvIV(*svp) : 0; - + svp = hv_fetch(action, "cachesize", 9, FALSE); info->db_BT_cachesize = svp ? SvIV(*svp) : 0; - + #ifndef DB_VERSION_MAJOR svp = hv_fetch(action, "minkeypage", 10, FALSE); info->btree.minkeypage = svp ? SvIV(*svp) : 0; - + svp = hv_fetch(action, "maxkeypage", 10, FALSE); info->btree.maxkeypage = svp ? SvIV(*svp) : 0; #endif svp = hv_fetch(action, "psize", 5, FALSE); info->db_BT_psize = svp ? SvIV(*svp) : 0; - + svp = hv_fetch(action, "lorder", 6, FALSE); info->db_BT_lorder = svp ? SvIV(*svp) : 0; PrintBtree(info) ; - + } else if (sv_isa(sv, "DB_File::RECNOINFO")) { - if (isHASH) - croak("DB_File can only tie an array to a DB_RECNO database"); + if (isHASH) + croak_and_free("DB_File can only tie an array to a DB_RECNO database"); RETVAL->type = DB_RECNO ; openinfo = (void *)info ; - info->db_RE_flags = 0 ; + info->db_RE_flags = 0 ; svp = hv_fetch(action, "flags", 5, FALSE); info->db_RE_flags = (u_long) (svp ? SvIV(*svp) : 0); - + svp = hv_fetch(action, "reclen", 6, FALSE); info->db_RE_reclen = (size_t) (svp ? SvIV(*svp) : 0); - + svp = hv_fetch(action, "cachesize", 9, FALSE); info->db_RE_cachesize = (u_int) (svp ? SvIV(*svp) : 0); - + svp = hv_fetch(action, "psize", 5, FALSE); info->db_RE_psize = (u_int) (svp ? SvIV(*svp) : 0); - + svp = hv_fetch(action, "lorder", 6, FALSE); info->db_RE_lorder = (int) (svp ? SvIV(*svp) : 0); #ifdef DB_VERSION_MAJOR - info->re_source = name ; - name = NULL ; + info->re_source = name ; + name = NULL ; #endif - svp = hv_fetch(action, "bfname", 6, FALSE); + svp = hv_fetch(action, "bfname", 6, FALSE); if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,n_a) ; + char * ptr = SvPV(*svp,n_a) ; #ifdef DB_VERSION_MAJOR - name = (char*) n_a ? ptr : NULL ; + name = (char*) n_a ? ptr : NULL ; #else info->db_RE_bfname = (char*) (n_a ? ptr : NULL) ; #endif - } - else + } + else #ifdef DB_VERSION_MAJOR - name = NULL ; + name = NULL ; #else - info->db_RE_bfname = NULL ; + info->db_RE_bfname = NULL ; #endif - - svp = hv_fetch(action, "bval", 4, FALSE); + + svp = hv_fetch(action, "bval", 4, FALSE); #ifdef DB_VERSION_MAJOR if (svp && SvOK(*svp)) { - int value ; + int value ; if (SvPOK(*svp)) - value = (int)*SvPV(*svp, n_a) ; - else - value = SvIV(*svp) ; - - if (info->flags & DB_FIXEDLEN) { - info->re_pad = value ; - info->flags |= DB_PAD ; - } - else { - info->re_delim = value ; - info->flags |= DB_DELIMITER ; - } + value = (int)*SvPV(*svp, n_a) ; + else + value = SvIV(*svp) ; + + if (info->flags & DB_FIXEDLEN) { + info->re_pad = value ; + info->flags |= DB_PAD ; + } + else { + info->re_delim = value ; + info->flags |= DB_DELIMITER ; + } } #else if (svp && SvOK(*svp)) { if (SvPOK(*svp)) - info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; - else - info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; - DB_flags(info->flags, DB_DELIMITER) ; + info->db_RE_bval = (u_char)*SvPV(*svp, n_a) ; + else + info->db_RE_bval = (u_char)(unsigned long) SvIV(*svp) ; + DB_flags(info->flags, DB_DELIMITER) ; } else - { - if (info->db_RE_flags & R_FIXEDLEN) + { + if (info->db_RE_flags & R_FIXEDLEN) info->db_RE_bval = (u_char) ' ' ; - else + else info->db_RE_bval = (u_char) '\n' ; - DB_flags(info->flags, DB_DELIMITER) ; - } + DB_flags(info->flags, DB_DELIMITER) ; + } #endif #ifdef DB_RENUMBER - info->flags |= DB_RENUMBER ; + info->flags |= DB_RENUMBER ; #endif - + PrintRecno(info) ; } else - croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + croak_and_free("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); } @@ -1225,8 +1240,8 @@ SV * sv ; #ifdef DB_VERSION_MAJOR { - int Flags = 0 ; - int status ; + int Flags = 0 ; + int status ; /* Map 1.x flags to 2.x flags */ if ((flags & O_CREAT) == O_CREAT) @@ -1244,25 +1259,23 @@ SV * sv ; Flags |= DB_TRUNCATE ; #endif - status = db_open(name, RETVAL->type, Flags, mode, NULL, (DB_INFO*)openinfo, &RETVAL->dbp) ; + status = db_open(name, RETVAL->type, Flags, mode, NULL, (DB_INFO*)openinfo, &RETVAL->dbp) ; if (status == 0) #if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6 status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor) ; #else - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, - 0) ; + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, 0) ; #endif if (status) - RETVAL->dbp = NULL ; - + RETVAL->dbp = NULL ; } #else #if defined(DB_LIBRARY_COMPATIBILITY_API) && DB_VERSION_MAJOR > 2 - RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; -#else - RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; + RETVAL->dbp = __db185_open(name, flags, mode, RETVAL->type, openinfo) ; +#else + RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ; #endif /* DB_LIBRARY_COMPATIBILITY_API */ #endif @@ -1271,218 +1284,219 @@ SV * sv ; #else /* Berkeley DB Version > 2 */ - SV ** svp; - HV * action ; - DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; - DB * dbp ; - STRLEN n_a; - int status ; + SV ** svp; + HV * action ; + DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ; + DB * dbp ; + STRLEN n_a; + int status ; dMY_CXT; -/* printf("In ParseOpenInfo name=[%s] flags=[%d] mode = [%d]\n", name, flags, mode) ; */ + Trace(("In ParseOpenInfo name=[%s] flags=[%d] mode=[%d] SV NULL=[%d]\n",\ + name, flags, mode, sv == NULL)) ; Zero(RETVAL, 1, DB_File_type) ; /* Default to HASH */ RETVAL->filtering = 0 ; - RETVAL->filter_fetch_key = RETVAL->filter_store_key = + RETVAL->filter_fetch_key = RETVAL->filter_store_key = RETVAL->filter_fetch_value = RETVAL->filter_store_value = RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ; RETVAL->type = DB_HASH ; /* DGH - Next line added to avoid SEGV on existing hash DB */ - CurrentDB = RETVAL; + CurrentDB = RETVAL; /* fd for 1.86 hash in memory files doesn't return -1 like 1.85 */ RETVAL->in_memory = (name == NULL) ; status = db_create(&RETVAL->dbp, NULL,0) ; - /* printf("db_create returned %d %s\n", status, db_strerror(status)) ; */ + Trace(("db_create returned %d %s\n", status, db_strerror(status))) ; if (status) { - RETVAL->dbp = NULL ; + RETVAL->dbp = NULL ; return (RETVAL) ; - } + } dbp = RETVAL->dbp ; #ifdef WANT_ERROR - RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; + RETVAL->dbp->set_errcall(RETVAL->dbp, db_errcall_cb) ; #endif if (sv) { if (! SvROK(sv) ) - croak ("type parameter is not a reference") ; + croak_and_free("type parameter is not a reference") ; svp = hv_fetch( (HV*)SvRV(sv), "GOT", 3, FALSE) ; if (svp && SvOK(*svp)) action = (HV*) SvRV(*svp) ; - else - croak("internal error") ; + else + croak_and_free("internal error") ; if (sv_isa(sv, "DB_File::HASHINFO")) { - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_HASH database") ; + if (!isHASH) + croak_and_free("DB_File can only tie an associative array to a DB_HASH database") ; RETVAL->type = DB_HASH ; - - svp = hv_fetch(action, "hash", 4, FALSE); + + svp = hv_fetch(action, "hash", 4, FALSE); if (svp && SvOK(*svp)) { - (void)dbp->set_h_hash(dbp, hash_cb) ; - RETVAL->hash = newSVsv(*svp) ; + (void)dbp->set_h_hash(dbp, hash_cb) ; + RETVAL->hash = newSVsv(*svp) ; } svp = hv_fetch(action, "ffactor", 7, FALSE); - if (svp) - (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ; - + if (svp) + (void)dbp->set_h_ffactor(dbp, my_SvUV32(*svp)) ; + svp = hv_fetch(action, "nelem", 5, FALSE); - if (svp) + if (svp) (void)dbp->set_h_nelem(dbp, my_SvUV32(*svp)) ; - + svp = hv_fetch(action, "bsize", 5, FALSE); - if (svp) + if (svp) (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)); - + svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) + if (svp) (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; - + svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) + if (svp) (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; - PrintHash(info) ; + PrintHash(info) ; } else if (sv_isa(sv, "DB_File::BTREEINFO")) { - if (!isHASH) - croak("DB_File can only tie an associative array to a DB_BTREE database"); + if (!isHASH) + croak_and_free("DB_File can only tie an associative array to a DB_BTREE database"); RETVAL->type = DB_BTREE ; - + svp = hv_fetch(action, "compare", 7, FALSE); if (svp && SvOK(*svp)) { (void)dbp->set_bt_compare(dbp, btree_compare) ; - RETVAL->compare = newSVsv(*svp) ; + RETVAL->compare = newSVsv(*svp) ; } svp = hv_fetch(action, "prefix", 6, FALSE); if (svp && SvOK(*svp)) { (void)dbp->set_bt_prefix(dbp, btree_prefix) ; - RETVAL->prefix = newSVsv(*svp) ; + RETVAL->prefix = newSVsv(*svp) ; } svp = hv_fetch(action, "flags", 5, FALSE); - if (svp) - (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ; - + if (svp) + (void)dbp->set_flags(dbp, my_SvUV32(*svp)) ; + svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) + if (svp) (void)dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; - + svp = hv_fetch(action, "psize", 5, FALSE); - if (svp) + if (svp) (void)dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; - + svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) + if (svp) (void)dbp->set_lorder(dbp, (int)SvIV(*svp)) ; - PrintBtree(info) ; - + PrintBtree(info) ; + } else if (sv_isa(sv, "DB_File::RECNOINFO")) { - int fixed = FALSE ; + int fixed = FALSE ; - if (isHASH) - croak("DB_File can only tie an array to a DB_RECNO database"); + if (isHASH) + croak_and_free("DB_File can only tie an array to a DB_RECNO database"); RETVAL->type = DB_RECNO ; - svp = hv_fetch(action, "flags", 5, FALSE); - if (svp) { - int flags = SvIV(*svp) ; - /* remove FIXDLEN, if present */ - if (flags & DB_FIXEDLEN) { - fixed = TRUE ; - flags &= ~DB_FIXEDLEN ; - } - } + svp = hv_fetch(action, "flags", 5, FALSE); + if (svp) { + int flags = SvIV(*svp) ; + /* remove FIXDLEN, if present */ + if (flags & DB_FIXEDLEN) { + fixed = TRUE ; + flags &= ~DB_FIXEDLEN ; + } + } - svp = hv_fetch(action, "cachesize", 9, FALSE); - if (svp) { - status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; - } - - svp = hv_fetch(action, "psize", 5, FALSE); - if (svp) { - status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; - } - - svp = hv_fetch(action, "lorder", 6, FALSE); - if (svp) { - status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ; - } + svp = hv_fetch(action, "cachesize", 9, FALSE); + if (svp) { + status = dbp->set_cachesize(dbp, 0, my_SvUV32(*svp), 0) ; + } + + svp = hv_fetch(action, "psize", 5, FALSE); + if (svp) { + status = dbp->set_pagesize(dbp, my_SvUV32(*svp)) ; + } + + svp = hv_fetch(action, "lorder", 6, FALSE); + if (svp) { + status = dbp->set_lorder(dbp, (int)SvIV(*svp)) ; + } - svp = hv_fetch(action, "bval", 4, FALSE); + svp = hv_fetch(action, "bval", 4, FALSE); if (svp && SvOK(*svp)) { - int value ; + int value ; if (SvPOK(*svp)) - value = (int)*SvPV(*svp, n_a) ; - else - value = (int)SvIV(*svp) ; + value = (int)*SvPV(*svp, n_a) ; + else + value = (int)SvIV(*svp) ; - if (fixed) { - (void)dbp->set_re_pad(dbp, value) ; - } - else { - (void)dbp->set_re_delim(dbp, value) ; - } + if (fixed) { + (void)dbp->set_re_pad(dbp, value) ; + } + else { + (void)dbp->set_re_delim(dbp, value) ; + } } - if (fixed) { - svp = hv_fetch(action, "reclen", 6, FALSE); - if (svp) { - u_int32_t len = my_SvUV32(*svp) ; - (void)dbp->set_re_len(dbp, len) ; - } - } - - if (name != NULL) { - (void)dbp->set_re_source(dbp, name) ; - name = NULL ; - } - - svp = hv_fetch(action, "bfname", 6, FALSE); + if (fixed) { + svp = hv_fetch(action, "reclen", 6, FALSE); + if (svp) { + u_int32_t len = my_SvUV32(*svp) ; + (void)dbp->set_re_len(dbp, len) ; + } + } + + if (name != NULL) { + (void)dbp->set_re_source(dbp, name) ; + name = NULL ; + } + + svp = hv_fetch(action, "bfname", 6, FALSE); if (svp && SvOK(*svp)) { - char * ptr = SvPV(*svp,n_a) ; - name = (char*) n_a ? ptr : NULL ; - } - else - name = NULL ; - - - (void)dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ; - - if (flags){ - (void)dbp->set_flags(dbp, (u_int32_t)flags) ; - } + char * ptr = SvPV(*svp,n_a) ; + name = (char*) n_a ? ptr : NULL ; + } + else + name = NULL ; + + + (void)dbp->set_flags(dbp, (u_int32_t)DB_RENUMBER) ; + + if (flags){ + (void)dbp->set_flags(dbp, (u_int32_t)flags) ; + } PrintRecno(info) ; } else - croak("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); + croak_and_free("type is not of type DB_File::HASHINFO, DB_File::BTREEINFO or DB_File::RECNOINFO"); } { - u_int32_t Flags = 0 ; - int status ; + u_int32_t Flags = 0 ; + int status ; /* Map 1.x flags to 3.x flags */ if ((flags & O_CREAT) == O_CREAT) @@ -1507,27 +1521,25 @@ SV * sv ; #endif #ifdef AT_LEAST_DB_4_1 - status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, - Flags, mode) ; + status = (RETVAL->dbp->open)(RETVAL->dbp, NULL, name, NULL, RETVAL->type, + Flags, mode) ; #else - status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, - Flags, mode) ; + status = (RETVAL->dbp->open)(RETVAL->dbp, name, NULL, RETVAL->type, + Flags, mode) ; #endif - /* printf("open returned %d %s\n", status, db_strerror(status)) ; */ + Trace(("open returned %d %s\n", status, db_strerror(status))) ; if (status == 0) { - status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, - 0) ; - /* printf("cursor returned %d %s\n", status, db_strerror(status)) ; */ - } + status = (RETVAL->dbp->cursor)(RETVAL->dbp, NULL, &RETVAL->cursor, 0) ; + Trace(("cursor returned %d %s\n", status, db_strerror(status))) ; + } if (status) - { - db_close(RETVAL); /* close **dbp handle to prevent mem.leak */ - RETVAL->dbp = NULL ; - } - + { + db_close(RETVAL); /* close **dbp handle to prevent mem.leak */ + RETVAL->dbp = NULL ; + } } return (RETVAL) ; @@ -1537,9 +1549,9 @@ SV * sv ; } /* ParseOpenInfo */ -#include "constants.h" +#include "constants.h" -MODULE = DB_File PACKAGE = DB_File PREFIX = db_ +MODULE = DB_File PACKAGE = DB_File PREFIX = db_ INCLUDE: constants.xs @@ -1547,17 +1559,17 @@ BOOT: { #ifdef dTHX dTHX; -#endif +#endif #ifdef WANT_ERROR - SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; + SV * sv_err = perl_get_sv(ERR_BUFF, GV_ADD|GV_ADDMULTI) ; #endif MY_CXT_INIT; #ifdef WANT_ERROR PERL_UNUSED_VAR(sv_err); /* huh? we just retrieved it... */ #endif __getBerkeleyDBInfo() ; - - DBT_clear(empty) ; + + DBT_clear(empty) ; empty.data = &zero ; empty.size = sizeof(recno_t) ; } @@ -1566,161 +1578,162 @@ BOOT: DB_File db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH) - int isHASH - char * dbtype - int flags - int mode - CODE: - { - char * name = (char *) NULL ; - SV * sv = (SV *) NULL ; - STRLEN n_a; - - if (items >= 3 && SvOK(ST(2))) - name = (char*) SvPV(ST(2), n_a) ; - - if (items == 6) - sv = ST(5) ; - - RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; - Trace(("db_DoTie_ %p\n", RETVAL)); - if (RETVAL->dbp == NULL) { - Safefree(RETVAL); - RETVAL = NULL ; - } - } - OUTPUT: - RETVAL + int isHASH + char * dbtype + int flags + int mode + CODE: + { + char * name = (char *) NULL ; + SV * sv = (SV *) NULL ; + STRLEN n_a; + Trace(("In db_DoTie_\n")); + + if (items >= 3 && SvOK(ST(2))) + name = (char*) SvPV(ST(2), n_a) ; + + if (items == 6) + sv = ST(5) ; + + RETVAL = ParseOpenInfo(aTHX_ isHASH, name, flags, mode, sv) ; + Trace(("db_DoTie_ %p\n", RETVAL)); + if (RETVAL->dbp == NULL) { + Safefree(RETVAL); + RETVAL = NULL ; + } + } + OUTPUT: + RETVAL int db_DESTROY(db) - DB_File db - PREINIT: - dMY_CXT; - INIT: - CurrentDB = db ; - Trace(("DESTROY %p\n", db)); - CLEANUP: - Trace(("DESTROY %p done\n", db)); - if (db->hash) - SvREFCNT_dec(db->hash) ; - if (db->compare) - SvREFCNT_dec(db->compare) ; - if (db->prefix) - SvREFCNT_dec(db->prefix) ; - if (db->filter_fetch_key) - SvREFCNT_dec(db->filter_fetch_key) ; - if (db->filter_store_key) - SvREFCNT_dec(db->filter_store_key) ; - if (db->filter_fetch_value) - SvREFCNT_dec(db->filter_fetch_value) ; - if (db->filter_store_value) - SvREFCNT_dec(db->filter_store_value) ; - safefree(db) ; + DB_File db + PREINIT: + dMY_CXT; + INIT: + CurrentDB = db ; + Trace(("DESTROY %p\n", db)); + CLEANUP: + Trace(("DESTROY %p done\n", db)); + if (db->hash) + SvREFCNT_dec(db->hash) ; + if (db->compare) + SvREFCNT_dec(db->compare) ; + if (db->prefix) + SvREFCNT_dec(db->prefix) ; + if (db->filter_fetch_key) + SvREFCNT_dec(db->filter_fetch_key) ; + if (db->filter_store_key) + SvREFCNT_dec(db->filter_store_key) ; + if (db->filter_fetch_value) + SvREFCNT_dec(db->filter_fetch_value) ; + if (db->filter_store_value) + SvREFCNT_dec(db->filter_store_value) ; + safefree(db) ; #ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; + if (RETVAL > 0) + RETVAL = -1 ; #endif int db_DELETE(db, key, flags=0) - DB_File db - DBTKEY key - u_int flags - PREINIT: - dMY_CXT; - INIT: - (void)flags; - CurrentDB = db ; + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT; + INIT: + (void)flags; + CurrentDB = db ; int db_EXISTS(db, key) - DB_File db - DBTKEY key - PREINIT: - dMY_CXT; - CODE: - { - DBT value ; - - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; - } - OUTPUT: - RETVAL + DB_File db + DBTKEY key + PREINIT: + dMY_CXT; + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = (((db->dbp)->get)(db->dbp, TXN &key, &value, 0) == 0) ; + } + OUTPUT: + RETVAL void db_FETCH(db, key, flags=0) - DB_File db - DBTKEY key - u_int flags - PREINIT: - dMY_CXT ; - int RETVAL ; - CODE: - { - DBT value ; - - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = db_get(db, key, value, flags) ; - ST(0) = sv_newmortal(); - OutputValue(ST(0), value) - } + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBT value ; + + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = db_get(db, key, value, flags) ; + ST(0) = sv_newmortal(); + OutputValue(ST(0), value) + } int db_STORE(db, key, value, flags=0) - DB_File db - DBTKEY key - DBT value - u_int flags - PREINIT: - dMY_CXT; - INIT: - (void)flags; - CurrentDB = db ; + DB_File db + DBTKEY key + DBT value + u_int flags + PREINIT: + dMY_CXT; + INIT: + (void)flags; + CurrentDB = db ; void db_FIRSTKEY(db) - DB_File db - PREINIT: - dMY_CXT ; - int RETVAL ; - CODE: - { - DBTKEY key ; - DBT value ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = do_SEQ(db, key, value, R_FIRST) ; - ST(0) = sv_newmortal(); - OutputKey(ST(0), key) ; - } + DB_File db + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } void db_NEXTKEY(db, key) - DB_File db - DBTKEY key = NO_INIT - PREINIT: - dMY_CXT ; - int RETVAL ; - CODE: - { - DBT value ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - RETVAL = do_SEQ(db, key, value, R_NEXT) ; - ST(0) = sv_newmortal(); - OutputKey(ST(0), key) ; - } + DB_File db + DBTKEY key = NO_INIT + PREINIT: + dMY_CXT ; + int RETVAL ; + CODE: + { + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + RETVAL = do_SEQ(db, key, value, R_NEXT) ; + ST(0) = sv_newmortal(); + OutputKey(ST(0), key) ; + } # # These would be nice for RECNO @@ -1728,166 +1741,166 @@ db_NEXTKEY(db, key) int unshift(db, ...) - DB_File db - ALIAS: UNSHIFT = 1 - PREINIT: - dMY_CXT; - CODE: - { - DBTKEY key ; - DBT value ; - int i ; - int One ; - STRLEN n_a; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; + DB_File db + ALIAS: UNSHIFT = 1 + PREINIT: + dMY_CXT; + CODE: + { + DBTKEY key ; + DBT value ; + int i ; + int One ; + STRLEN n_a; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; #ifdef DB_VERSION_MAJOR - /* get the first value */ - RETVAL = do_SEQ(db, key, value, DB_FIRST) ; - RETVAL = 0 ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, DB_FIRST) ; + RETVAL = 0 ; #else - RETVAL = -1 ; -#endif - for (i = items-1 ; i > 0 ; --i) - { - DBM_ckFilter(ST(i), filter_store_value, "filter_store_value"); - value.data = SvPVbyte(ST(i), n_a) ; - value.size = n_a ; - One = 1 ; - key.data = &One ; - key.size = sizeof(int) ; + RETVAL = -1 ; +#endif + for (i = items-1 ; i > 0 ; --i) + { + DBM_ckFilter(ST(i), filter_store_value, "filter_store_value"); + value.data = SvPVbyte(ST(i), n_a) ; + value.size = n_a ; + One = 1 ; + key.data = &One ; + key.size = sizeof(int) ; #ifdef DB_VERSION_MAJOR - RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; + RETVAL = (db->cursor->c_put)(db->cursor, &key, &value, DB_BEFORE) ; #else - RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; + RETVAL = (db->dbp->put)(db->dbp, &key, &value, R_IBEFORE) ; #endif - if (RETVAL != 0) - break; - } - } - OUTPUT: - RETVAL + if (RETVAL != 0) + break; + } + } + OUTPUT: + RETVAL void pop(db) - DB_File db - PREINIT: - dMY_CXT; - ALIAS: POP = 1 - PREINIT: - I32 RETVAL; - CODE: - { - DBTKEY key ; - DBT value ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - - /* First get the final value */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; - ST(0) = sv_newmortal(); - /* Now delete it */ - if (RETVAL == 0) - { - /* the call to del will trash value, so take a copy now */ - OutputValue(ST(0), value) ; - RETVAL = db_del(db, key, R_CURSOR) ; - if (RETVAL != 0) - sv_setsv(ST(0), &PL_sv_undef); - } - } + DB_File db + PREINIT: + dMY_CXT; + ALIAS: POP = 1 + PREINIT: + I32 RETVAL; + CODE: + { + DBTKEY key ; + DBT value ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + + /* First get the final value */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv(ST(0), &PL_sv_undef); + } + } void shift(db) - DB_File db - PREINIT: - dMY_CXT; - ALIAS: SHIFT = 1 - PREINIT: - I32 RETVAL; - CODE: - { - DBT value ; - DBTKEY key ; - - DBT_clear(key) ; - DBT_clear(value) ; - CurrentDB = db ; - /* get the first value */ - RETVAL = do_SEQ(db, key, value, R_FIRST) ; - ST(0) = sv_newmortal(); - /* Now delete it */ - if (RETVAL == 0) - { - /* the call to del will trash value, so take a copy now */ - OutputValue(ST(0), value) ; - RETVAL = db_del(db, key, R_CURSOR) ; - if (RETVAL != 0) - sv_setsv (ST(0), &PL_sv_undef) ; - } - } + DB_File db + PREINIT: + dMY_CXT; + ALIAS: SHIFT = 1 + PREINIT: + I32 RETVAL; + CODE: + { + DBT value ; + DBTKEY key ; + + DBT_clear(key) ; + DBT_clear(value) ; + CurrentDB = db ; + /* get the first value */ + RETVAL = do_SEQ(db, key, value, R_FIRST) ; + ST(0) = sv_newmortal(); + /* Now delete it */ + if (RETVAL == 0) + { + /* the call to del will trash value, so take a copy now */ + OutputValue(ST(0), value) ; + RETVAL = db_del(db, key, R_CURSOR) ; + if (RETVAL != 0) + sv_setsv (ST(0), &PL_sv_undef) ; + } + } I32 push(db, ...) - DB_File db - PREINIT: - dMY_CXT; - ALIAS: PUSH = 1 - CODE: - { - DBTKEY key ; - DBT value ; - DB * Db = db->dbp ; - int i ; - STRLEN n_a; - int keyval ; - - DBT_flags(key) ; - DBT_flags(value) ; - CurrentDB = db ; - /* Set the Cursor to the Last element */ - RETVAL = do_SEQ(db, key, value, R_LAST) ; -#ifndef DB_VERSION_MAJOR - if (RETVAL >= 0) -#endif - { - if (RETVAL == 0) - keyval = *(int*)key.data ; - else - keyval = 0 ; - for (i = 1 ; i < items ; ++i) - { - DBM_ckFilter(ST(i), filter_store_value, "filter_store_value"); - value.data = SvPVbyte(ST(i), n_a) ; - value.size = n_a ; - ++ keyval ; - key.data = &keyval ; - key.size = sizeof(int) ; - RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; - if (RETVAL != 0) - break; - } - } - } - OUTPUT: - RETVAL + DB_File db + PREINIT: + dMY_CXT; + ALIAS: PUSH = 1 + CODE: + { + DBTKEY key ; + DBT value ; + DB * Db = db->dbp ; + int i ; + STRLEN n_a; + int keyval ; + + DBT_flags(key) ; + DBT_flags(value) ; + CurrentDB = db ; + /* Set the Cursor to the Last element */ + RETVAL = do_SEQ(db, key, value, R_LAST) ; +#ifndef DB_VERSION_MAJOR + if (RETVAL >= 0) +#endif + { + if (RETVAL == 0) + keyval = *(int*)key.data ; + else + keyval = 0 ; + for (i = 1 ; i < items ; ++i) + { + DBM_ckFilter(ST(i), filter_store_value, "filter_store_value"); + value.data = SvPVbyte(ST(i), n_a) ; + value.size = n_a ; + ++ keyval ; + key.data = &keyval ; + key.size = sizeof(int) ; + RETVAL = (Db->put)(Db, TXN &key, &value, 0) ; + if (RETVAL != 0) + break; + } + } + } + OUTPUT: + RETVAL I32 length(db) - DB_File db - PREINIT: - dMY_CXT; - ALIAS: FETCHSIZE = 1 - CODE: - CurrentDB = db ; - RETVAL = GetArrayLength(aTHX_ db) ; - OUTPUT: - RETVAL + DB_File db + PREINIT: + dMY_CXT; + ALIAS: FETCHSIZE = 1 + CODE: + CurrentDB = db ; + RETVAL = GetArrayLength(aTHX_ db) ; + OUTPUT: + RETVAL # @@ -1896,161 +1909,161 @@ length(db) int db_del(db, key, flags=0) - DB_File db - DBTKEY key - u_int flags - PREINIT: - dMY_CXT; - CODE: - CurrentDB = db ; - RETVAL = db_del(db, key, flags) ; + DB_File db + DBTKEY key + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_del(db, key, flags) ; #ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_NOTFOUND) - RETVAL = 1 ; + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; #endif - OUTPUT: - RETVAL + OUTPUT: + RETVAL int db_get(db, key, value, flags=0) - DB_File db - DBTKEY key - DBT value = NO_INIT - u_int flags - PREINIT: - dMY_CXT; - CODE: - CurrentDB = db ; - DBT_clear(value) ; - RETVAL = db_get(db, key, value, flags) ; + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_get(db, key, value, flags) ; #ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_NOTFOUND) - RETVAL = 1 ; + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; #endif - OUTPUT: - RETVAL - value + OUTPUT: + RETVAL + value int db_put(db, key, value, flags=0) - DB_File db - DBTKEY key - DBT value - u_int flags - PREINIT: - dMY_CXT; - CODE: - CurrentDB = db ; - RETVAL = db_put(db, key, value, flags) ; + DB_File db + DBTKEY key + DBT value + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_put(db, key, value, flags) ; #ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_KEYEXIST) - RETVAL = 1 ; + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_KEYEXIST) + RETVAL = 1 ; #endif - OUTPUT: - RETVAL - key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); + OUTPUT: + RETVAL + key if (flagSet(flags, R_IAFTER) || flagSet(flags, R_IBEFORE)) OutputKey(ST(1), key); int db_fd(db) - DB_File db - PREINIT: - dMY_CXT ; - CODE: - CurrentDB = db ; + DB_File db + PREINIT: + dMY_CXT ; + CODE: + CurrentDB = db ; #ifdef DB_VERSION_MAJOR - RETVAL = -1 ; - { - int status = 0 ; - status = (db->in_memory - ? -1 - : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; - if (status != 0) - RETVAL = -1 ; - } + RETVAL = -1 ; + { + int status = 0 ; + status = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp, &RETVAL) ) ; + if (status != 0) + RETVAL = -1 ; + } #else - RETVAL = (db->in_memory - ? -1 - : ((db->dbp)->fd)(db->dbp) ) ; + RETVAL = (db->in_memory + ? -1 + : ((db->dbp)->fd)(db->dbp) ) ; #endif - OUTPUT: - RETVAL + OUTPUT: + RETVAL int db_sync(db, flags=0) - DB_File db - u_int flags - PREINIT: - dMY_CXT; - CODE: - CurrentDB = db ; - RETVAL = db_sync(db, flags) ; + DB_File db + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + RETVAL = db_sync(db, flags) ; #ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; + if (RETVAL > 0) + RETVAL = -1 ; #endif - OUTPUT: - RETVAL + OUTPUT: + RETVAL int db_seq(db, key, value, flags) - DB_File db - DBTKEY key - DBT value = NO_INIT - u_int flags - PREINIT: - dMY_CXT; - CODE: - CurrentDB = db ; - DBT_clear(value) ; - RETVAL = db_seq(db, key, value, flags); + DB_File db + DBTKEY key + DBT value = NO_INIT + u_int flags + PREINIT: + dMY_CXT; + CODE: + CurrentDB = db ; + DBT_clear(value) ; + RETVAL = db_seq(db, key, value, flags); #ifdef DB_VERSION_MAJOR - if (RETVAL > 0) - RETVAL = -1 ; - else if (RETVAL == DB_NOTFOUND) - RETVAL = 1 ; + if (RETVAL > 0) + RETVAL = -1 ; + else if (RETVAL == DB_NOTFOUND) + RETVAL = 1 ; #endif - OUTPUT: - RETVAL - key - value + OUTPUT: + RETVAL + key + value SV * filter_fetch_key(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - DBM_setFilter(db->filter_fetch_key, code) ; + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_key, code) ; SV * filter_store_key(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - DBM_setFilter(db->filter_store_key, code) ; + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_key, code) ; SV * filter_fetch_value(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - DBM_setFilter(db->filter_fetch_value, code) ; + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_fetch_value, code) ; SV * filter_store_value(db, code) - DB_File db - SV * code - SV * RETVAL = &PL_sv_undef ; - CODE: - DBM_setFilter(db->filter_store_value, code) ; + DB_File db + SV * code + SV * RETVAL = &PL_sv_undef ; + CODE: + DBM_setFilter(db->filter_store_value, code) ; diff --git a/gnu/usr.bin/perl/cpan/DB_File/Makefile.PL b/gnu/usr.bin/perl/cpan/DB_File/Makefile.PL index 03dbf964299..774c219f5a5 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/DB_File/Makefile.PL @@ -46,14 +46,14 @@ my $WALL = '' ; my $CORE = $ENV{PERL_CORE} ? '' : '-D_NOT_CORE'; WriteMakefile( - NAME => 'DB_File', - LIBS => ["-L${LIB_DIR} $LIBS"], - INC => "-I$INC_DIR", - VERSION_FROM => 'DB_File.pm', - XS_VERSION => eval MM->parse_version('DB_File.pm'), - XSPROTOARG => '-noprototypes', - DEFINE => "$CORE $OS2 $VER_INFO $COMPAT185 $WALL", - OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', + NAME => 'DB_File', + LIBS => ["-L${LIB_DIR} $LIBS"], + INC => "-I$INC_DIR", + VERSION_FROM => 'DB_File.pm', + XS_VERSION => eval MM->parse_version('DB_File.pm'), + XSPROTOARG => '-noprototypes', + DEFINE => "$CORE $OS2 $VER_INFO $COMPAT185 $WALL", + OBJECT => 'version$(OBJ_EXT) DB_File$(OBJ_EXT)', ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : () @@ -69,46 +69,72 @@ WriteMakefile( ? (INSTALLDIRS => 'site') : (INSTALLDIRS => 'perl'), - #OPTIMIZE => '-g', - 'depend' => { 'Makefile' => 'config.in', + #OPTIMIZE => '-g', + 'depend' => { 'Makefile' => 'config.in', 'version$(OBJ_EXT)' => 'version.c'}, - 'clean' => { FILES => 'constants.h constants.xs DB_File.pm.bak t/db-btree.t.bak t/db-hash.t.bak t/db-recno.t.bak t/pod.t.bak' }, - 'macro' => { my_files => "@files" }, + 'clean' => { FILES => 'constants.h constants.xs DB_File.pm.bak t/db-btree.t.bak t/db-hash.t.bak t/db-recno.t.bak t/pod.t.bak' }, + 'macro' => { my_files => "@files" }, 'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz', - DIST_DEFAULT => 'MyDoubleCheck tardist'}, - ); + DIST_DEFAULT => 'MyDoubleCheck tardist'}, + + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ? ( META_MERGE => { + + "meta-spec" => { version => 2 }, + + resources => { + + bugtracker => { + web => 'https://github.com/pmqs/DB_File/issues' + }, + + homepage => 'https://github.com/pmqs/DB_File', + + repository => { + type => 'git', + url => 'git://github.com/pmqs/DB_File.git', + web => 'https://github.com/pmqs/DB_File', + }, + }, + } + ) + : () + ), + + + ); my @names = qw( - BTREEMAGIC - BTREEVERSION - DB_LOCK - DB_SHMEM - DB_TXN - HASHMAGIC - HASHVERSION - MAX_PAGE_NUMBER - MAX_PAGE_OFFSET - MAX_REC_NUMBER - RET_ERROR - RET_SPECIAL - RET_SUCCESS - R_CURSOR - R_DUP - R_FIRST - R_FIXEDLEN - R_IAFTER - R_IBEFORE - R_LAST - R_NEXT - R_NOKEY - R_NOOVERWRITE - R_PREV - R_RECNOSYNC - R_SETCURSOR - R_SNAPSHOT - __R_UNUSED - ); + BTREEMAGIC + BTREEVERSION + DB_LOCK + DB_SHMEM + DB_TXN + HASHMAGIC + HASHVERSION + MAX_PAGE_NUMBER + MAX_PAGE_OFFSET + MAX_REC_NUMBER + RET_ERROR + RET_SPECIAL + RET_SUCCESS + R_CURSOR + R_DUP + R_FIRST + R_FIXEDLEN + R_IAFTER + R_IBEFORE + R_LAST + R_NEXT + R_NOKEY + R_NOOVERWRITE + R_PREV + R_RECNOSYNC + R_SETCURSOR + R_SNAPSHOT + __R_UNUSED + ); if (eval {require ExtUtils::Constant; 1}) { # Check the constants above all appear in @EXPORT in DB_File.pm @@ -171,9 +197,9 @@ sub MY::postamble { <<'EOM' } ; MyDoubleCheck: @echo Checking config.in is setup for a release - @(grep "^LIB.*/usr/local/BerkeleyDB" config.in && \ - grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in && \ - grep "^#DBNAME.*" config.in) >/dev/null || \ + @(grep "^LIB.*/usr/local/BerkeleyDB" config.in && \ + grep "^INCLUDE.*/usr/local/BerkeleyDB" config.in && \ + grep "^#DBNAME.*" config.in) >/dev/null || \ (echo config.in needs fixing ; exit 1) @echo config.in is ok @echo @@ -183,16 +209,16 @@ MyDoubleCheck: @echo DB_File.xs is ok @echo @echo Checking for $$^W in files: $(my_files) - @perl -ne ' \ - exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) || \ - (echo found unexpected $$^W ; exit 1) + @perl -ne ' \ + exit 1 if /^\s*local\s*\(\s*\$$\^W\s*\)/;' $(my_files) || \ + (echo found unexpected $$^W ; exit 1) @echo No $$^W found. @echo @echo Checking for 'use vars' in files: $(my_files) - @perl -ne ' \ - exit 0 if /^__(DATA|END)__/; \ - exit 1 if /^\s*use\s+vars/;' $(my_files) || \ - (echo found unexpected "use vars"; exit 1) + @perl -ne ' \ + exit 0 if /^__(DATA|END)__/; \ + exit 1 if /^\s*use\s+vars/;' $(my_files) || \ + (echo found unexpected "use vars"; exit 1) @echo No 'use vars' found. @echo @echo All files are OK for a release. @@ -223,24 +249,24 @@ sub ParseCONFIG open(F, "$CONFIG") or die "Cannot open file $CONFIG: $!\n" ; while (<F>) { - s/^\s*|\s*$//g ; - next if /^\s*$/ or /^\s*#/ ; - s/\s*#\s*$// ; - - ($k, $v) = split(/\s+=\s+/, $_, 2) ; - $k = uc $k ; - if ($ValidOption{$k}) { - delete $Parsed{$k} ; - $Info{$k} = $v ; - } - else { - push(@badkey, $k) ; - } + s/^\s*|\s*$//g ; + next if /^\s*$/ or /^\s*#/ ; + s/\s*#\s*$// ; + + ($k, $v) = split(/\s+=\s+/, $_, 2) ; + $k = uc $k ; + if ($ValidOption{$k}) { + delete $Parsed{$k} ; + $Info{$k} = $v ; + } + else { + push(@badkey, $k) ; + } } close F ; print "Unknown keys in $CONFIG ignored [@badkey]\n" - if @badkey ; + if @badkey ; # check parsed values my @missing = () ; @@ -252,18 +278,18 @@ sub ParseCONFIG $DB_NAME = $ENV{'DB_FILE_NAME'} || $Info{'DBNAME'} ; $COMPAT185 = "-DCOMPAT185 -DDB_LIBRARY_COMPATIBILITY_API" if (defined $ENV{'DB_FILE_COMPAT185'} && - $ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) || - $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; + $ENV{'DB_FILE_COMPAT185'} =~ /^\s*(on|true|1)\s*$/i) || + $Info{'COMPAT185'} =~ /^\s*(on|true|1)\s*$/i ; my $PREFIX = $Info{'PREFIX'} ; my $HASH = $Info{'HASH'} ; $VER_INFO = "-DmDB_Prefix_t=${PREFIX} -DmDB_Hash_t=${HASH}" ; print <<EOM if 0 ; - INCLUDE [$INC_DIR] - LIB [$LIB_DIR] - HASH [$HASH] - PREFIX [$PREFIX] + INCLUDE [$INC_DIR] + LIB [$LIB_DIR] + HASH [$HASH] + PREFIX [$PREFIX] DBNAME [$DB_NAME] EOM @@ -295,10 +321,10 @@ sub UpDowngrade # From: warnings::warnif(x,y); # To: $^W && carp(y); # warnif -- x $warn_sub = sub { - s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; - s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; + s/^(\s*)(no\s+warnings)/${1}local (\$^W) = 0; #$2/ ; + s/^(\s*)(use\s+warnings)/${1}local (\$^W) = 1; #$2/ ; - s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ; + s/^(\s*)warnings::warnif\s*\((.*?)\s*,\s*(.*?)\)\s*;/${1}\$^W && carp($3); # warnif - $2/ ; }; } else { @@ -310,14 +336,14 @@ sub UpDowngrade # From: $^W && carp(y); # warnif -- x # To: warnings::warnif(x,y); $warn_sub = sub { - s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; - s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ; + s/^(\s*)local\s*\(\$\^W\)\s*=\s*\d+\s*;\s*#\s*((no|use)\s+warnings.*)/$1$2/ ; + s/^(\s*)\$\^W\s+\&\&\s*carp\s*\((.*?)\)\s*;\s*#\s*warnif\s*-\s*(.*)/${1}warnings::warnif($3, $2);/ ; }; } if ($] < 5.006000) { $our_sub = sub { - if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { + if ( /^(\s*)our\s+\(\s*([^)]+\s*)\)/ ) { my $indent = $1; my $vars = join ' ', split /\s*,\s*/, $2; $_ = "${indent}use vars qw($vars);\n"; @@ -326,7 +352,7 @@ sub UpDowngrade } else { $our_sub = sub { - if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { + if ( /^(\s*)use\s+vars\s+qw\((.*?)\)/ ) { my $indent = $1; my $vars = join ', ', split ' ', $2; $_ = "${indent}our ($vars);\n"; @@ -349,11 +375,11 @@ sub doUpDown while (<>) { - print, last if /^__(END|DATA)__/ ; + print, last if /^__(END|DATA)__/ ; - &{ $our_sub }(); - &{ $warn_sub }(); - print ; + &{ $our_sub }(); + &{ $warn_sub }(); + print ; } return if eof ; diff --git a/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.pm b/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.pm index bc0fec720a1..2742a05e658 100644 --- a/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.pm +++ b/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.pm @@ -3,7 +3,7 @@ package Digest::MD5; use strict; use vars qw($VERSION @ISA @EXPORT_OK); -$VERSION = '2.55'; +$VERSION = '2.55_01'; require Exporter; *import = \&Exporter::import; diff --git a/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs b/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs index fda44bbe4a9..964d37fb0e5 100644 --- a/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs +++ b/gnu/usr.bin/perl/cpan/Digest-MD5/MD5.xs @@ -39,8 +39,6 @@ extern "C" { #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include <sys/types.h> -#include <md5.h> #ifdef __cplusplus } #endif @@ -90,6 +88,46 @@ static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type, # define SvPVbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), (lp))) #endif +/* Perl does not guarantee that U32 is exactly 32 bits. Some system + * has no integral type with exactly 32 bits. For instance, A Cray has + * short, int and long all at 64 bits so we need to apply this macro + * to reduce U32 values to 32 bits at appropriate places. If U32 + * really does have 32 bits then this is a no-op. + */ +#if BYTEORDER > 0x4321 || defined(TRUNCATE_U32) + #define TO32(x) ((x) & 0xFFFFffff) + #define TRUNC32(x) ((x) &= 0xFFFFffff) +#else + #define TO32(x) (x) + #define TRUNC32(x) /*nothing*/ +#endif + +/* The MD5 algorithm is defined in terms of little endian 32-bit + * values. The following macros (and functions) allow us to convert + * between native integers and such values. + */ +static void u2s(U32 u, U8* s) +{ + *s++ = (U8)(u & 0xFF); + *s++ = (U8)((u >> 8) & 0xFF); + *s++ = (U8)((u >> 16) & 0xFF); + *s = (U8)((u >> 24) & 0xFF); +} + +#define s2u(s,u) ((u) = (U32)(*s) | \ + ((U32)(*(s+1)) << 8) | \ + ((U32)(*(s+2)) << 16) | \ + ((U32)(*(s+3)) << 24)) + +/* This structure keeps the current state of algorithm. + */ +typedef struct { + U32 A, B, C, D; /* current digest */ + U32 bytes_low; /* counts bytes in message */ + U32 bytes_high; /* turn it into a 64-bit counter */ + U8 buffer[128]; /* collect complete 64 byte blocks */ +} MD5_CTX; + #if defined(USE_ITHREADS) && defined(MGf_DUP) STATIC int dup_md5_ctx(pTHX_ MAGIC *mg, CLONE_PARAMS *params) { @@ -126,6 +164,300 @@ STATIC const struct { }; #endif + +/* Padding is added at the end of the message in order to fill a + * complete 64 byte block (- 8 bytes for the message length). The + * padding is also the reason the buffer in MD5_CTX have to be + * 128 bytes. + */ +static const unsigned char PADDING[64] = { + 0x80, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 +}; + +/* Constants for MD5Transform routine. + */ +#define S11 7 +#define S12 12 +#define S13 17 +#define S14 22 +#define S21 5 +#define S22 9 +#define S23 14 +#define S24 20 +#define S31 4 +#define S32 11 +#define S33 16 +#define S34 23 +#define S41 6 +#define S42 10 +#define S43 15 +#define S44 21 + +/* F, G, H and I are basic MD5 functions. + */ +#define F(x, y, z) ((((x) & ((y) ^ (z))) ^ (z))) +#define G(x, y, z) F(z, x, y) +#define H(x, y, z) ((x) ^ (y) ^ (z)) +#define I(x, y, z) ((y) ^ ((x) | (~z))) + +/* ROTATE_LEFT rotates x left n bits. + */ +#define ROTATE_LEFT(x, n) (((x) << (n) | ((x) >> (32-(n))))) + +/* FF, GG, HH, and II transformations for rounds 1, 2, 3, and 4. + * Rotation is separate from addition to prevent recomputation. + */ +#define FF(a, b, c, d, s, ac) \ + (a) += F ((b), (c), (d)) + (NEXTx) + (U32)(ac); \ + TRUNC32((a)); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ + TRUNC32((a)); + +#define GG(a, b, c, d, x, s, ac) \ + (a) += G ((b), (c), (d)) + X[x] + (U32)(ac); \ + TRUNC32((a)); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ + TRUNC32((a)); + +#define HH(a, b, c, d, x, s, ac) \ + (a) += H ((b), (c), (d)) + X[x] + (U32)(ac); \ + TRUNC32((a)); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ + TRUNC32((a)); + +#define II(a, b, c, d, x, s, ac) \ + (a) += I ((b), (c), (d)) + X[x] + (U32)(ac); \ + TRUNC32((a)); \ + (a) = ROTATE_LEFT ((a), (s)); \ + (a) += (b); \ + TRUNC32((a)); + + +static void +MD5Init(MD5_CTX *ctx) +{ + /* Start state */ + ctx->A = 0x67452301; + ctx->B = 0xefcdab89; + ctx->C = 0x98badcfe; + ctx->D = 0x10325476; + + /* message length */ + ctx->bytes_low = ctx->bytes_high = 0; +} + + +static void +MD5Transform(MD5_CTX* ctx, const U8* buf, STRLEN blocks) +{ +#ifdef MD5_DEBUG + static int tcount = 0; +#endif + + U32 A = ctx->A; + U32 B = ctx->B; + U32 C = ctx->C; + U32 D = ctx->D; + + do { + U32 a = A; + U32 b = B; + U32 c = C; + U32 d = D; + + U32 X[16]; /* little-endian values, used in round 2-4 */ + U32 *uptr = X; + U32 tmp; + #define NEXTx (s2u(buf,tmp), buf += 4, *uptr++ = tmp) + +#ifdef MD5_DEBUG + if (buf == ctx->buffer) + fprintf(stderr,"%5d: Transform ctx->buffer", ++tcount); + else + fprintf(stderr,"%5d: Transform %p (%d)", ++tcount, buf, blocks); + + { + int i; + fprintf(stderr,"["); + for (i = 0; i < 16; i++) { + fprintf(stderr,"%x,", x[i]); /* FIXME */ + } + fprintf(stderr,"]\n"); + } +#endif + + /* Round 1 */ + FF (a, b, c, d, S11, 0xd76aa478); /* 1 */ + FF (d, a, b, c, S12, 0xe8c7b756); /* 2 */ + FF (c, d, a, b, S13, 0x242070db); /* 3 */ + FF (b, c, d, a, S14, 0xc1bdceee); /* 4 */ + FF (a, b, c, d, S11, 0xf57c0faf); /* 5 */ + FF (d, a, b, c, S12, 0x4787c62a); /* 6 */ + FF (c, d, a, b, S13, 0xa8304613); /* 7 */ + FF (b, c, d, a, S14, 0xfd469501); /* 8 */ + FF (a, b, c, d, S11, 0x698098d8); /* 9 */ + FF (d, a, b, c, S12, 0x8b44f7af); /* 10 */ + FF (c, d, a, b, S13, 0xffff5bb1); /* 11 */ + FF (b, c, d, a, S14, 0x895cd7be); /* 12 */ + FF (a, b, c, d, S11, 0x6b901122); /* 13 */ + FF (d, a, b, c, S12, 0xfd987193); /* 14 */ + FF (c, d, a, b, S13, 0xa679438e); /* 15 */ + FF (b, c, d, a, S14, 0x49b40821); /* 16 */ + + /* Round 2 */ + GG (a, b, c, d, 1, S21, 0xf61e2562); /* 17 */ + GG (d, a, b, c, 6, S22, 0xc040b340); /* 18 */ + GG (c, d, a, b, 11, S23, 0x265e5a51); /* 19 */ + GG (b, c, d, a, 0, S24, 0xe9b6c7aa); /* 20 */ + GG (a, b, c, d, 5, S21, 0xd62f105d); /* 21 */ + GG (d, a, b, c, 10, S22, 0x2441453); /* 22 */ + GG (c, d, a, b, 15, S23, 0xd8a1e681); /* 23 */ + GG (b, c, d, a, 4, S24, 0xe7d3fbc8); /* 24 */ + GG (a, b, c, d, 9, S21, 0x21e1cde6); /* 25 */ + GG (d, a, b, c, 14, S22, 0xc33707d6); /* 26 */ + GG (c, d, a, b, 3, S23, 0xf4d50d87); /* 27 */ + GG (b, c, d, a, 8, S24, 0x455a14ed); /* 28 */ + GG (a, b, c, d, 13, S21, 0xa9e3e905); /* 29 */ + GG (d, a, b, c, 2, S22, 0xfcefa3f8); /* 30 */ + GG (c, d, a, b, 7, S23, 0x676f02d9); /* 31 */ + GG (b, c, d, a, 12, S24, 0x8d2a4c8a); /* 32 */ + + /* Round 3 */ + HH (a, b, c, d, 5, S31, 0xfffa3942); /* 33 */ + HH (d, a, b, c, 8, S32, 0x8771f681); /* 34 */ + HH (c, d, a, b, 11, S33, 0x6d9d6122); /* 35 */ + HH (b, c, d, a, 14, S34, 0xfde5380c); /* 36 */ + HH (a, b, c, d, 1, S31, 0xa4beea44); /* 37 */ + HH (d, a, b, c, 4, S32, 0x4bdecfa9); /* 38 */ + HH (c, d, a, b, 7, S33, 0xf6bb4b60); /* 39 */ + HH (b, c, d, a, 10, S34, 0xbebfbc70); /* 40 */ + HH (a, b, c, d, 13, S31, 0x289b7ec6); /* 41 */ + HH (d, a, b, c, 0, S32, 0xeaa127fa); /* 42 */ + HH (c, d, a, b, 3, S33, 0xd4ef3085); /* 43 */ + HH (b, c, d, a, 6, S34, 0x4881d05); /* 44 */ + HH (a, b, c, d, 9, S31, 0xd9d4d039); /* 45 */ + HH (d, a, b, c, 12, S32, 0xe6db99e5); /* 46 */ + HH (c, d, a, b, 15, S33, 0x1fa27cf8); /* 47 */ + HH (b, c, d, a, 2, S34, 0xc4ac5665); /* 48 */ + + /* Round 4 */ + II (a, b, c, d, 0, S41, 0xf4292244); /* 49 */ + II (d, a, b, c, 7, S42, 0x432aff97); /* 50 */ + II (c, d, a, b, 14, S43, 0xab9423a7); /* 51 */ + II (b, c, d, a, 5, S44, 0xfc93a039); /* 52 */ + II (a, b, c, d, 12, S41, 0x655b59c3); /* 53 */ + II (d, a, b, c, 3, S42, 0x8f0ccc92); /* 54 */ + II (c, d, a, b, 10, S43, 0xffeff47d); /* 55 */ + II (b, c, d, a, 1, S44, 0x85845dd1); /* 56 */ + II (a, b, c, d, 8, S41, 0x6fa87e4f); /* 57 */ + II (d, a, b, c, 15, S42, 0xfe2ce6e0); /* 58 */ + II (c, d, a, b, 6, S43, 0xa3014314); /* 59 */ + II (b, c, d, a, 13, S44, 0x4e0811a1); /* 60 */ + II (a, b, c, d, 4, S41, 0xf7537e82); /* 61 */ + II (d, a, b, c, 11, S42, 0xbd3af235); /* 62 */ + II (c, d, a, b, 2, S43, 0x2ad7d2bb); /* 63 */ + II (b, c, d, a, 9, S44, 0xeb86d391); /* 64 */ + + A += a; TRUNC32(A); + B += b; TRUNC32(B); + C += c; TRUNC32(C); + D += d; TRUNC32(D); + + } while (--blocks); + ctx->A = A; + ctx->B = B; + ctx->C = C; + ctx->D = D; +} + + +#ifdef MD5_DEBUG +static char* +ctx_dump(MD5_CTX* ctx) +{ + static char buf[1024]; + sprintf(buf, "{A=%x,B=%x,C=%x,D=%x,%d,%d(%d)}", + ctx->A, ctx->B, ctx->C, ctx->D, + ctx->bytes_low, ctx->bytes_high, (ctx->bytes_low&0x3F)); + return buf; +} +#endif + + +static void +MD5Update(MD5_CTX* ctx, const U8* buf, STRLEN len) +{ + STRLEN blocks; + STRLEN fill = ctx->bytes_low & 0x3F; + +#ifdef MD5_DEBUG + static int ucount = 0; + fprintf(stderr,"%5i: Update(%s, %p, %d)\n", ++ucount, ctx_dump(ctx), + buf, len); +#endif + + ctx->bytes_low += len; + if (ctx->bytes_low < len) /* wrap around */ + ctx->bytes_high++; + + if (fill) { + STRLEN missing = 64 - fill; + if (len < missing) { + Copy(buf, ctx->buffer + fill, len, U8); + return; + } + Copy(buf, ctx->buffer + fill, missing, U8); + MD5Transform(ctx, ctx->buffer, 1); + buf += missing; + len -= missing; + } + + blocks = len >> 6; + if (blocks) + MD5Transform(ctx, buf, blocks); + if ( (len &= 0x3F)) { + Copy(buf + (blocks << 6), ctx->buffer, len, U8); + } +} + + +static void +MD5Final(U8* digest, MD5_CTX *ctx) +{ + STRLEN fill = ctx->bytes_low & 0x3F; + STRLEN padlen = (fill < 56 ? 56 : 120) - fill; + U32 bits_low, bits_high; +#ifdef MD5_DEBUG + fprintf(stderr," Final: %s\n", ctx_dump(ctx)); +#endif + Copy(PADDING, ctx->buffer + fill, padlen, U8); + fill += padlen; + + bits_low = ctx->bytes_low << 3; + bits_high = (ctx->bytes_high << 3) | (ctx->bytes_low >> 29); + u2s(bits_low, ctx->buffer + fill); fill += 4; + u2s(bits_high, ctx->buffer + fill); fill += 4; + + MD5Transform(ctx, ctx->buffer, fill >> 6); +#ifdef MD5_DEBUG + fprintf(stderr," Result: %s\n", ctx_dump(ctx)); +#endif + + u2s(ctx->A, digest); + u2s(ctx->B, digest+4); + u2s(ctx->C, digest+8); + u2s(ctx->D, digest+12); +} + +#ifndef INT2PTR +#define INT2PTR(any,d) (any)(d) +#endif + static MD5_CTX* get_md5_ctx(pTHX_ SV* sv) { MAGIC *mg; @@ -306,7 +638,7 @@ addfile(self, fh) InputStream fh PREINIT: MD5_CTX* context = get_md5_ctx(aTHX_ self); - STRLEN fill = (context->count >> 3) & (MD5_BLOCK_LENGTH - 1); + STRLEN fill = context->bytes_low & 0x3F; #ifdef USE_HEAP_INSTEAD_OF_STACK unsigned char* buffer; #else @@ -371,12 +703,14 @@ context(ctx, ...) PPCODE: if (items > 2) { STRLEN len; - ctx->count = SvUV(ST(1)) << 3; + unsigned long blocks = SvUV(ST(1)); unsigned char *buf = (unsigned char *)(SvPV(ST(2), len)); - ctx->state[0] = buf[ 0] | (buf[ 1]<<8) | (buf[ 2]<<16) | (buf[ 3]<<24); - ctx->state[1] = buf[ 4] | (buf[ 5]<<8) | (buf[ 6]<<16) | (buf[ 7]<<24); - ctx->state[2] = buf[ 8] | (buf[ 9]<<8) | (buf[10]<<16) | (buf[11]<<24); - ctx->state[3] = buf[12] | (buf[13]<<8) | (buf[14]<<16) | (buf[15]<<24); + ctx->A = buf[ 0] | (buf[ 1]<<8) | (buf[ 2]<<16) | (buf[ 3]<<24); + ctx->B = buf[ 4] | (buf[ 5]<<8) | (buf[ 6]<<16) | (buf[ 7]<<24); + ctx->C = buf[ 8] | (buf[ 9]<<8) | (buf[10]<<16) | (buf[11]<<24); + ctx->D = buf[12] | (buf[13]<<8) | (buf[14]<<16) | (buf[15]<<24); + ctx->bytes_low = blocks << 6; + ctx->bytes_high = blocks >> 26; if (items == 4) { buf = (unsigned char *)(SvPV(ST(3), len)); MD5Update(ctx, buf, len); @@ -386,20 +720,17 @@ context(ctx, ...) XSRETURN(0); } - w=ctx->state[0]; out[ 0]=w; out[ 1]=(w>>8); out[ 2]=(w>>16); out[ 3]=(w>>24); - w=ctx->state[1]; out[ 4]=w; out[ 5]=(w>>8); out[ 6]=(w>>16); out[ 7]=(w>>24); - w=ctx->state[2]; out[ 8]=w; out[ 9]=(w>>8); out[10]=(w>>16); out[11]=(w>>24); - w=ctx->state[3]; out[12]=w; out[13]=(w>>8); out[14]=(w>>16); out[15]=(w>>24); + w=ctx->A; out[ 0]=w; out[ 1]=(w>>8); out[ 2]=(w>>16); out[ 3]=(w>>24); + w=ctx->B; out[ 4]=w; out[ 5]=(w>>8); out[ 6]=(w>>16); out[ 7]=(w>>24); + w=ctx->C; out[ 8]=w; out[ 9]=(w>>8); out[10]=(w>>16); out[11]=(w>>24); + w=ctx->D; out[12]=w; out[13]=(w>>8); out[14]=(w>>16); out[15]=(w>>24); EXTEND(SP, 3); - ST(0) = sv_2mortal(newSViv((ctx->count >> 3) - - ((ctx->count >> 3) % MD5_BLOCK_LENGTH))); + ST(0) = sv_2mortal(newSVuv(ctx->bytes_high << 26 | + ctx->bytes_low >> 6)); ST(1) = sv_2mortal(newSVpv(out, 16)); - ST(2) = sv_2mortal(newSVpv("",0)); - if (((ctx->count >> 3) & (MD5_BLOCK_LENGTH - 1)) != 0) - ST(2) = sv_2mortal(newSVpv((char *)ctx->buffer, - (ctx->count >> 3) & (MD5_BLOCK_LENGTH - 1))); - + ST(2) = sv_2mortal(newSVpv((char *)ctx->buffer, + ctx->bytes_low & 0x3F)); XSRETURN(3); void diff --git a/gnu/usr.bin/perl/cpan/Digest-MD5/Makefile.PL b/gnu/usr.bin/perl/cpan/Digest-MD5/Makefile.PL index 1015058bacd..76906d10463 100644 --- a/gnu/usr.bin/perl/cpan/Digest-MD5/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Digest-MD5/Makefile.PL @@ -5,7 +5,6 @@ use Config qw(%Config); use ExtUtils::MakeMaker; my @extra; -push(@extra, DEFINE => "-DU32_ALIGNMENT_REQUIRED") unless free_u32_alignment(); push(@extra, INSTALLDIRS => 'perl') if $] >= 5.008 && $] < 5.012; if ($^O eq 'VMS') { @@ -39,119 +38,6 @@ WriteMakefile( -sub free_u32_alignment -{ - $|=1; - if (exists $Config{d_u32align}) { - print "Perl's config says that U32 access must "; - print "not " unless $Config{d_u32align}; - print "be aligned.\n"; - return !$Config{d_u32align}; - } - - if ($^O eq 'VMS' || $^O eq 'MSWin32') { - print "Assumes that $^O implies free alignment for U32 access.\n"; - return 1; - } - - if ($^O eq 'hpux' && $Config{osvers} < 11.0) { - print "Will not test for free alignment on older HP-UX.\n"; - return 0; - } - - print "Testing alignment requirements for U32... "; - open(ALIGN_TEST, ">u32align.c") or die "$!"; - print ALIGN_TEST <<'EOT'; close(ALIGN_TEST); -/*--------------------------------------------------------------*/ -/* This program allocates a buffer of U8 (char) and then tries */ -/* to access it through a U32 pointer at every offset. The */ -/* program is expected to die with a bus error/seg fault for */ -/* machines that do not support unaligned integer read/write */ -/*--------------------------------------------------------------*/ - -#include <stdio.h> -#include "EXTERN.h" -#include "perl.h" - -#ifdef printf - #undef printf -#endif - -int main(int argc, char** argv, char** env) -{ -#if BYTEORDER == 0x1234 || BYTEORDER == 0x4321 - volatile U8 buf[] = "\0\0\0\1\0\0\0\0"; - volatile U32 *up; - int i; - - if (sizeof(U32) != 4) { - printf("sizeof(U32) is not 4, but %d\n", sizeof(U32)); - exit(1); - } - - fflush(stdout); - - for (i = 0; i < 4; i++) { - up = (U32*)(buf + i); - if (! ((*up == 1 << (8*i)) || /* big-endian */ - (*up == 1 << (8*(3-i))) /* little-endian */ - ) - ) - { - printf("read failed (%x)\n", *up); - exit(2); - } - } - - /* write test */ - for (i = 0; i < 4; i++) { - up = (U32*)(buf + i); - *up = 0xBeef; - if (*up != 0xBeef) { - printf("write failed (%x)\n", *up); - exit(3); - } - } - - printf("no restrictions\n"); - exit(0); -#else - printf("unusual byteorder, playing safe\n"); - exit(1); -#endif - return 0; -} -/*--------------------------------------------------------------*/ -EOT - - my $cc_cmd = "$Config{cc} $Config{ccflags} -I$Config{archlibexp}/CORE"; - my $exe = "u32align$Config{exe_ext}"; - $cc_cmd .= " -o $exe"; - my $rc; - $rc = system("$cc_cmd $Config{ldflags} u32align.c $Config{libs}"); - if ($rc) { - print "Can't compile test program. Will ensure alignment to play safe.\n\n"; - unlink("u32align.c", $exe, "u32align$Config{obj_ext}"); - return 0; - } - - $rc = system("./$exe"); - unlink("u32align.c", $exe, "u32align$Config{obj_ext}"); - - return 1 unless $rc; - - if ($rc > 0x80) { - (my $cp = $rc) >>= 8; - print "Test program exit status was $cp\n"; - } - if ($rc & 0x80) { - $rc &= ~0x80; - unlink("core") && print "Core dump deleted\n"; - } - print "signal $rc\n" if $rc && $rc < 0x80; - return 0; -} - BEGIN { # compatibility with older versions of MakeMaker my $developer = -d ".git"; diff --git a/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t b/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t index 728ceb130b8..ef64088c8c5 100755 --- a/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t +++ b/gnu/usr.bin/perl/cpan/Digest-MD5/t/files.t @@ -21,7 +21,7 @@ EOT # This is the output of: 'md5sum README MD5.xs rfc1321.txt' $EXPECT = <<EOT; 2f93400875dbb56f36691d5f69f3eba5 README -641f5e20d5d53222c50ba99fbddabd15 MD5.xs +5b8b4f96bc27a425501307c5461970db MD5.xs 754b9db19f79dbc4992f7166eb0f37ce rfc1321.txt EOT } diff --git a/gnu/usr.bin/perl/cpan/Encode/Encode.pm b/gnu/usr.bin/perl/cpan/Encode/Encode.pm index bc566879e30..de06ba149ea 100644 --- a/gnu/usr.bin/perl/cpan/Encode/Encode.pm +++ b/gnu/usr.bin/perl/cpan/Encode/Encode.pm @@ -1,5 +1,5 @@ # -# $Id: Encode.pm,v 3.01 2019/03/13 00:25:25 dankogai Exp $ +# $Id: Encode.pm,v 3.06 2020/05/02 02:31:14 dankogai Exp $ # package Encode; use strict; @@ -7,7 +7,7 @@ use warnings; use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; our $VERSION; BEGIN { - $VERSION = sprintf "%d.%02d", q$Revision: 3.01 $ =~ /(\d+)/g; + $VERSION = sprintf "%d.%02d", q$Revision: 3.06 $ =~ /(\d+)/g; require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); } @@ -65,7 +65,7 @@ require Encode::Config; eval { local $SIG{__DIE__}; local $SIG{__WARN__}; - local @INC = @INC; + local @INC = @INC || (); pop @INC if $INC[-1] eq '.'; require Encode::ConfigLocal; }; diff --git a/gnu/usr.bin/perl/cpan/Encode/Encode.xs b/gnu/usr.bin/perl/cpan/Encode/Encode.xs index feeccd8752b..4baf2963aa4 100644 --- a/gnu/usr.bin/perl/cpan/Encode/Encode.xs +++ b/gnu/usr.bin/perl/cpan/Encode/Encode.xs @@ -1,5 +1,5 @@ /* - $Id: Encode.xs,v 2.47 2019/03/13 00:26:18 dankogai Exp dankogai $ + $Id: Encode.xs,v 2.48 2020/03/02 04:34:34 dankogai Exp $ */ #define PERL_NO_GET_CONTEXT @@ -231,7 +231,7 @@ encode_method(pTHX_ const encode_t * enc, const encpage_t * dir, SV * src, U8 * if (dir == enc->f_utf8) { STRLEN clen; UV ch = - utf8n_to_uvuni(s+slen, (tlen-sdone-slen), + utf8n_to_uvchr(s+slen, (tlen-sdone-slen), &clen, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY); /* if non-representable multibyte prefix at end of current buffer - break*/ if (clen > tlen - sdone - slen) break; @@ -982,6 +982,7 @@ ALIAS: PREINIT: SV *obj; INIT: + PERL_UNUSED_VAR(ix); SvGETMAGIC(encoding); CODE: if (!SvOK(encoding)) @@ -1003,6 +1004,7 @@ ALIAS: PREINIT: SV *obj; INIT: + PERL_UNUSED_VAR(ix); SvGETMAGIC(encoding); CODE: if (!SvOK(encoding)) diff --git a/gnu/usr.bin/perl/cpan/Encode/bin/enc2xs b/gnu/usr.bin/perl/cpan/Encode/bin/enc2xs index 619b64b7573..1209baa9cdd 100644 --- a/gnu/usr.bin/perl/cpan/Encode/bin/enc2xs +++ b/gnu/usr.bin/perl/cpan/Encode/bin/enc2xs @@ -11,7 +11,7 @@ use warnings; use Getopt::Std; use Config; my @orig_ARGV = @ARGV; -our $VERSION = do { my @r = (q$Revision: 2.21 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 2.23 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # These may get re-ordered. # RAW is a do_now as inserted by &enter @@ -144,6 +144,7 @@ getopts('CM:SQqOo:f:n:v',\%opt); $opt{M} and make_makefile_pl($opt{M}, @ARGV); $opt{C} and make_configlocal_pm($opt{C}, @ARGV); $opt{v} ||= $ENV{ENC2XS_VERBOSE}; +$opt{q} ||= $ENV{ENC2XS_NO_COMMENTS}; sub verbose { print STDERR @_ if $opt{v}; @@ -914,24 +915,7 @@ sub decode_U } my @uname; -sub char_names -{ - my $s = do "unicore/Name.pl"; - die "char_names: unicore/Name.pl: $!\n" unless defined $s; - pos($s) = 0; - while ($s =~ /\G([0-9a-f]+)\t([0-9a-f]*)\t(.*?)\s*\n/igc) - { - my $name = $3; - my $s = hex($1); - last if $s >= 0x10000; - my $e = length($2) ? hex($2) : $s; - for (my $i = $s; $i <= $e; $i++) - { - $uname[$i] = $name; -# print sprintf("U%04X $name\n",$i); - } - } -} +sub char_names{} # cf. https://rt.cpan.org/Ticket/Display.html?id=132471 sub output_ucm_page { diff --git a/gnu/usr.bin/perl/cpan/Encode/encoding.pm b/gnu/usr.bin/perl/cpan/Encode/encoding.pm index c3f324d29fa..a01833451fc 100644 --- a/gnu/usr.bin/perl/cpan/Encode/encoding.pm +++ b/gnu/usr.bin/perl/cpan/Encode/encoding.pm @@ -1,6 +1,6 @@ -# $Id: encoding.pm,v 2.22 2018/02/11 05:32:03 dankogai Exp $ +# $Id: encoding.pm,v 3.00 2020/04/19 10:56:28 dankogai Exp $ package encoding; -our $VERSION = sprintf "%d.%02d", q$Revision: 2.22 $ =~ /(\d+)/g; +our $VERSION = sprintf "%d.%02d", q$Revision: 3.00 $ =~ /(\d+)/g; use Encode; use strict; diff --git a/gnu/usr.bin/perl/cpan/Encode/lib/Encode/Guess.pm b/gnu/usr.bin/perl/cpan/Encode/lib/Encode/Guess.pm index 41fc19b7991..87a725d9993 100644 --- a/gnu/usr.bin/perl/cpan/Encode/lib/Encode/Guess.pm +++ b/gnu/usr.bin/perl/cpan/Encode/lib/Encode/Guess.pm @@ -2,7 +2,7 @@ package Encode::Guess; use strict; use warnings; use Encode qw(:fallbacks find_encoding); -our $VERSION = do { my @r = ( q$Revision: 2.7 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; +our $VERSION = do { my @r = ( q$Revision: 2.8 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; my $Canon = 'Guess'; use constant DEBUG => !!$ENV{PERL_ENCODE_DEBUG}; @@ -158,7 +158,7 @@ sub guess { $nline++; } $try{ascii} - or return "Encodings too ambiguous: ", join( " or ", keys %try ); + or return "Encodings too ambiguous: " . join( " or ", keys %try ); return $try{ascii}; } diff --git a/gnu/usr.bin/perl/cpan/Encode/t/enc_utf8.t b/gnu/usr.bin/perl/cpan/Encode/t/enc_utf8.t index be7d487804c..ea8b80d2334 100755 --- a/gnu/usr.bin/perl/cpan/Encode/t/enc_utf8.t +++ b/gnu/usr.bin/perl/cpan/Encode/t/enc_utf8.t @@ -1,4 +1,4 @@ -# $Id: enc_utf8.t,v 2.5 2017/06/10 17:23:50 dankogai Exp $ +# $Id: enc_utf8.t,v 2.6 2019/12/25 09:23:21 dankogai Exp $ # This is the twin of enc_eucjp.t . BEGIN { @@ -8,21 +8,22 @@ BEGIN { exit 0; } unless (find PerlIO::Layer 'perlio') { - print "1..0 # Skip: PerlIO was not built\n"; - exit 0; + print "1..0 # Skip: PerlIO was not built\n"; + exit 0; } if (ord("A") == 193) { - print "1..0 # encoding pragma does not support EBCDIC platforms\n"; - exit(0); + print "1..0 # encoding pragma does not support EBCDIC platforms\n"; + exit(0); } if ($] >= 5.025003 and !$Config{usecperl}){ - print "1..0 # Skip: Perl <=5.25.2 or cperl required\n"; - exit 0; + print "1..0 # Skip: Perl <=5.25.2 or cperl required\n"; + exit 0; } } no warnings "deprecated"; use encoding 'utf8'; +use warnings; my @c = (127, 128, 255, 256); diff --git a/gnu/usr.bin/perl/cpan/Encode/t/whatwg-aliases.json b/gnu/usr.bin/perl/cpan/Encode/t/whatwg-aliases.json deleted file mode 100644 index 4307b0cc486..00000000000 --- a/gnu/usr.bin/perl/cpan/Encode/t/whatwg-aliases.json +++ /dev/null @@ -1,455 +0,0 @@ -[ - { - "encodings": [ - { - "labels": [ - "unicode-1-1-utf-8", - "utf-8", - "utf8" - ], - "name": "UTF-8" - } - ], - "heading": "The Encoding" - }, - { - "encodings": [ - { - "labels": [ - "866", - "cp866", - "csibm866", - "ibm866" - ], - "name": "IBM866" - }, - { - "labels": [ - "csisolatin2", - "iso-8859-2", - "iso-ir-101", - "iso8859-2", - "iso88592", - "iso_8859-2", - "iso_8859-2:1987", - "l2", - "latin2" - ], - "name": "ISO-8859-2" - }, - { - "labels": [ - "csisolatin3", - "iso-8859-3", - "iso-ir-109", - "iso8859-3", - "iso88593", - "iso_8859-3", - "iso_8859-3:1988", - "l3", - "latin3" - ], - "name": "ISO-8859-3" - }, - { - "labels": [ - "csisolatin4", - "iso-8859-4", - "iso-ir-110", - "iso8859-4", - "iso88594", - "iso_8859-4", - "iso_8859-4:1988", - "l4", - "latin4" - ], - "name": "ISO-8859-4" - }, - { - "labels": [ - "csisolatincyrillic", - "cyrillic", - "iso-8859-5", - "iso-ir-144", - "iso8859-5", - "iso88595", - "iso_8859-5", - "iso_8859-5:1988" - ], - "name": "ISO-8859-5" - }, - { - "labels": [ - "arabic", - "asmo-708", - "csiso88596e", - "csiso88596i", - "csisolatinarabic", - "ecma-114", - "iso-8859-6", - "iso-8859-6-e", - "iso-8859-6-i", - "iso-ir-127", - "iso8859-6", - "iso88596", - "iso_8859-6", - "iso_8859-6:1987" - ], - "name": "ISO-8859-6" - }, - { - "labels": [ - "csisolatingreek", - "ecma-118", - "elot_928", - "greek", - "greek8", - "iso-8859-7", - "iso-ir-126", - "iso8859-7", - "iso88597", - "iso_8859-7", - "iso_8859-7:1987", - "sun_eu_greek" - ], - "name": "ISO-8859-7" - }, - { - "labels": [ - "csiso88598e", - "csisolatinhebrew", - "hebrew", - "iso-8859-8", - "iso-8859-8-e", - "iso-ir-138", - "iso8859-8", - "iso88598", - "iso_8859-8", - "iso_8859-8:1988", - "visual" - ], - "name": "ISO-8859-8" - }, - { - "labels": [ - "csiso88598i", - "iso-8859-8-i", - "logical" - ], - "name": "ISO-8859-8-I" - }, - { - "labels": [ - "csisolatin6", - "iso-8859-10", - "iso-ir-157", - "iso8859-10", - "iso885910", - "l6", - "latin6" - ], - "name": "ISO-8859-10" - }, - { - "labels": [ - "iso-8859-13", - "iso8859-13", - "iso885913" - ], - "name": "ISO-8859-13" - }, - { - "labels": [ - "iso-8859-14", - "iso8859-14", - "iso885914" - ], - "name": "ISO-8859-14" - }, - { - "labels": [ - "csisolatin9", - "iso-8859-15", - "iso8859-15", - "iso885915", - "iso_8859-15", - "l9" - ], - "name": "ISO-8859-15" - }, - { - "labels": [ - "iso-8859-16" - ], - "name": "ISO-8859-16" - }, - { - "labels": [ - "cskoi8r", - "koi", - "koi8", - "koi8-r", - "koi8_r" - ], - "name": "KOI8-R" - }, - { - "labels": [ - "koi8-ru", - "koi8-u" - ], - "name": "KOI8-U" - }, - { - "labels": [ - "csmacintosh", - "mac", - "macintosh", - "x-mac-roman" - ], - "name": "macintosh" - }, - { - "labels": [ - "dos-874", - "iso-8859-11", - "iso8859-11", - "iso885911", - "tis-620", - "windows-874" - ], - "name": "windows-874" - }, - { - "labels": [ - "cp1250", - "windows-1250", - "x-cp1250" - ], - "name": "windows-1250" - }, - { - "labels": [ - "cp1251", - "windows-1251", - "x-cp1251" - ], - "name": "windows-1251" - }, - { - "labels": [ - "ansi_x3.4-1968", - "ascii", - "cp1252", - "cp819", - "csisolatin1", - "ibm819", - "iso-8859-1", - "iso-ir-100", - "iso8859-1", - "iso88591", - "iso_8859-1", - "iso_8859-1:1987", - "l1", - "latin1", - "us-ascii", - "windows-1252", - "x-cp1252" - ], - "name": "windows-1252" - }, - { - "labels": [ - "cp1253", - "windows-1253", - "x-cp1253" - ], - "name": "windows-1253" - }, - { - "labels": [ - "cp1254", - "csisolatin5", - "iso-8859-9", - "iso-ir-148", - "iso8859-9", - "iso88599", - "iso_8859-9", - "iso_8859-9:1989", - "l5", - "latin5", - "windows-1254", - "x-cp1254" - ], - "name": "windows-1254" - }, - { - "labels": [ - "cp1255", - "windows-1255", - "x-cp1255" - ], - "name": "windows-1255" - }, - { - "labels": [ - "cp1256", - "windows-1256", - "x-cp1256" - ], - "name": "windows-1256" - }, - { - "labels": [ - "cp1257", - "windows-1257", - "x-cp1257" - ], - "name": "windows-1257" - }, - { - "labels": [ - "cp1258", - "windows-1258", - "x-cp1258" - ], - "name": "windows-1258" - }, - { - "labels": [ - "x-mac-cyrillic", - "x-mac-ukrainian" - ], - "name": "x-mac-cyrillic" - } - ], - "heading": "Legacy single-byte encodings" - }, - { - "encodings": [ - { - "labels": [ - "chinese", - "csgb2312", - "csiso58gb231280", - "gb2312", - "gb_2312", - "gb_2312-80", - "gbk", - "iso-ir-58", - "x-gbk" - ], - "name": "GBK" - }, - { - "labels": [ - "gb18030" - ], - "name": "gb18030" - } - ], - "heading": "Legacy multi-byte Chinese (simplified) encodings" - }, - { - "encodings": [ - { - "labels": [ - "big5", - "big5-hkscs", - "cn-big5", - "csbig5", - "x-x-big5" - ], - "name": "Big5" - } - ], - "heading": "Legacy multi-byte Chinese (traditional) encodings" - }, - { - "encodings": [ - { - "labels": [ - "cseucpkdfmtjapanese", - "euc-jp", - "x-euc-jp" - ], - "name": "EUC-JP" - }, - { - "labels": [ - "csiso2022jp", - "iso-2022-jp" - ], - "name": "ISO-2022-JP" - }, - { - "labels": [ - "csshiftjis", - "ms932", - "ms_kanji", - "shift-jis", - "shift_jis", - "sjis", - "windows-31j", - "x-sjis" - ], - "name": "Shift_JIS" - } - ], - "heading": "Legacy multi-byte Japanese encodings" - }, - { - "encodings": [ - { - "labels": [ - "cseuckr", - "csksc56011987", - "euc-kr", - "iso-ir-149", - "korean", - "ks_c_5601-1987", - "ks_c_5601-1989", - "ksc5601", - "ksc_5601", - "windows-949" - ], - "name": "EUC-KR" - } - ], - "heading": "Legacy multi-byte Korean encodings" - }, - { - "encodings": [ - { - "labels": [ - "csiso2022kr", - "hz-gb-2312", - "iso-2022-cn", - "iso-2022-cn-ext", - "iso-2022-kr" - ], - "name": "replacement" - }, - { - "labels": [ - "utf-16be" - ], - "name": "UTF-16BE" - }, - { - "labels": [ - "utf-16", - "utf-16le" - ], - "name": "UTF-16LE" - }, - { - "labels": [ - "x-user-defined" - ], - "name": "x-user-defined" - } - ], - "heading": "Legacy miscellaneous encodings" - } -] diff --git a/gnu/usr.bin/perl/cpan/Encode/t/whatwg-aliases.t b/gnu/usr.bin/perl/cpan/Encode/t/whatwg-aliases.t deleted file mode 100644 index ffc030bb757..00000000000 --- a/gnu/usr.bin/perl/cpan/Encode/t/whatwg-aliases.t +++ /dev/null @@ -1,66 +0,0 @@ -# This test checks aliases support based on the list in the -# WHATWG Encoding Living Standard -# -# https://encoding.spec.whatwg.org/ -# -# The input of this test is the file whatwg-aliases.json downloaded from -# https://encoding.spec.whatwg.org/encodings.json -# -# To run: -# AUTHOR_TESTING=1 prove -l t/whatwg-aliases.t - - -use Test::More - ($ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING}) - ? 'no_plan' - : (skip_all => 'For maintainers only'); -use Encode 'find_encoding'; -use JSON::PP 'decode_json'; -use File::Spec; -use FindBin; - -my $encodings = decode_json(do { - # https://encoding.spec.whatwg.org/encodings.json - open my $f, '<', File::Spec->catdir($FindBin::Bin, 'whatwg-aliases.json'); - local $/; - <$f> -}); - -my %IGNORE = map { $_ => '' } qw( - replacement - utf8 -); - -my %TODO = ( - 'ISO-8859-8-I' => 'Not supported', - 'gb18030' => 'Not supported', - '866' => 'Not supported', - 'x-user-defined' => 'Not supported', - # ... -); - -for my $section (@$encodings) { - for my $enc (@{$section->{encodings}}) { - - my $name = $enc->{name}; - - next if exists $IGNORE{$name}; - - local $TODO = $TODO{$name} if exists $TODO{$name}; - - my $encoding = find_encoding($name); - isa_ok($encoding, 'Encode::Encoding', $name); - - for my $label (@{$enc->{labels}}) { - local $TODO = $TODO{$label} if exists $TODO{$label}; - - my $e = find_encoding($label); - if (isa_ok($e, 'Encode::Encoding', $label)) { - next if exists $IGNORE{$label}; - is($e->name, $encoding->name, "$label ->name is $name") - } - } - } -} - -done_testing; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm b/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm index 7bcd941bd2a..047c007145e 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-Install/lib/ExtUtils/Install.pm @@ -108,7 +108,6 @@ $INSTALL_QUIET = 1 $ENV{MAKEFLAGS} =~ /\b(s|silent|quiet)\b/); my $Curdir = File::Spec->curdir; -my $Perm_Dir = $ENV{PERL_CORE} ? 0770 : 0755; sub _estr(@) { return join "\n",'!' x 72,@_,'!' x 72,''; @@ -800,7 +799,7 @@ sub install { #XXX OS-SPECIFIC _chdir($cwd); } foreach my $targetdir (sort keys %check_dirs) { - _mkpath( $targetdir, 0, $Perm_Dir, $verbose, $dry_run ); + _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); } foreach my $found (@found_files) { my ($diff, $ffd, $origfile, $mode, $size, $atime, $mtime, @@ -814,7 +813,7 @@ sub install { #XXX OS-SPECIFIC $targetfile= _unlink_or_rename( $targetfile, 'tryhard', 'install' ) unless $dry_run; } elsif ( ! -d $targetdir ) { - _mkpath( $targetdir, 0, $Perm_Dir, $verbose, $dry_run ); + _mkpath( $targetdir, 0, 0755, $verbose, $dry_run ); } print "Installing $targetfile\n"; @@ -854,7 +853,7 @@ sub install { #XXX OS-SPECIFIC if ($pack{'write'}) { $dir = install_rooted_dir(dirname($pack{'write'})); - _mkpath( $dir, 0, $Perm_Dir, $verbose, $dry_run ); + _mkpath( $dir, 0, 0755, $verbose, $dry_run ); print "Writing $pack{'write'}\n" if $verbose; $packlist->write(install_rooted_file($pack{'write'})) unless $dry_run; } @@ -1200,7 +1199,7 @@ environment variable will silence this output. sub pm_to_blib { my($fromto,$autodir,$pm_filter) = @_; - _mkpath($autodir,0,$Perm_Dir) if defined $autodir; + _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; @@ -1223,7 +1222,7 @@ sub pm_to_blib { # we wont try hard here. its too likely to mess things up. forceunlink($to); } else { - _mkpath(dirname($to),0,$Perm_Dir); + _mkpath(dirname($to),0,0755); } if ($need_filtering) { run_filter($pm_filter, $from, $to); diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm index 4924c81fbea..c5101c37b7d 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command.pm @@ -7,8 +7,8 @@ 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.34'; -$VERSION = eval $VERSION; +$VERSION = '7.44'; +$VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; my $Is_VMS_mode = $Is_VMS; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm index 0323ed40fa7..484fa5b69d5 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Command/MM.pm @@ -10,8 +10,8 @@ our @ISA = qw(Exporter); our @EXPORT = qw(test_harness pod2man perllocal_install uninstall warn_if_old_packlist test_s cp_nonempty); -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; my $Is_VMS = $^O eq 'VMS'; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm index 700cb7347ab..deec54d2883 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist.pm @@ -2,8 +2,8 @@ package ExtUtils::Liblist; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; use File::Spec; require ExtUtils::Liblist::Kid; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm index a6da855862f..e040a899edb 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Liblist/Kid.pm @@ -11,8 +11,8 @@ use 5.006; use strict; use warnings; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44_01'; +$VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; use Cwd 'cwd'; @@ -49,8 +49,10 @@ sub _unix_os2_ext { # $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 ) = split " ", $Config{'libpth'} || ''; + my ( @libpath ) = Text::ParseWords::quotewords( '\s+', 0, $Config{'libpth'} || '' ); my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen ); my ( @libs, %libs_seen ); my ( $fullname, @fullname ); @@ -63,7 +65,7 @@ sub _unix_os2_ext { $potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g; } - foreach my $thislib ( split ' ', $potential_libs ) { + foreach my $thislib ( Text::ParseWords::quotewords( '\s+', 0, $potential_libs) ) { my ( $custom_name ) = ''; # Handle possible linker path arguments. @@ -88,6 +90,7 @@ sub _unix_os2_ext { $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; @@ -171,6 +174,10 @@ sub _unix_os2_ext { && -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" ) ) { @@ -207,7 +214,8 @@ sub _unix_os2_ext { # Now update library lists # what do we know about this library... - my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ ); + # "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 diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm index b2c360bca3a..f1ffa91849e 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM.pm @@ -3,8 +3,8 @@ package ExtUtils::MM; use strict; use ExtUtils::MakeMaker::Config; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::Liblist; require ExtUtils::MakeMaker; @@ -23,9 +23,9 @@ ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass B<FOR INTERNAL USE ONLY> -ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically +ExtUtils::MM is a subclass of L<ExtUtils::MakeMaker> which automatically chooses the appropriate OS specific subclass for you -(ie. ExtUils::MM_Unix, etc...). +(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/). diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm index b114ee49d30..654e2213594 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_AIX.pm @@ -1,8 +1,8 @@ package ExtUtils::MM_AIX; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; require ExtUtils::MM_Unix; @@ -19,10 +19,10 @@ ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix =head1 DESCRIPTION -This is a subclass of ExtUtils::MM_Unix which contains functionality for +This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for AIX. -Unless otherwise stated it works just like ExtUtils::MM_Unix +Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods @@ -50,7 +50,9 @@ sub xs_dlsyms_ext { sub xs_dlsyms_arg { my($self, $file) = @_; - return qq{-bE:${file}}; + my $arg = qq{-bE:${file}}; + $arg = '-Wl,'.$arg if $Config{lddlflags} =~ /-Wl,-bE:/; + return $arg; } sub init_others { diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm index f0106a44c9d..4f4b252c261 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Any.pm @@ -1,8 +1,8 @@ package ExtUtils::MM_Any; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; use Carp; use File::Spec; @@ -46,7 +46,7 @@ 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> ExtUtils::MM_Unix. This is a +Subclass off of ExtUtils::MM_Any I<and> L<ExtUtils::MM_Unix>. This is a temporary solution. B<THIS MAY BE TEMPORARY!> @@ -195,7 +195,7 @@ sub can_redirect_error { my $is_dmake = $self->is_make_type('dmake'); -Returns true if C<<$self->make>> is the given type; possibilities are: +Returns true if C<< $self->make >> is the given type; possibilities are: gmake GNU make dmake @@ -1167,7 +1167,7 @@ MAKE_FRAG $mm->_fix_metadata_before_conversion( \%metadata ); -Fixes errors in the metadata before it's handed off to CPAN::Meta for +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. @@ -2214,7 +2214,9 @@ sub init_INSTALL_from_INSTALL_BASE { my $key = "INSTALL".$dir.$uc_thing; $install{$key} ||= - $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); + ($thing =~ /^man.dir$/ and not $Config{lc $key}) + ? 'none' + : $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); } } @@ -2416,7 +2418,7 @@ 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 ExtUtils::MakeMaker. +WriteMakefile() documented in L<ExtUtils::MakeMaker>. =cut @@ -2767,7 +2769,7 @@ END =head2 File::Spec wrappers -ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here +ExtUtils::MM_Any is a subclass of L<File::Spec>. The methods noted here override File::Spec. @@ -2908,8 +2910,7 @@ 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" - unless $ENV{PERL_CORE}; + 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 ''; } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm index 6fb7911390c..d62a7d132f3 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_BeOS.pm @@ -12,7 +12,7 @@ ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 DESCRIPTION -See ExtUtils::MM_Unix for a documentation of the methods provided +See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. @@ -26,8 +26,8 @@ require ExtUtils::MM_Any; require ExtUtils::MM_Unix; our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; =item os_flavor @@ -58,6 +58,8 @@ sub init_linker { =back +=cut + 1; __END__ diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm index 934e65f913d..2052c7c3aa3 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Cygwin.pm @@ -9,8 +9,8 @@ require ExtUtils::MM_Unix; require ExtUtils::MM_Win32; our @ISA = qw( ExtUtils::MM_Unix ); -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; =head1 NAME @@ -23,7 +23,7 @@ ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 DESCRIPTION -See ExtUtils::MM_Unix for a documentation of the methods provided there. +See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. =over 4 @@ -86,7 +86,7 @@ sub init_linker { if ($Config{useshrplib} eq 'true') { my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}"; - if( $] >= 5.006002 ) { + if( "$]" >= 5.006002 ) { $libperl =~ s/(dll\.)?a$/dll.a/; } $self->{PERL_ARCHIVE} = $libperl; @@ -104,8 +104,8 @@ sub init_linker { Determine whether a file is native to Cygwin by checking whether it resides inside the Cygwin installation (using Windows paths). If so, -use C<ExtUtils::MM_Unix> to determine if it may be a command. -Otherwise use the tests from C<ExtUtils::MM_Win32>. +use L<ExtUtils::MM_Unix> to determine if it may be a command. +Otherwise use the tests from L<ExtUtils::MM_Win32>. =cut @@ -158,16 +158,6 @@ sub install { $s; } -=item all_target - -Build man pages, too - -=cut - -sub all_target { - ExtUtils::MM_Unix::all_target(shift); -} - =back =cut diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm index 33a8b199df3..d5c66deb895 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_DOS.pm @@ -2,8 +2,8 @@ package ExtUtils::MM_DOS; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; @@ -21,10 +21,10 @@ ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix =head1 DESCRIPTION -This is a subclass of ExtUtils::MM_Unix which contains functionality +This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for DOS. -Unless otherwise stated, it works just like ExtUtils::MM_Unix +Unless otherwise stated, it works just like ExtUtils::MM_Unix. =head2 Overridden methods diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm index f5359dca095..9ca9d2c6214 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Darwin.pm @@ -7,8 +7,8 @@ BEGIN { our @ISA = qw( ExtUtils::MM_Unix ); } -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; =head1 NAME @@ -21,7 +21,7 @@ ExtUtils::MM_Darwin - special behaviors for OS X =head1 DESCRIPTION -See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documentation on the +See L<ExtUtils::MM_Unix> or L<ExtUtils::MM_Any> for documentation on the methods overridden here. =head2 Overridden Methods diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm index 5646ae33406..b10e3f9cfba 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_MacOS.pm @@ -2,8 +2,8 @@ package ExtUtils::MM_MacOS; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; sub new { die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker'; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm index c88c4fabe98..a9e2e1af542 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_NW5.pm @@ -10,7 +10,7 @@ ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 DESCRIPTION -See ExtUtils::MM_Unix for a documentation of the methods provided +See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. @@ -22,8 +22,8 @@ use strict; use ExtUtils::MakeMaker::Config; use File::Basename; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Win32; our @ISA = qw(ExtUtils::MM_Win32); @@ -192,7 +192,7 @@ MAKE_FRAG } # Reconstruct the X.Y.Z version. my $version = join '.', map { sprintf "%d", $_ } - $] =~ /(\d)\.(\d{3})(\d{2})/; + "$]" =~ /(\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 $@ diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm index dfa6dca4916..300f091c351 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS2.pm @@ -5,8 +5,8 @@ use strict; use ExtUtils::MakeMaker qw(neatvalue); use File::Spec; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; @@ -24,7 +24,7 @@ ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 DESCRIPTION -See ExtUtils::MM_Unix for a documentation of the methods provided +See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm index 362d7d920fb..3e6f6d06995 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_QNX.pm @@ -1,8 +1,8 @@ package ExtUtils::MM_QNX; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); @@ -19,10 +19,10 @@ ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix =head1 DESCRIPTION -This is a subclass of ExtUtils::MM_Unix which contains functionality for +This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for QNX. -Unless otherwise stated it works just like ExtUtils::MM_Unix +Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm index cc95c415e81..4201585e326 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_UWIN.pm @@ -1,8 +1,8 @@ package ExtUtils::MM_UWIN; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); @@ -19,10 +19,10 @@ ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix =head1 DESCRIPTION -This is a subclass of ExtUtils::MM_Unix which contains functionality for +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 +Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm index 45ab3e85bc4..ce1292740f0 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Unix.pm @@ -14,8 +14,8 @@ use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); # If we make $VERSION an our variable parse_version() breaks use vars qw($VERSION); -$VERSION = '7.34'; -$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval] +$VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Any; our @ISA = qw(ExtUtils::MM_Any); @@ -37,6 +37,10 @@ BEGIN { 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 { @@ -54,15 +58,15 @@ ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker =head1 SYNOPSIS -C<require ExtUtils::MM_Unix;> + require ExtUtils::MM_Unix; =head1 DESCRIPTION The methods provided by this package are designed to be used in -conjunction with ExtUtils::MakeMaker. When MakeMaker writes a +conjunction with L<ExtUtils::MakeMaker>. When MakeMaker writes a Makefile, it creates one or more objects that inherit their methods -from a package C<MM>. MM itself doesn't provide any methods, but it -ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating +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 @@ -89,8 +93,8 @@ 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 MM_Any. If you can't find -something that used to be in here, look in MM_Any. +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 @@ -132,6 +136,10 @@ sub c_o { 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/; @@ -151,8 +159,11 @@ 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 \$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n"; + push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags " + .($dbgout?"$dbgout ":'') + ."\$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n"; } return join "", @m; } @@ -170,6 +181,16 @@ sub xs_obj_opt { "-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) @@ -462,12 +483,20 @@ 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_INCDEP)$(DFSEP)config.h -} if -e $self->catfile( $self->{PERL_INC}, 'config.h' ); +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 @@ -940,6 +969,7 @@ sub dynamic_lib { 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. @@ -1091,7 +1121,6 @@ Finds the executables PERL and FULLPERL sub find_perl { my($self, $ver, $names, $dirs, $trace) = @_; - if ($trace >= 2){ print "Looking for perl $ver by these names: @$names @@ -1244,12 +1273,15 @@ sub _fixin_replace_shebang { my ( $self, $file, $line ) = @_; # Now figure out the interpreter name. - my ( $cmd, $arg ) = split ' ', $line, 2; - $cmd =~ s!^.*/!!; + my ( $origcmd, $arg ) = split ' ', $line, 2; + (my $cmd = $origcmd) =~ s!^.*/!!; # Now look (in reverse) for interpreter in absolute PATH (unless perl). my $interpreter; - if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) { + 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,^\#!,,; @@ -1271,6 +1303,24 @@ sub _fixin_replace_shebang { $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. @@ -1456,12 +1506,13 @@ sub init_MANPODS { foreach my $num (1,3) { my $installdirs = uc $self->{INSTALLDIRS}; $installdirs = '' if $installdirs eq 'PERL'; - my $mandir = $self->_expand_macros( - $self->{ "INSTALL${installdirs}MAN${num}DIR" } ); + 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 =~ /\b(?:man|cat)$_$/ ) { + if ( $mandir =~ /^(?:man|cat)$_$/ ) { $section = $_; last; } @@ -2062,6 +2113,11 @@ sub init_PERL { # 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}; @@ -2084,6 +2140,11 @@ sub init_PERL { # 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}; @@ -2153,8 +2214,7 @@ Called by init_main. Initializes PERL_* sub init_PERM { my($self) = shift; - my $perm_dir = $self->{PERL_CORE} ? 770 : 755; - $self->{PERM_DIR} = $perm_dir unless defined $self->{PERM_DIR}; + $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}; @@ -2188,6 +2248,7 @@ sub init_xs { 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)"; @@ -2758,14 +2819,14 @@ sub _find_static_libs { 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 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` =~ /\bboot_/; + return `nm $libfile 2>$devnull` =~ /\b_?boot_/; } =item makefile (o) @@ -2892,7 +2953,7 @@ sub parse_abstract { } close $fh; - if ( $pod_encoding and !( $] < 5.008 or !$Config{useperlio} ) ) { + 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 @@ -2914,7 +2975,7 @@ 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 +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. @@ -3171,7 +3232,7 @@ PPD_PERLVERS } my $archname = $Config{archname}; - if ($] >= 5.008) { + if ("$]" >= 5.008) { # 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 @@ -3288,9 +3349,11 @@ sub processPL { my $m = ''; foreach my $plfile (sort keys %$pl_files) { - my $list = ref($pl_files->{$plfile}) - ? $pl_files->{$plfile} - : [$pl_files->{$plfile}]; + 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} ) { @@ -3314,13 +3377,27 @@ sub processPL { $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 - \$($perlrun) $plfile $target +$target :: $plfile $pm_dep $extra_inputs + \$($perlrun) $plfile $target $extra_inputs MAKE_FRAG } @@ -3452,7 +3529,7 @@ sub escape_newlines { =item max_exec_len -Using POSIX::ARG_MAX. Otherwise falling back to 4096. +Using L<POSIX>::ARG_MAX. Otherwise falling back to 4096. =cut @@ -3977,13 +4054,15 @@ 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', $m_o unless $self->is_make_type('dmake'); + $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) $*.c %s + $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) %s$*.c %s EOF if ($self->{XSMULTI}) { for my $ext ($self->_xs_list_basenames) { @@ -3997,16 +4076,17 @@ EOF $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC'); my $define = '$(DEFINE)'; $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE'); - # 1 2 3 4 - $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $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 $*.c %3$s + %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; } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm index b6fbccfe349..fbf5f9ee265 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VMS.pm @@ -15,8 +15,8 @@ BEGIN { use File::Basename; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Any; require ExtUtils::MM_Unix; @@ -38,7 +38,7 @@ ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 DESCRIPTION -See ExtUtils::MM_Unix for a documentation of the methods provided +See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. @@ -87,7 +87,7 @@ sub ext { 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 ExtUtils::MM_Unix +of why this method overrides the MM_Unix method; see the L<ExtUtils::MM_Unix> documentation for more details. =over 4 @@ -251,7 +251,8 @@ sub find_perl { =item _fixin_replace_shebang (override) -Helper routine for MM->fixin(), overridden because there's no such thing as an +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. @@ -587,9 +588,10 @@ sub constants { # Cleanup paths for directories in MMS macros. foreach my $macro ( qw [ INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB - PERL_LIB PERL_ARCHLIB + PERL_LIB PERL_ARCHLIB PERL_ARCHLIBDEP PERL_INC PERL_SRC ], - (map { 'INSTALL'.$_ } $self->installvars) + (map { 'INSTALL'.$_ } $self->installvars), + (map { 'DESTINSTALL'.$_ } $self->installvars) ) { next unless defined $self->{$macro}; @@ -1487,8 +1489,8 @@ uninstall_from_vendordirs :: =item perldepend (override) Use VMS-style syntax for files; it's cheaper to just do it directly here -than to have the MM_Unix method call C<catfile> repeatedly. Also, if -we have to rebuild Config.pm, use MM[SK] to do it. +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 @@ -2081,7 +2083,7 @@ sub init_linker { Eliminate the macros in the output to the MMS/MMK file. -(File::Spec::VMS used to do this for us, but it's being removed) +(L<File::Spec::VMS> used to do this for us, but it's being removed) =cut @@ -2120,7 +2122,7 @@ 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 -File::Spec::VMS is deprecated. +L<File::Spec::VMS> is deprecated. =cut @@ -2182,7 +2184,7 @@ 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 -File::Spec::VMS is deprecated. +L<File::Spec::VMS> is deprecated. =cut diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm index 66c7ff74722..dea49e1a566 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_VOS.pm @@ -1,8 +1,8 @@ package ExtUtils::MM_VOS; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Unix; our @ISA = qw(ExtUtils::MM_Unix); @@ -19,10 +19,10 @@ ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix =head1 DESCRIPTION -This is a subclass of ExtUtils::MM_Unix which contains functionality for +This is a subclass of L<ExtUtils::MM_Unix> which contains functionality for VOS. -Unless otherwise stated it works just like ExtUtils::MM_Unix +Unless otherwise stated it works just like ExtUtils::MM_Unix. =head2 Overridden methods diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm index 43c974d5b41..3db0f45260f 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win32.pm @@ -13,7 +13,7 @@ ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker =head1 DESCRIPTION -See ExtUtils::MM_Unix for a documentation of the methods provided +See L<ExtUtils::MM_Unix> for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. @@ -27,8 +27,8 @@ 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.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; $ENV{EMXSHELL} = 'sh'; # to run `commands` @@ -77,7 +77,7 @@ Changes the path separator with . sub replace_manpage_separator { my($self,$man) = @_; - $man =~ s,/+,.,g; + $man =~ s,[/\\]+,.,g; $man; } @@ -143,7 +143,7 @@ sub init_tools { $self->{DEV_NULL} ||= '> NUL'; $self->{FIXIN} ||= $self->{PERL_CORE} ? - "\$(PERLRUN) $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" : + "\$(PERLRUN) -I$self->{PERL_SRC}\\cpan\\ExtUtils-PL2Bat\\lib $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" : 'pl2bat.bat'; $self->SUPER::init_tools; @@ -506,7 +506,7 @@ sub quote_literal { $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\" $text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\" $text =~ s{(?<!\\)"}{\\"}g; # " -> \" - $text = qq{"$text"} if $text =~ /[ \t]/; + $text = qq{"$text"} if $text =~ /[ \t#]/; # hash because gmake 4.2.1 # Apply the Command Prompt parsing rules (cmd.exe) my @text = split /("[^"]*")/, $text; @@ -595,6 +595,16 @@ 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 diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm index 85a80c638b0..4220e52dc37 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_Win95.pm @@ -2,8 +2,8 @@ package ExtUtils::MM_Win95; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require ExtUtils::MM_Win32; our @ISA = qw(ExtUtils::MM_Win32); @@ -21,7 +21,7 @@ ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X =head1 DESCRIPTION -This is a subclass of ExtUtils::MM_Win32 containing changes necessary +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 diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm index a193f3a045c..957ab164592 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MY.pm @@ -3,8 +3,8 @@ package ExtUtils::MY; use strict; require ExtUtils::MM; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; our @ISA = qw(ExtUtils::MM); { @@ -30,7 +30,7 @@ ExtUtils::MY - ExtUtils::MakeMaker subclass for customization B<FOR INTERNAL USE ONLY> -ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your +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. diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm index 90d9eac49c1..6dceb98be41 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker.pm @@ -24,8 +24,8 @@ 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.34'; -$VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval] +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; # Emulate something resembling CVS $Revision$ (our $Revision = $VERSION) =~ s{_}{}; @@ -316,7 +316,7 @@ sub full_setup { 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 + 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 @@ -398,7 +398,7 @@ sub full_setup { ); # 5.5.3 doesn't have any concept of vendor libs - push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006; + push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if "$]" >= 5.006; foreach my $item (@attrib_help){ $Recognized_Att_Keys{$item} = 1; @@ -534,7 +534,7 @@ sub new { # simulate "use warnings FATAL => 'all'" for vintage perls die @_; }; - !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $] + !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= "$]" }; if (!$perl_version_ok) { if (!defined $perl_version_ok) { @@ -693,6 +693,7 @@ END } 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); @@ -702,7 +703,8 @@ END } if ($self->{PARENT}) { $self->{PARENT}->{CHILDREN}->{$newclass} = $self; - foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE LD OPTIMIZE)) { + 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}) { @@ -1264,7 +1266,7 @@ sub write_file_via_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; + 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: $!"; @@ -1427,6 +1429,8 @@ 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>. @@ -2599,6 +2603,20 @@ 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 @@ -3023,7 +3041,8 @@ be linked. =item postamble -Anything put here will be passed to MY::postamble() if you have one. +Anything put here will be passed to +L<MY::postamble()|ExtUtils::MM_Any/postamble (o)> if you have one. =item realclean @@ -3070,7 +3089,7 @@ or you can edit the default by saying something like: 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 ExtUtils::Embed which is a collection of utilities +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 @@ -3134,7 +3153,7 @@ override or create an attribute you would say something like =head2 Distribution Support For authors of extensions MakeMaker provides several Makefile -targets. Most of the support comes from the ExtUtils::Manifest module, +targets. Most of the support comes from the L<ExtUtils::Manifest> module, where additional documentation can be found. =over 4 @@ -3142,13 +3161,13 @@ where additional documentation can be found. =item make distcheck reports which files are below the build directory but not in the -MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for +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 ExtUtils::Manifest::skipcheck() for +C<MANIFEST.SKIP> file (See L<ExtUtils::Manifest/skipcheck> for details) =item make distclean @@ -3165,7 +3184,7 @@ C<*.bak>, C<*.old> and C<*.orig> =item make manifest rewrites the MANIFEST file, adding all remaining files found (See -ExtUtils::Manifest::mkmanifest() for details) +L<ExtUtils::Manifest/mkmanifest> for details) =item make distdir @@ -3365,11 +3384,16 @@ Same as the PERL_CORE parameter. The parameter overrides this. =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 is easier to +not rely on make or any other external utility. It may be easier to extend to suit your needs. -L<Module::Install> is a wrapper around MakeMaker which adds features -not normally available. +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. @@ -3378,10 +3402,18 @@ 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. +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<Dist::Zilla> makes it easy for the module author to create MakeMaker-based -distributions with lots of bells and whistles. +L<Minilla> is a minimal authoring tool that does the same things as +Dist::Milla without the overhead of Dist::Zilla. =head1 AUTHORS diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm index 0d4f8b1e611..5c93f0afdfb 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Config.pm @@ -2,8 +2,8 @@ package ExtUtils::MakeMaker::Config; use strict; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; use Config (); diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod index 0ceb4f766ec..a82c53b00c0 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/FAQ.pod @@ -1,7 +1,7 @@ package ExtUtils::MakeMaker::FAQ; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; 1; __END__ @@ -12,7 +12,7 @@ ExtUtils::MakeMaker::FAQ - Frequently Asked Questions About MakeMaker =head1 DESCRIPTION -FAQs, tricks and tips for C<ExtUtils::MakeMaker>. +FAQs, tricks and tips for L<ExtUtils::MakeMaker>. =head2 Module Installation @@ -84,7 +84,8 @@ installation. =item How do I keep from installing man pages? Recent versions of MakeMaker will only install man pages on Unix-like -operating systems. +operating systems by default. To generate manpages on non-Unix operating +systems, make the "manifypods" target. For an individual module: @@ -568,7 +569,7 @@ What most people need to know (superclasses on top.) | MY -The object actually used is of the class MY which allows you to +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. @@ -599,24 +600,24 @@ NOTE: Yes, this is a mess. See L<http://archive.develooper.com/makemaker@perl.org/msg00134.html> for some history. -NOTE: When ExtUtils::MM is loaded it chooses a superclass for MM from +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 ExtUtils::MM_Any chosen based on your operating system. +modules except L<ExtUtils::MM_Any> chosen based on your operating system. NOTE: The main object used by MakeMaker is a PACK### object, *not* -ExtUtils::MakeMaker. It is, effectively, a subclass of MY, -ExtUtils::Makemaker, ExtUtils::Liblist and ExtUtils::MM_{Current OS} +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 MY are simply copied into PACK### rather than -MY being a superclass of PACK###. I don't remember the rationale. +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: ExtUtils::Liblist should be removed from the inheritance hiearchy +NOTE: L<ExtUtils::Liblist> should be removed from the inheritance hiearchy and simply be called as functions. -NOTE: Modules like File::Spec and Exporter have been omitted for clarity. +NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity. =head2 The MM_* hierarchy @@ -631,12 +632,13 @@ NOTE: Modules like File::Spec and Exporter have been omitted for clarity. | | MM_Any -NOTE: Each direct MM_Unix subclass is also an MM_Any subclass. This +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 File::Spec and Exporter have been omitted for clarity. +NOTE: Modules like L<File::Spec> and L<Exporter> have been omitted for clarity. =head1 PATCHING diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm index 6d97df06f61..8931826b590 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Locale.pm @@ -1,8 +1,8 @@ package ExtUtils::MakeMaker::Locale; use strict; -our $VERSION = "7.34"; -$VERSION = eval $VERSION; +our $VERSION = "7.44"; +$VERSION =~ tr/_//d; use base 'Exporter'; our @EXPORT_OK = qw( @@ -47,7 +47,10 @@ sub _init { unless (defined &GetInputCP) { eval { require Win32; - eval { Win32::GetConsoleCP() }; + 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; @@ -96,6 +99,13 @@ sub _init { $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"; } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod index b49e4448330..6365e4be665 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/Tutorial.pod @@ -1,7 +1,7 @@ package ExtUtils::MakeMaker::Tutorial; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; =head1 NAME @@ -205,7 +205,8 @@ 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::Install>, L<PAR> +L<ExtUtils::ModuleMaker>, L<Module::Starter>, L<Minilla::Tutorial>, +L<Dist::Milla::Tutorial>, L<Dist::Zilla::Starter> =cut diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm index c59be1eeee7..c94c855c54b 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version.pm @@ -15,8 +15,8 @@ use strict; use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); -$VERSION = '7.34'; -$VERSION = eval $VERSION; +$VERSION = '7.44'; +$VERSION =~ tr/_//d; $CLASS = 'version'; { @@ -35,7 +35,7 @@ $CLASS = 'version'; *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION; *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp; *version::new = \&ExtUtils::MakeMaker::version::vpp::new; - if ($] >= 5.009000) { + if ("$]" >= 5.009000) { no strict 'refs'; *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify; *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm index f0eb14eacb4..7cfed5ba88a 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MakeMaker/version/regex.pm @@ -10,8 +10,8 @@ use strict; use vars qw($VERSION $CLASS $STRICT $LAX); -$VERSION = '7.34'; -$VERSION = eval $VERSION; +$VERSION = '7.44'; +$VERSION =~ tr/_//d; #--------------------------------------------------------------------------# # Version regexp components diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm index 0d4c1a20909..a11a950c1b6 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mkbootstrap.pm @@ -3,8 +3,8 @@ package ExtUtils::Mkbootstrap; # There's just too much Dynaloader incest here to turn on strict vars. use strict 'refs'; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; require Exporter; our @ISA = ('Exporter'); @@ -84,7 +84,7 @@ ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader =head1 SYNOPSIS -C<Mkbootstrap> + Mkbootstrap =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm index 0ec5f9dbdfd..9279b6b7852 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/Mksymlists.pm @@ -10,8 +10,8 @@ use Config; our @ISA = qw(Exporter); our @EXPORT = qw(&Mksymlists); -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; sub Mksymlists { my(%spec) = @_; @@ -148,7 +148,7 @@ sub _write_win32 { # 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) { + unless("$]" >= 5.016) { if ($Config::Config{'cc'} =~ /^bcc/i) { push @syms, "_$_", "$_ = _$_" for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm index 01b46ee45a5..1ccaf776a03 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/testlib.pm @@ -3,8 +3,8 @@ package ExtUtils::testlib; use strict; use warnings; -our $VERSION = '7.34'; -$VERSION = eval $VERSION; +our $VERSION = '7.44'; +$VERSION =~ tr/_//d; use Cwd; use File::Spec; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Unix.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Unix.t index 388bc545cd2..62b291c770e 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Unix.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Unix.t @@ -12,7 +12,7 @@ BEGIN { plan skip_all => 'Non-Unix platform'; } else { - plan tests => 113; + plan tests => 114; } } @@ -150,8 +150,18 @@ is ($t->has_link_code(),1); is ($t->{HAS_LINK_CODE},1); ############################################################################### # libscan -is ($t->libscan('Readme.pod'), '', 'libscan excludes base Readme.pod'); -is ($t->libscan('README.pod'), '', 'libscan excludes base README.pod'); +{ + # suppress noisy & unnecessary "WARNING: Older versions of ExtUtils::MakeMaker may errantly install README.pod..." + my @warnings = (); + local $SIG{__WARN__} = sub { push @warnings, shift; }; + is ($t->libscan('Readme.pod'), '', 'libscan excludes base Readme.pod'); + is ($t->libscan('README.pod'), '', 'libscan excludes base README.pod'); + # verify that suppressed warnings are present + isnt (scalar(@warnings), 0); + if (scalar(@warnings)) { + note (sprintf('suppressed warnings: [ "%s" ]', do { my $s = join(q/" , "/, @warnings); $s =~ s/([^[:print:]])/sprintf('\x{%x}', ord($1))/egmsx; $s; })); + } +} is ($t->libscan('lib/Foo/README.pod'), 'lib/Foo/README.pod', 'libscan accepts README.pod in a subdirectory'); is ($t->libscan('foo/RCS/bar'), '', 'libscan on RCS'); is ($t->libscan('CVS/bar/car'), '', 'libscan on CVS'); diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/PL_FILES.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/PL_FILES.t index 51aed5e5d03..7e627db543c 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/PL_FILES.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/PL_FILES.t @@ -13,7 +13,7 @@ use ExtUtils::MM; use Test::More !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'} ? (skip_all => "cross-compiling and make not available") - : (tests => 10); + : (tests => 12); use File::Spec; use File::Temp qw[tempdir]; use File::Path; @@ -36,6 +36,8 @@ WriteMakefile( NAME => 'PL::Module', PL_FILES => { 'single.PL' => 'single.out', 'multi.PL' => [qw(1.out 2.out)], + 'single-in.PL' => { 'single-in.out' => 'single.in' }, + 'multi-in.PL' => { 'multi-in.out' => [qw(1.in 2.in)] }, 'Bar_pm.PL' => '$(INST_LIB)/PL/Bar.pm', 'Bar2.pm.PL' => 'Bar2.pm', }, @@ -53,6 +55,11 @@ END 'multi.PL' => _gen_pl_files(), 'Bar_pm.PL' => _gen_pm_files(), 'Bar2.pm.PL' => _gen_pm_files(), + 'single-in.PL' => _gen_pm_files(1), + 'multi-in.PL' => _gen_pm_files(2), + 'single.in' => '', + '1.in' => '', + '2.in' => '', 'lib/PL/Foo.pm' => <<'END', # Module to load to ensure PL_FILES have blib in @INC. package PL::Foo; @@ -76,7 +83,11 @@ cmp_ok( $?, '==', 0 ); my $make_out = run("$make"); is( $?, 0 ) || diag $make_out; -foreach my $file (qw(single.out 1.out 2.out blib/lib/PL/Bar.pm blib/lib/PL/Bar2.pm)) { +foreach my $file (qw( + single.out 1.out 2.out + single-in.out multi-in.out + blib/lib/PL/Bar.pm blib/lib/PL/Bar2.pm +)) { ok( -e $file, "$file was created" ); } @@ -105,7 +116,8 @@ END } sub _gen_pm_files { - my $test = <<'END'; + my $inputs = (shift || 0) + 1; + my $test = sprintf <<'END', $inputs; #!/usr/bin/perl -w # Ensure we do NOT have blib in @INC when building a module @@ -114,7 +126,7 @@ eval { require PL::Foo; }; # Had a bug where PL_FILES weren't sent the file to generate die "argv empty\n" unless @ARGV; -die "too many in argv: @ARGV\n" unless @ARGV == 1; +die "wrong number in argv: @ARGV\n" unless @ARGV == %d; my $file = $ARGV[0]; open OUT, ">$file" or die $!; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/basic.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/basic.t index 534bf219f6c..7c87c752128 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/basic.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/basic.t @@ -35,7 +35,11 @@ my $Is_VMS = $^O eq 'VMS'; my $OLD_CP; # crude but... my $w32worked; # or whether we had to fallback to chcp if ($^O eq "MSWin32") { - eval { require Win32; $w32worked = $OLD_CP = Win32::GetConsoleCP() }; + eval { + require Win32; + local $SIG{__WARN__} = sub {} if ( "$]" < 5.014 ); # suppress deprecation warning for inherited AUTOLOAD of Win32::GetConsoleCP() + $w32worked = $OLD_CP = Win32::GetConsoleCP(); + }; $OLD_CP = $1 if !$w32worked and qx(chcp) =~ /(\d+)$/ and $? == 0; if (defined $OLD_CP) { if ($w32worked) { @@ -128,7 +132,7 @@ like( $ppd_html, qr{^\s*<REQUIRE NAME="strict::" />}m, ' <REQUIRE>' ); unlike( $ppd_html, qr{^\s*<REQUIRE NAME="warnings::" />}m, 'no <REQUIRE> for build_require' ); my $archname = $Config{archname}; -if( $] >= 5.008 ) { +if( "$]" >= 5.008 ) { # XXX This is a copy of the internal logic, so it's not a great test $archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}"; } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/build_man.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/build_man.t index b35c4c16bf9..d2ab550fb03 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/build_man.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/build_man.t @@ -7,7 +7,7 @@ BEGIN { } use strict; -use Test::More tests => 46; +use Test::More tests => 50; use File::Spec; use File::Temp qw[tempdir]; @@ -44,10 +44,21 @@ ok((my $stdout = tie *STDOUT, 'TieOut'), 'tie stdout'); { local $Config{installman3dir} = File::Spec->catdir(qw(t lib)); - my $mm = WriteMakefile( - NAME => 'Big::Dummy', - VERSION_FROM => 'lib/Big/Dummy.pm', - ); + my $mm; + { + # suppress noisy & unnecessary "WARNING: Older versions of ExtUtils::MakeMaker may errantly install README.pod..." + my @warnings = (); + local $SIG{__WARN__} = sub { push @warnings, shift; }; + $mm = WriteMakefile( + NAME => 'Big::Dummy', + VERSION_FROM => 'lib/Big/Dummy.pm', + ); + # verify that suppressed warnings are present + isnt (scalar(@warnings), 0); + if (scalar(@warnings)) { + note (sprintf('suppressed warnings: [ "%s" ]', do { my $s = join(q/" , "/, @warnings); $s =~ s/([^[:print:]])/sprintf('\x{%x}', ord($1))/egmsx; $s; })); + } + } my %got = %{ $mm->{MAN3PODS} }; # because value too OS-specific my $delete_key = $^O eq 'VMS' ? '[.lib.Big]Dummy.pm' : 'lib/Big/Dummy.pm'; @@ -56,29 +67,62 @@ ok((my $stdout = tie *STDOUT, 'TieOut'), 'tie stdout'); } { - my $mm = WriteMakefile( - NAME => 'Big::Dummy', - VERSION_FROM => 'lib/Big/Dummy.pm', - INSTALLMAN3DIR => 'none' - ); + my $mm; + { + # suppress noisy & unnecessary "WARNING: Older versions of ExtUtils::MakeMaker may errantly install README.pod..." + my @warnings = (); + local $SIG{__WARN__} = sub { push @warnings, shift; }; + $mm = WriteMakefile( + NAME => 'Big::Dummy', + VERSION_FROM => 'lib/Big/Dummy.pm', + INSTALLMAN3DIR => 'none' + ); + # verify that suppressed warnings are present + isnt (scalar(@warnings), 0); + if (scalar(@warnings)) { + note (sprintf('suppressed warnings: [ "%s" ]', do { my $s = join(q/" , "/, @warnings); $s =~ s/([^[:print:]])/sprintf('\x{%x}', ord($1))/egmsx; $s; })); + } + } is_deeply $mm->{MAN3PODS}, {}, 'suppress man3pod with "none"'; } { - my $mm = WriteMakefile( - NAME => 'Big::Dummy', - VERSION_FROM => 'lib/Big/Dummy.pm', - MAN3PODS => {} - ); + my $mm; + { + # suppress noisy & unnecessary "WARNING: Older versions of ExtUtils::MakeMaker may errantly install README.pod..." + my @warnings = (); + local $SIG{__WARN__} = sub { push @warnings, shift; }; + $mm = WriteMakefile( + NAME => 'Big::Dummy', + VERSION_FROM => 'lib/Big/Dummy.pm', + MAN3PODS => {} + ); + # verify that suppressed warnings are present + isnt (scalar(@warnings), 0); + if (scalar(@warnings)) { + note (sprintf('suppressed warnings: [ "%s" ]', do { my $s = join(q/" , "/, @warnings); $s =~ s/([^[:print:]])/sprintf('\x{%x}', ord($1))/egmsx; $s; })); + } + } is_deeply $mm->{MAN3PODS}, {}, 'suppress man3pod with {}'; } { - my $mm = WriteMakefile( - NAME => 'Big::Dummy', - VERSION_FROM => 'lib/Big/Dummy.pm', - MAN3PODS => { "Foo.pm" => "Foo.1" } - ); + my $mm; + { + # suppress noisy & unnecessary "WARNING: Older versions of ExtUtils::MakeMaker may errantly install README.pod..." + my @warnings = (); + local $SIG{__WARN__} = sub { push @warnings, shift; }; + $mm = WriteMakefile( + NAME => 'Big::Dummy', + VERSION_FROM => 'lib/Big/Dummy.pm', + MAN3PODS => { "Foo.pm" => "Foo.1" } + ); + # verify that suppressed warnings are present + isnt (scalar(@warnings), 0); + if (scalar(@warnings)) { + note (sprintf('suppressed warnings: [ "%s" ]', do { my $s = join(q/" , "/, @warnings); $s =~ s/([^[:print:]])/sprintf('\x{%x}', ord($1))/egmsx; $s; })); + } + } is_deeply $mm->{MAN3PODS}, { "Foo.pm" => "Foo.1" }, 'override man3pod'; } @@ -172,10 +216,10 @@ unlink $README; INSTALLDIRS => $INSTALLDIRS, ); - my $makefile = slurp('Makefile'); + my $makefile = slurp($mm->{MAKEFILE}); - like $makefile, qr/^\QMAN1SECTION = 1pm\E$/xms, "Set MAN1SECTION"; - like $makefile, qr/^\QMAN3SECTION = 3pm\E$/xms, "Set MAN3SECTION"; + like $makefile, qr/\QMAN1SECTION = 1pm\E/xms, "Set MAN1SECTION"; + like $makefile, qr/\QMAN3SECTION = 3pm\E/xms, "Set MAN3SECTION"; like $makefile, qr/\Q$(POD2MAN) --section=$(MAN1SECTION) \E/, "Set POD2MAN section to \$(MAN1SECTION)"; @@ -183,4 +227,3 @@ unlink $README; "Set POD2MAN section to \$(MAN3SECTION)"; } } - diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Utils.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Utils.pm index ce73b30b777..76c1ad5010d 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Utils.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Utils.pm @@ -407,7 +407,7 @@ sub hash2files { $file = File::Spec->catfile(File::Spec->curdir, $prefix, split m{\/}, $file); my $dir = dirname($file); mkpath $dir; - my $utf8 = ($] < 5.008 or !$Config{useperlio}) ? "" : ":utf8"; + my $utf8 = ("$]" < 5.008 or !$Config{useperlio}) ? "" : ":utf8"; open(FILE, ">$utf8", $file) || die "Can't create $file: $!"; print FILE $text; close FILE; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/parse_version.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/parse_version.t index 2dbd064c035..dc9919a5515 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/parse_version.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/parse_version.t @@ -53,7 +53,7 @@ if( $Has_Version ) { $versions{q[$VERSION = v1.2.3]} = 'v1.2.3'; } -if( $] >= 5.011001 ) { +if( "$]" >= 5.011001 ) { $versions{'package Foo 1.23;' } = '1.23'; $versions{'package Foo::Bar 1.23;' } = '1.23'; $versions{'package Foo v1.2.3;' } = 'v1.2.3'; @@ -81,7 +81,7 @@ our $VERSION = 2.34; END } -if( $] >= 5.014 ) { +if( "$]" >= 5.014 ) { $versions{'package Foo 1.23 { }' } = '1.23'; $versions{'package Foo::Bar 1.23 { }' } = '1.23'; $versions{'package Foo v1.2.3 { }' } = 'v1.2.3'; @@ -110,7 +110,7 @@ our $VERSION = 2.34; END } -if ( $] > 5.009 && $] < 5.012 ) { +if ( "$]" < 5.012 ) { delete $versions{'$VERSION = -1.0'}; } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/unicode.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/unicode.t index 557ac775404..14a0c8501b0 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/unicode.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/unicode.t @@ -14,7 +14,7 @@ use File::Path; use utf8; BEGIN { plan skip_all => 'Need perlio and perl 5.8+.' - if $] < 5.008 or !$Config{useperlio}; + if "$]" < 5.008 or !$Config{useperlio}; plan skip_all => 'cross-compiling and make not available' if !MM->can_run(make()) && $ENV{PERL_CORE} && $Config{'usecrosscompile'}; @@ -76,7 +76,7 @@ END { ok( chdir $DIRNAME, "chdir'd to $DIRNAME" ) || diag("chdir failed: $!"); -if ($] >= 5.008) { +if ("$]" >= 5.008) { eval { require ExtUtils::MakeMaker::Locale; }; note "ExtUtils::MakeMaker::Locale vars: $ExtUtils::MakeMaker::Locale::ENCODING_LOCALE;$ExtUtils::MakeMaker::Locale::ENCODING_LOCALE_FS;$ExtUtils::MakeMaker::Locale::ENCODING_CONSOLE_IN;$ExtUtils::MakeMaker::Locale::ENCODING_CONSOLE_OUT\n" unless $@; note "Locale env vars: " . join(';', map { diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/vstrings.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/vstrings.t index 9f88399ebd8..63ef8e292bd 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/vstrings.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/vstrings.t @@ -93,7 +93,7 @@ sub run_test { local $_; SKIP: { skip "No vstring test <5.8", 2 - if $] < 5.008 && $pkg eq 'BareV2String' && $descrip =~ m!^2-part!; + if "$]" < 5.008 && $pkg eq 'BareV2String' && $descrip =~ m!^2-part!; my $warnings; eval { $warnings = capture_make("Fake::$pkg" => $version); }; is($@, '', "$descrip not fatal") or skip "$descrip WM failed", 1; diff --git a/gnu/usr.bin/perl/cpan/Getopt-Long/lib/Getopt/Long.pm b/gnu/usr.bin/perl/cpan/Getopt-Long/lib/Getopt/Long.pm index 664c8b63c91..70ac4159565 100644 --- a/gnu/usr.bin/perl/cpan/Getopt-Long/lib/Getopt/Long.pm +++ b/gnu/usr.bin/perl/cpan/Getopt-Long/lib/Getopt/Long.pm @@ -4,8 +4,8 @@ # Author : Johan Vromans # Created On : Tue Sep 11 15:00:12 1990 # Last Modified By: Johan Vromans -# Last Modified On: Sat May 27 12:11:39 2017 -# Update Count : 1715 +# Last Modified On: Mon Aug 12 17:05:46 2019 +# Update Count : 1728 # Status : Released ################ Module Preamble ################ @@ -18,10 +18,10 @@ use warnings; package Getopt::Long; use vars qw($VERSION); -$VERSION = 2.50; +$VERSION = 2.51; # For testing versions only. use vars qw($VERSION_STRING); -$VERSION_STRING = "2.50"; +$VERSION_STRING = "2.51"; use Exporter; use vars qw(@ISA @EXPORT @EXPORT_OK); @@ -303,7 +303,7 @@ sub GetOptionsFromArray(@) { # Avoid some warnings if debugging. local ($^W) = 0; print STDERR - ("Getopt::Long $Getopt::Long::VERSION ", + ("Getopt::Long $Getopt::Long::VERSION_STRING ", "called from package \"$pkg\".", "\n ", "argv: ", @@ -769,7 +769,7 @@ sub GetOptionsFromArray(@) { } # Finish. - if ( @ret && $order == $PERMUTE ) { + if ( @ret && ( $order == $PERMUTE || $passthrough ) ) { # Push back accumulated arguments print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") if $debug; @@ -805,10 +805,8 @@ sub ParseOptionSpec ($$) { ( # Option name (?: \w+[-\w]* ) - # Alias names, or "?" - (?: \| (?: \? | \w[-\w]* ) )* # Aliases - (?: \| (?: [^-|!+=:][^|!+=:]* )? )* + (?: \| (?: . [^|!+=:]* )? )* )? ( # Either modifiers ... @@ -1123,6 +1121,12 @@ sub FindOption ($$$$$) { $optargtype = 3; } if(($optargtype == 0) && !$mand) { + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } my $val = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : $type eq 's' ? '' @@ -1541,7 +1545,7 @@ sub setup_pa_args($@) { # Sneak way to know what version the user requested. sub VERSION { - $requested_version = $_[1]; + $requested_version = $_[1] if @_ > 1; shift->SUPER::VERSION(@_); } @@ -2269,8 +2273,7 @@ it will set variable C<$stdio>. A special option 'name' C<< <> >> can be used to designate a subroutine to handle non-option arguments. When GetOptions() encounters an argument that does not look like an option, it will immediately call this -subroutine and passes it one parameter: the argument name. Well, actually -it is an object that stringifies to the argument name. +subroutine and passes it one parameter: the argument name. For example: @@ -2733,8 +2736,10 @@ version 2.13. use Getopt::Long; GetOptions ("help|?"); # -help and -? will both set $opt_help -Other characters that can't appear in Perl identifiers are also supported -as aliases with Getopt::Long of at least version 2.39. +Other characters that can't appear in Perl identifiers are also +supported in aliases with Getopt::Long of at version 2.39. Note that +the characters C<!>, C<|>, C<+>, C<=>, and C<:> can only appear as the +first (or only) character of an alias. As of version 2.32 Getopt::Long provides auto-help, a quick and easy way to add the options --help and -? to your program, and handle them. diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/Makefile.PL b/gnu/usr.bin/perl/cpan/IO-Compress/Makefile.PL index ca8cce49a22..d22a4c2b4bb 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/IO-Compress/Makefile.PL @@ -3,7 +3,7 @@ use strict ; require 5.006 ; -$::VERSION = '2.084' ; +$::VERSION = '2.093' ; use lib '.'; use private::MakeUtil; @@ -42,7 +42,7 @@ WriteMakefile( INSTALLDIRS => ($] >= 5.009 && $] < 5.011 ? 'perl' : 'site'), - EXE_FILES => ['bin/zipdetails'], + EXE_FILES => ['bin/zipdetails', 'bin/streamzip'], ( $] >= 5.009 && $] <= 5.011001 && ! $ENV{PERL_CORE} @@ -50,11 +50,33 @@ WriteMakefile( : () ), - META_MERGE => { - no_index => { - directory => [ 't', 'private' ], - }, - }, + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ? ( META_MERGE => { + + "meta-spec" => { version => 2 }, + + no_index => { + directory => [ 't', 'private' ], + }, + + resources => { + + bugtracker => { + web => 'https://github.com/pmqs/IO-Compress/issues' + }, + + homepage => 'https://github.com/pmqs/IO-Compress', + + repository => { + type => 'git', + url => 'git://github.com/pmqs/IO-Compress.git', + web => 'https://github.com/pmqs/IO-Compress', + }, + }, + } + ) + : () + ), ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : ()), diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/bin/zipdetails b/gnu/usr.bin/perl/cpan/IO-Compress/bin/zipdetails index ac647b398a2..bff32a1c02e 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/bin/zipdetails +++ b/gnu/usr.bin/perl/cpan/IO-Compress/bin/zipdetails @@ -139,7 +139,7 @@ my %Extras = ( # The Header ID mappings defined by Info-ZIP and third parties are: - 0x0065, ['IBM S/390 attributes - uncompressed', undef], + 0x0065, ['IBM S/390 attributes - uncompressed', \&decodeMVS], 0x0066, ['IBM S/390 attributes - compressed', undef], 0x07c8, ['Info-ZIP Macintosh (old, J. Lee)', undef], 0x2605, ['ZipIt Macintosh (first version)', undef], @@ -180,7 +180,7 @@ my %Extras = ( ); -my $VERSION = "1.09" ; +my $VERSION = "1.11" ; my $FH; @@ -1201,7 +1201,7 @@ sub decode_Zip64 } if (full32 $z64Data->[2] ) { - out_VV " Offset to Central Dir"; + out_VV " Offset to Local Dir"; } if ($z64Data->[3] == 0xFFFF ) { @@ -1463,6 +1463,24 @@ sub decode_NT_security } } +sub decodeMVS +{ + my $len = shift; + my $context = shift; + + # data in Big-Endian + myRead(my $data, $len); + my $ID = unpack("N", $data); + + if ($ID == 0xE9F3F9F0) + { + out($data, " ID", "'Z390'"); + substr($data, 0, 4) = ''; + } + + out($data, " Extra Payload", hexDump($data)); +} + sub printAes { my $context = shift ; @@ -2062,7 +2080,7 @@ OPTIONS -h display help -v Verbose - output more stuff -Copyright (c) 2011-2018 Paul Marquess. All rights reserved. +Copyright (c) 2011-2019 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. @@ -2157,6 +2175,11 @@ Error handling is still a work in progress. If the program encounters a problem reading a zip file it is likely to terminate with an unhelpful error message. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. =head1 SEE ALSO @@ -2182,7 +2205,7 @@ Paul Marquess F<pmqs@cpan.org>. =head1 COPYRIGHT -Copyright (c) 2011-2018 Paul Marquess. All rights reserved. +Copyright (c) 2011-2019 Paul Marquess. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm index ce79d7d1132..4a0aae6c4bc 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/Compress/Zlib.pm @@ -7,17 +7,17 @@ use Carp ; use IO::Handle ; use Scalar::Util qw(dualvar); -use IO::Compress::Base::Common 2.084 ; -use Compress::Raw::Zlib 2.084 ; -use IO::Compress::Gzip 2.084 ; -use IO::Uncompress::Gunzip 2.084 ; +use IO::Compress::Base::Common 2.093 ; +use Compress::Raw::Zlib 2.093 ; +use IO::Compress::Gzip 2.093 ; +use IO::Uncompress::Gunzip 2.093 ; use strict ; use warnings ; use bytes ; our ($VERSION, $XS_VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.084'; +$VERSION = '2.093'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -224,7 +224,7 @@ sub Compress::Zlib::gzFile::gzseek my $gz = $self->[0] ; my $status ; - eval { $status = $gz->seek($offset, $whence) ; }; + eval { local $SIG{__DIE__}; $status = $gz->seek($offset, $whence) ; }; if ($@) { my $error = $@; @@ -461,7 +461,7 @@ sub inflate package Compress::Zlib ; -use IO::Compress::Gzip::Constants 2.084 ; +use IO::Compress::Gzip::Constants 2.093 ; sub memGzip($) { @@ -1467,6 +1467,12 @@ Returns the version of the zlib library. All the I<zlib> constants are automatically imported when you make use of I<Compress::Zlib>. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm index 623a2c671ac..a8a7762ce70 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Bzip2.pm @@ -4,12 +4,12 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status); +use IO::Compress::Base::Common 2.093 qw(:Status); -use Compress::Raw::Bzip2 2.084 ; +use Compress::Raw::Bzip2 2.093 ; our ($VERSION); -$VERSION = '2.084'; +$VERSION = '2.093'; sub mkCompObject { diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm index 8903287b106..140d29ff29f 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Deflate.pm @@ -4,13 +4,13 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status); -use Compress::Raw::Zlib 2.084 qw( !crc32 !adler32 ) ; +use IO::Compress::Base::Common 2.093 qw(:Status); +use Compress::Raw::Zlib 2.093 qw( !crc32 !adler32 ) ; require Exporter; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, @EXPORT, %DEFLATE_CONSTANTS); -$VERSION = '2.084'; +$VERSION = '2.093'; @ISA = qw(Exporter); @EXPORT_OK = @Compress::Raw::Zlib::DEFLATE_CONSTANTS; %EXPORT_TAGS = %Compress::Raw::Zlib::DEFLATE_CONSTANTS; diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm index ae23102a248..487cfa7b476 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Adapter/Identity.pm @@ -4,10 +4,10 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status); +use IO::Compress::Base::Common 2.093 qw(:Status); our ($VERSION); -$VERSION = '2.084'; +$VERSION = '2.093'; sub mkCompObject { diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm index 1e2a54ba397..f817d13b472 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base.pm @@ -6,7 +6,7 @@ require 5.006 ; use strict ; use warnings; -use IO::Compress::Base::Common 2.084 ; +use IO::Compress::Base::Common 2.093 ; use IO::File (); ; use Scalar::Util (); @@ -20,7 +20,7 @@ use Symbol(); our (@ISA, $VERSION); @ISA = qw(IO::File Exporter); -$VERSION = '2.084'; +$VERSION = '2.093'; #Can't locate object method "SWASHNEW" via package "utf8" (perhaps you forgot to load "utf8"?) at .../ext/Compress-Zlib/Gzip/blib/lib/Compress/Zlib/Common.pm line 16. @@ -1021,6 +1021,12 @@ IO::Compress::Base - Base Class for IO::Compress modules This module is not intended for direct use in application code. Its sole purpose is to be sub-classed by IO::Compress modules. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm index 53232898c47..87af18b6de8 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Base/Common.pm @@ -11,7 +11,7 @@ use File::GlobMapper; require Exporter; our ($VERSION, @ISA, @EXPORT, %EXPORT_TAGS, $HAS_ENCODE); @ISA = qw(Exporter); -$VERSION = '2.084'; +$VERSION = '2.093'; @EXPORT = qw( isaFilehandle isaFilename isaScalar whatIsInput whatIsOutput diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm index 1c0d027abdc..13d3b4674df 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Bzip2.pm @@ -5,16 +5,16 @@ use warnings; use bytes; require Exporter ; -use IO::Compress::Base 2.084 ; +use IO::Compress::Base 2.093 ; -use IO::Compress::Base::Common 2.084 qw(); -use IO::Compress::Adapter::Bzip2 2.084 ; +use IO::Compress::Base::Common 2.093 qw(); +use IO::Compress::Adapter::Bzip2 2.093 ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bzip2Error); -$VERSION = '2.084'; +$VERSION = '2.093'; $Bzip2Error = ''; @ISA = qw(IO::Compress::Base Exporter); @@ -51,7 +51,7 @@ sub getExtraParams { my $self = shift ; - use IO::Compress::Base::Common 2.084 qw(:Parse); + use IO::Compress::Base::Common 2.093 qw(:Parse); return ( 'blocksize100k' => [IO::Compress::Base::Common::Parse_unsigned, 1], @@ -183,7 +183,6 @@ IO::Compress::Bzip2 - Write bzip2 files/buffers binmode $z fileno $z close $z ; - =head1 DESCRIPTION @@ -210,7 +209,8 @@ The functional interface needs Perl5.005 or better. =head2 bzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<bzip2> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -223,7 +223,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -319,9 +319,9 @@ in C<$output_filename_or_reference> as a concatenated series of compressed data =head2 Optional Parameters -Unless specified below, the optional parameters for C<bzip2>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<bzip2> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -389,6 +389,22 @@ Defaults to 0. =head2 Examples +Here are a few example that show the capabilities of the module. + +=head3 Streaming + +This very simple command line example demonstrates the streaming capabilities of the module. +The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT. + + $ echo hello world | perl -MIO::Compress::Bzip2=bzip2 -e 'bzip2 \*STDIN => \*STDOUT' >output.bz2 + +The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>, +so the above can be rewritten as + + $ echo hello world | perl -MIO::Compress::Bzip2=bzip2 -e 'bzip2 "-" => "-"' >output.bz2 + +=head3 Compressing a file from the filesystem + To read the contents of the file C<file1.txt> and write the compressed data to the file C<file1.txt.bz2>. @@ -400,6 +416,8 @@ data to the file C<file1.txt.bz2>. bzip2 $input => "$input.bz2" or die "bzip2 failed: $Bzip2Error\n"; +=head3 Reading from a Filehandle and writing to an in-memory buffer + To read from an existing Perl filehandle, C<$input>, and write the compressed data to a buffer, C<$buffer>. @@ -414,6 +432,8 @@ compressed data to a buffer, C<$buffer>. bzip2 $input => \$buffer or die "bzip2 failed: $Bzip2Error\n"; +=head3 Compressing multiple files + To compress all files in the directory "/my/home" that match "*.txt" and store the compressed data in the same directory @@ -488,7 +508,7 @@ return undef. =head2 Constructor Options -C<OPTS> is any combination of the following options: +C<OPTS> is any combination of zero or more the following options: =over 5 @@ -768,6 +788,12 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> @@ -778,7 +804,7 @@ L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, L<Archive::Tar|Archive::Tar>, L<IO::Zlib|IO::Zlib> -The primary site for the bzip2 program is L<http://www.bzip.org>. +The primary site for the bzip2 program is L<https://sourceware.org/bzip2/>. See the module L<Compress::Bzip2|Compress::Bzip2> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm index 1ca86c9331c..5ecac19b889 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Deflate.pm @@ -8,16 +8,16 @@ use bytes; require Exporter ; -use IO::Compress::RawDeflate 2.084 (); -use IO::Compress::Adapter::Deflate 2.084 ; +use IO::Compress::RawDeflate 2.093 (); +use IO::Compress::Adapter::Deflate 2.093 ; -use IO::Compress::Zlib::Constants 2.084 ; -use IO::Compress::Base::Common 2.084 qw(); +use IO::Compress::Zlib::Constants 2.093 ; +use IO::Compress::Base::Common 2.093 qw(); our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $DeflateError); -$VERSION = '2.084'; +$VERSION = '2.093'; $DeflateError = ''; @ISA = qw(IO::Compress::RawDeflate Exporter); @@ -212,7 +212,6 @@ IO::Compress::Deflate - Write RFC 1950 files/buffers binmode $z fileno $z close $z ; - =head1 DESCRIPTION @@ -239,7 +238,8 @@ The functional interface needs Perl5.005 or better. =head2 deflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<deflate> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -252,7 +252,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -348,9 +348,9 @@ in C<$output_filename_or_reference> as a concatenated series of compressed data =head2 Optional Parameters -Unless specified below, the optional parameters for C<deflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<deflate> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -418,6 +418,22 @@ Defaults to 0. =head2 Examples +Here are a few example that show the capabilities of the module. + +=head3 Streaming + +This very simple command line example demonstrates the streaming capabilities of the module. +The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT. + + $ echo hello world | perl -MIO::Compress::Deflate=deflate -e 'deflate \*STDIN => \*STDOUT' >output.1950 + +The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>, +so the above can be rewritten as + + $ echo hello world | perl -MIO::Compress::Deflate=deflate -e 'deflate "-" => "-"' >output.1950 + +=head3 Compressing a file from the filesystem + To read the contents of the file C<file1.txt> and write the compressed data to the file C<file1.txt.1950>. @@ -429,6 +445,8 @@ data to the file C<file1.txt.1950>. deflate $input => "$input.1950" or die "deflate failed: $DeflateError\n"; +=head3 Reading from a Filehandle and writing to an in-memory buffer + To read from an existing Perl filehandle, C<$input>, and write the compressed data to a buffer, C<$buffer>. @@ -443,6 +461,8 @@ compressed data to a buffer, C<$buffer>. deflate $input => \$buffer or die "deflate failed: $DeflateError\n"; +=head3 Compressing multiple files + To compress all files in the directory "/my/home" that match "*.txt" and store the compressed data in the same directory @@ -517,7 +537,7 @@ return undef. =head2 Constructor Options -C<OPTS> is any combination of the following options: +C<OPTS> is any combination of zero or more the following options: =over 5 @@ -892,6 +912,12 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/FAQ.pod b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/FAQ.pod index 1e66507aa2d..697f0f3d3b0 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/FAQ.pod +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/FAQ.pod @@ -656,6 +656,12 @@ One final point -- obviously C<InputLength> can only be used whenever you know the length of the compressed data beforehand, like here with a zip file. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs//issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm index 5302011a20d..3fd13695083 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip.pm @@ -8,12 +8,12 @@ use bytes; require Exporter ; -use IO::Compress::RawDeflate 2.084 () ; -use IO::Compress::Adapter::Deflate 2.084 ; +use IO::Compress::RawDeflate 2.093 () ; +use IO::Compress::Adapter::Deflate 2.093 ; -use IO::Compress::Base::Common 2.084 qw(:Status ); -use IO::Compress::Gzip::Constants 2.084 ; -use IO::Compress::Zlib::Extra 2.084 ; +use IO::Compress::Base::Common 2.093 qw(:Status ); +use IO::Compress::Gzip::Constants 2.093 ; +use IO::Compress::Zlib::Extra 2.093 ; BEGIN { @@ -25,7 +25,7 @@ BEGIN our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $GzipError); -$VERSION = '2.084'; +$VERSION = '2.093'; $GzipError = '' ; @ISA = qw(IO::Compress::RawDeflate Exporter); @@ -319,7 +319,6 @@ IO::Compress::Gzip - Write RFC 1952 files/buffers binmode $z fileno $z close $z ; - =head1 DESCRIPTION @@ -349,7 +348,8 @@ The functional interface needs Perl5.005 or better. =head2 gzip $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<gzip> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -362,7 +362,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -466,9 +466,9 @@ in C<$output_filename_or_reference> as a concatenated series of compressed data =head2 Optional Parameters -Unless specified below, the optional parameters for C<gzip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<gzip> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -536,6 +536,22 @@ Defaults to 0. =head2 Examples +Here are a few example that show the capabilities of the module. + +=head3 Streaming + +This very simple command line example demonstrates the streaming capabilities of the module. +The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT. + + $ echo hello world | perl -MIO::Compress::Gzip=gzip -e 'gzip \*STDIN => \*STDOUT' >output.gz + +The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>, +so the above can be rewritten as + + $ echo hello world | perl -MIO::Compress::Gzip=gzip -e 'gzip "-" => "-"' >output.gz + +=head3 Compressing a file from the filesystem + To read the contents of the file C<file1.txt> and write the compressed data to the file C<file1.txt.gz>. @@ -547,6 +563,8 @@ data to the file C<file1.txt.gz>. gzip $input => "$input.gz" or die "gzip failed: $GzipError\n"; +=head3 Reading from a Filehandle and writing to an in-memory buffer + To read from an existing Perl filehandle, C<$input>, and write the compressed data to a buffer, C<$buffer>. @@ -561,6 +579,8 @@ compressed data to a buffer, C<$buffer>. gzip $input => \$buffer or die "gzip failed: $GzipError\n"; +=head3 Compressing multiple files + To compress all files in the directory "/my/home" that match "*.txt" and store the compressed data in the same directory @@ -635,7 +655,7 @@ return undef. =head2 Constructor Options -C<OPTS> is any combination of the following options: +C<OPTS> is any combination of zero or more the following options: =over 5 @@ -1204,6 +1224,12 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Copress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Copress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm index d1bd0c2bb2a..1d18fc4004c 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Gzip/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %GZIP_OS_Names); our ($GZIP_FNAME_INVALID_CHAR_RE, $GZIP_FCOMMENT_INVALID_CHAR_RE); -$VERSION = '2.084'; +$VERSION = '2.093'; @ISA = qw(Exporter); diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm index b2f38ff4021..c833f5e98b0 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/RawDeflate.pm @@ -6,15 +6,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base 2.084 ; -use IO::Compress::Base::Common 2.084 qw(:Status ); -use IO::Compress::Adapter::Deflate 2.084 ; +use IO::Compress::Base 2.093 ; +use IO::Compress::Base::Common 2.093 qw(:Status ); +use IO::Compress::Adapter::Deflate 2.093 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %DEFLATE_CONSTANTS, %EXPORT_TAGS, $RawDeflateError); -$VERSION = '2.084'; +$VERSION = '2.093'; $RawDeflateError = ''; @ISA = qw(IO::Compress::Base Exporter); @@ -116,8 +116,8 @@ sub getExtraParams return getZlibParams(); } -use IO::Compress::Base::Common 2.084 qw(:Parse); -use Compress::Raw::Zlib 2.084 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); +use IO::Compress::Base::Common 2.093 qw(:Parse); +use Compress::Raw::Zlib 2.093 qw(Z_DEFLATED Z_DEFAULT_COMPRESSION Z_DEFAULT_STRATEGY); our %PARAMS = ( #'method' => [IO::Compress::Base::Common::Parse_unsigned, Z_DEFLATED], 'level' => [IO::Compress::Base::Common::Parse_signed, Z_DEFAULT_COMPRESSION], @@ -265,7 +265,6 @@ IO::Compress::RawDeflate - Write RFC 1951 files/buffers binmode $z fileno $z close $z ; - =head1 DESCRIPTION @@ -295,7 +294,8 @@ The functional interface needs Perl5.005 or better. =head2 rawdeflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<rawdeflate> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -308,7 +308,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -404,9 +404,9 @@ in C<$output_filename_or_reference> as a concatenated series of compressed data =head2 Optional Parameters -Unless specified below, the optional parameters for C<rawdeflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<rawdeflate> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -474,6 +474,22 @@ Defaults to 0. =head2 Examples +Here are a few example that show the capabilities of the module. + +=head3 Streaming + +This very simple command line example demonstrates the streaming capabilities of the module. +The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT. + + $ echo hello world | perl -MIO::Compress::RawDeflate=rawdeflate -e 'rawdeflate \*STDIN => \*STDOUT' >output.1951 + +The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>, +so the above can be rewritten as + + $ echo hello world | perl -MIO::Compress::RawDeflate=rawdeflate -e 'rawdeflate "-" => "-"' >output.1951 + +=head3 Compressing a file from the filesystem + To read the contents of the file C<file1.txt> and write the compressed data to the file C<file1.txt.1951>. @@ -485,6 +501,8 @@ data to the file C<file1.txt.1951>. rawdeflate $input => "$input.1951" or die "rawdeflate failed: $RawDeflateError\n"; +=head3 Reading from a Filehandle and writing to an in-memory buffer + To read from an existing Perl filehandle, C<$input>, and write the compressed data to a buffer, C<$buffer>. @@ -499,6 +517,8 @@ compressed data to a buffer, C<$buffer>. rawdeflate $input => \$buffer or die "rawdeflate failed: $RawDeflateError\n"; +=head3 Compressing multiple files + To compress all files in the directory "/my/home" that match "*.txt" and store the compressed data in the same directory @@ -573,7 +593,7 @@ return undef. =head2 Constructor Options -C<OPTS> is any combination of the following options: +C<OPTS> is any combination of zero or more the following options: =over 5 @@ -948,6 +968,12 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm index eabeef63e76..70b98b80d6e 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip.pm @@ -4,30 +4,30 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status ); -use IO::Compress::RawDeflate 2.084 (); -use IO::Compress::Adapter::Deflate 2.084 ; -use IO::Compress::Adapter::Identity 2.084 ; -use IO::Compress::Zlib::Extra 2.084 ; -use IO::Compress::Zip::Constants 2.084 ; +use IO::Compress::Base::Common 2.093 qw(:Status ); +use IO::Compress::RawDeflate 2.093 (); +use IO::Compress::Adapter::Deflate 2.093 ; +use IO::Compress::Adapter::Identity 2.093 ; +use IO::Compress::Zlib::Extra 2.093 ; +use IO::Compress::Zip::Constants 2.093 ; use File::Spec(); use Config; -use Compress::Raw::Zlib 2.084 (); +use Compress::Raw::Zlib 2.093 (); BEGIN { eval { require IO::Compress::Adapter::Bzip2 ; - import IO::Compress::Adapter::Bzip2 2.084 ; + import IO::Compress::Adapter::Bzip2 2.093 ; require IO::Compress::Bzip2 ; - import IO::Compress::Bzip2 2.084 ; + import IO::Compress::Bzip2 2.093 ; } ; eval { require IO::Compress::Adapter::Lzma ; - import IO::Compress::Adapter::Lzma 2.084 ; + import IO::Compress::Adapter::Lzma 2.093 ; require IO::Compress::Lzma ; - import IO::Compress::Lzma 2.084 ; + import IO::Compress::Lzma 2.093 ; } ; } @@ -36,7 +36,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $ZipError); -$VERSION = '2.084'; +$VERSION = '2.093'; $ZipError = ''; @ISA = qw(IO::Compress::RawDeflate Exporter); @@ -246,13 +246,17 @@ sub mkHeader &{ *$self->{ZipData}{FilterName} }() ; } -# if ( $param->getValue('utf8') ) { -# require Encode ; -# $filename = Encode::encode_utf8($filename) -# if length $filename ; -# $comment = Encode::encode_utf8($comment) -# if length $comment ; -# } + if ( $param->getValue('efs') && $] >= 5.008004) { + if (length $filename) { + utf8::downgrade($filename, 1) + or Carp::croak "Wide character in zip filename"; + } + + if (length $comment) { + utf8::downgrade($comment, 1) + or Carp::croak "Wide character in zip comment"; + } + } my $hdr = ''; @@ -325,8 +329,8 @@ sub mkHeader $gpFlag |= ZIP_GP_FLAG_LZMA_EOS_PRESENT if $method == ZIP_CM_LZMA ; -# $gpFlag |= ZIP_GP_FLAG_LANGUAGE_ENCODING -# if $param->getValue('utf8') && (length($filename) || length($comment)); + $gpFlag |= ZIP_GP_FLAG_LANGUAGE_ENCODING + if $param->getValue('efs') && (length($filename) || length($comment)); my $version = $ZIP_CM_MIN_VERSIONS{$method}; $version = ZIP64_MIN_VERSION @@ -682,7 +686,7 @@ our %PARAMS = ( 'name' => [IO::Compress::Base::Common::Parse_any, ''], 'filtername'=> [IO::Compress::Base::Common::Parse_code, undef], 'canonicalname'=> [IO::Compress::Base::Common::Parse_boolean, 0], -# 'utf8' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'efs' => [IO::Compress::Base::Common::Parse_boolean, 0], 'time' => [IO::Compress::Base::Common::Parse_any, undef], 'extime' => [IO::Compress::Base::Common::Parse_any, undef], 'exunix2' => [IO::Compress::Base::Common::Parse_any, undef], @@ -905,7 +909,6 @@ IO::Compress::Zip - Write zip files/buffers binmode $z fileno $z close $z ; - =head1 DESCRIPTION @@ -916,14 +919,18 @@ The primary purpose of this module is to provide streaming write access to zip files and buffers. It is not a general-purpose file archiver. If that is what you want, check out C<Archive::Zip> or C<Archive::Zip::SimpleZip>. -At present three compression methods are supported by IO::Compress::Zip, +At present the following compression methods are supported by IO::Compress::Zip, namely Store (no compression at all), Deflate, Bzip2 and LZMA. -Note that to create Bzip2 content, the module C<IO::Compress::Bzip2> must -be installed. +B<Note> + +=over 5 + +=item * To use Bzip2 compression, the module C<IO::Compress::Bzip2> must be installed. -Note that to create LZMA content, the module C<IO::Compress::Lzma> must -be installed. +=item * To use LZMA compression, the module C<IO::Compress::Lzma> must be installed. + +=back For reading zip files/buffers, see the companion module L<IO::Uncompress::Unzip|IO::Uncompress::Unzip>. @@ -945,7 +952,8 @@ The functional interface needs Perl5.005 or better. =head2 zip $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<zip> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -958,7 +966,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -1062,9 +1070,9 @@ in C<$output_filename_or_reference> as a distinct entry. =head2 Optional Parameters -Unless specified below, the optional parameters for C<zip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<zip> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -1132,6 +1140,50 @@ Defaults to 0. =head2 Examples +Here are a few example that show the capabilities of the module. + +=head3 Streaming + +This very simple command line example demonstrates the streaming capabilities of the module. +The code reads data from STDIN, compresses it, and writes the compressed data to STDOUT. + + $ echo hello world | perl -MIO::Compress::Zip=zip -e 'zip \*STDIN => \*STDOUT' >output.zip + +The special filename "-" can be used as a standin for both C<\*STDIN> and C<\*STDOUT>, +so the above can be rewritten as + + $ echo hello world | perl -MIO::Compress::Zip=zip -e 'zip "-" => "-"' >output.zip + +One problem with creating a zip archive directly from STDIN can be demonstrated by looking at +the contents of the zip file, output.zip, that we have just created. + + $ unzip -l output.zip + Archive: output.zip + Length Date Time Name + --------- ---------- ----- ---- + 12 2019-08-16 22:21 + --------- ------- + 12 1 file + +The archive member (filename) used is the empty string. + +If that doesn't suit your needs, you can explicitly set the filename used +in the zip archive by specifying the L<Name|"File Naming Options"> option, like so + + echo hello world | perl -MIO::Compress::Zip=zip -e 'zip "-" => "-", Name => "hello.txt"' >output.zip + +Now the contents of the zip file looks like this + + $ unzip -l output.zip + Archive: output.zip + Length Date Time Name + --------- ---------- ----- ---- + 12 2019-08-16 22:22 hello.txt + --------- ------- + 12 1 file + +=head3 Compressing a file from the filesystem + To read the contents of the file C<file1.txt> and write the compressed data to the file C<file1.txt.zip>. @@ -1143,6 +1195,8 @@ data to the file C<file1.txt.zip>. zip $input => "$input.zip" or die "zip failed: $ZipError\n"; +=head3 Reading from a Filehandle and writing to an in-memory buffer + To read from an existing Perl filehandle, C<$input>, and write the compressed data to a buffer, C<$buffer>. @@ -1157,6 +1211,8 @@ compressed data to a buffer, C<$buffer>. zip $input => \$buffer or die "zip failed: $ZipError\n"; +=head3 Compressing multiple files + To create a zip file, C<output.zip>, that contains the compressed contents of the files C<alpha.txt> and C<beta.txt> @@ -1235,7 +1291,7 @@ return undef. =head2 Constructor Options -C<OPTS> is any combination of the following options: +C<OPTS> is any combination of zero or more the following options: =over 5 @@ -1278,22 +1334,52 @@ to it. Otherwise the file pointer will not be moved. This parameter defaults to 0. +=back + +=head3 File Naming Options + +A quick bit of zip file terminology -- A zip archive consists of one or more I<archive members>, where each member has an associated +filename, known as the I<archive member name>. + +The options listed in this section control how the I<archive member name> (or filename) is stored the zip archive. + +=over 5 + =item C<< Name => $string >> -Stores the contents of C<$string> in the zip filename header field. +This option is used to explicitly set the I<archive member name> in +the zip archive to C<$string>. +Most of the time you don't need to make use of this option. +By default when adding a filename to the zip archive, the I<archive member name> will match the filename. + +You should only need to use this option if you want the I<archive member name> +to be different from the uncompressed filename or when the input is a filehandle or a buffer. -If C<Name> is not specified and the C<$input> parameter is a filename, the -value of C<$input> will be used for the zip filename header field. +The default behaviour for what I<archive member name> is used when the C<Name> option +is I<not> specified depends on the form of the C<$input> parameter: + +=over 5 -If C<Name> is not specified and the C<$input> parameter is not a filename, -no zip filename field will be created. +=item * + +If the C<$input> parameter is a filename, the +value of C<$input> will be used for the I<archive member name> . + +=item * +If the C<$input> parameter is not a filename, +the I<archive member name> will be an empty string. + +=back Note that both the C<CanonicalName> and C<FilterName> options -can modify the value used for the zip filename header field. +can modify the value used for the I<archive member name>. + +Also note that you should set the C<Efs> option to true if you are working +with UTF8 filenames. =item C<< CanonicalName => 0|1 >> -This option controls whether the filename field in the zip header is +This option controls whether the I<archive member name> is I<normalized> into Unix format before being written to the zip file. It is recommended that you enable this option unless you really need @@ -1313,15 +1399,14 @@ This option defaults to B<false>. =item C<< FilterName => sub { ... } >> -This option allow the filename field in the zip header to be modified +This option allow the I<archive member> name to be modified before it is written to the zip file. This option takes a parameter that must be a reference to a sub. On entry to the sub the C<$_> variable will contain the name to be filtered. If no filename is available C<$_> will contain an empty string. -The value of C<$_> when the sub returns will be stored in the filename -header field. +The value of C<$_> when the sub returns will be used as the I<archive member name>. Note that if C<CanonicalName> is enabled, a normalized filename will be passed to the sub. @@ -1343,6 +1428,167 @@ filenames before they are stored in C<$zipfile>. FilterName => sub { s[^$dir/][] } ; } +=item C<< Efs => 0|1 >> + +This option controls setting of the "Language Encoding Flag" (EFS) in the zip +archive. When set, the filename and comment fields for the zip archive MUST +be valid UTF-8. + +If the string used for the filename and/or comment is not valid UTF-8 when this option +is true, the script will die with a "wide character" error. + +Note that this option only works with Perl 5.8.4 or better. + +This option defaults to B<false>. + +=back + +=head3 Overall Zip Archive Structure + +=over 5 + +=item C<< Minimal => 1|0 >> + +If specified, this option will disable the creation of all extra fields +in the zip local and central headers. So the C<exTime>, C<exUnix2>, +C<exUnixN>, C<ExtraFieldLocal> and C<ExtraFieldCentral> options will +be ignored. + +This parameter defaults to 0. + +=item C<< Stream => 0|1 >> + +This option controls whether the zip file/buffer output is created in +streaming mode. + +Note that when outputting to a file with streaming mode disabled (C<Stream> +is 0), the output file must be seekable. + +The default is 1. + +=item C<< Zip64 => 0|1 >> + +Create a Zip64 zip file/buffer. This option is used if you want +to store files larger than 4 Gig or store more than 64K files in a single +zip archive. + +C<Zip64> will be automatically set, as needed, if working with the one-shot +interface when the input is either a filename or a scalar reference. + +If you intend to manipulate the Zip64 zip files created with this module +using an external zip/unzip, make sure that it supports Zip64. + +In particular, if you are using Info-Zip you need to have zip version 3.x +or better to update a Zip64 archive and unzip version 6.x to read a zip64 +archive. + +The default is 0. + +=back + +=head3 Deflate Compression Options + +=over 5 + +=item -Level + +Defines the compression level used by zlib. The value should either be +a number between 0 and 9 (0 means no compression and 9 is maximum +compression), or one of the symbolic constants defined below. + + Z_NO_COMPRESSION + Z_BEST_SPEED + Z_BEST_COMPRESSION + Z_DEFAULT_COMPRESSION + +The default is Z_DEFAULT_COMPRESSION. + +Note, these constants are not imported by C<IO::Compress::Zip> by default. + + use IO::Compress::Zip qw(:strategy); + use IO::Compress::Zip qw(:constants); + use IO::Compress::Zip qw(:all); + +=item -Strategy + +Defines the strategy used to tune the compression. Use one of the symbolic +constants defined below. + + Z_FILTERED + Z_HUFFMAN_ONLY + Z_RLE + Z_FIXED + Z_DEFAULT_STRATEGY + +The default is Z_DEFAULT_STRATEGY. + +=back + +=head3 Bzip2 Compression Options + +=over 5 + +=item C<< BlockSize100K => number >> + +Specify the number of 100K blocks bzip2 uses during compression. + +Valid values are from 1 to 9, where 9 is best compression. + +This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored +otherwise. + +The default is 1. + +=item C<< WorkFactor => number >> + +Specifies how much effort bzip2 should take before resorting to a slower +fallback compression algorithm. + +Valid values range from 0 to 250, where 0 means use the default value 30. + +This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored +otherwise. + +The default is 0. + +=back + +=head3 Lzma Compression Options + +=over 5 + +=item C<< Preset => number >> + +Used to choose the LZMA compression preset. + +Valid values are 0-9 and C<LZMA_PRESET_DEFAULT>. + +0 is the fastest compression with the lowest memory usage and the lowest +compression. + +9 is the slowest compression with the highest memory usage but with the best +compression. + +This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored +otherwise. + +Defaults to C<LZMA_PRESET_DEFAULT> (6). + +=item C<< Extreme => 0|1 >> + +Makes LZMA compression a lot slower, but a small compression gain. + +This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored +otherwise. + +Defaults to 0. + +=back + +=head3 Other Options + +=over 5 + =item C<< Time => $number >> Sets the last modified time field in the zip header to $number. @@ -1424,6 +1670,8 @@ By default no UnixN extra field is created. Stores the contents of C<$comment> in the Central File Header of the zip file. +Set the C<Efs> option to true if you want to store a UTF8 comment. + By default, no comment field is written to the zip file. =item C<< ZipComment => $comment >> @@ -1458,34 +1706,6 @@ content when C<IO::Compress::Lzma> is not available. The default method is ZIP_CM_DEFLATE. -=item C<< Stream => 0|1 >> - -This option controls whether the zip file/buffer output is created in -streaming mode. - -Note that when outputting to a file with streaming mode disabled (C<Stream> -is 0), the output file must be seekable. - -The default is 1. - -=item C<< Zip64 => 0|1 >> - -Create a Zip64 zip file/buffer. This option is used if you want -to store files larger than 4 Gig or store more than 64K files in a single -zip archive. - -C<Zip64> will be automatically set, as needed, if working with the one-shot -interface when the input is either a filename or a scalar reference. - -If you intend to manipulate the Zip64 zip files created with this module -using an external zip/unzip, make sure that it supports Zip64. - -In particular, if you are using Info-Zip you need to have zip version 3.x -or better to update a Zip64 archive and unzip version 6.x to read a zip64 -archive. - -The default is 0. - =item C<< TextFlag => 0|1 >> This parameter controls the setting of a bit in the zip central header. It @@ -1546,96 +1766,6 @@ If the C<Minimal> option is set to true, this option will be ignored. The maximum size of an extra field 65535 bytes. -=item C<< Minimal => 1|0 >> - -If specified, this option will disable the creation of all extra fields -in the zip local and central headers. So the C<exTime>, C<exUnix2>, -C<exUnixN>, C<ExtraFieldLocal> and C<ExtraFieldCentral> options will -be ignored. - -This parameter defaults to 0. - -=item C<< BlockSize100K => number >> - -Specify the number of 100K blocks bzip2 uses during compression. - -Valid values are from 1 to 9, where 9 is best compression. - -This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored -otherwise. - -The default is 1. - -=item C<< WorkFactor => number >> - -Specifies how much effort bzip2 should take before resorting to a slower -fallback compression algorithm. - -Valid values range from 0 to 250, where 0 means use the default value 30. - -This option is only valid if the C<Method> is ZIP_CM_BZIP2. It is ignored -otherwise. - -The default is 0. - -=item C<< Preset => number >> - -Used to choose the LZMA compression preset. - -Valid values are 0-9 and C<LZMA_PRESET_DEFAULT>. - -0 is the fastest compression with the lowest memory usage and the lowest -compression. - -9 is the slowest compression with the highest memory usage but with the best -compression. - -This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored -otherwise. - -Defaults to C<LZMA_PRESET_DEFAULT> (6). - -=item C<< Extreme => 0|1 >> - -Makes LZMA compression a lot slower, but a small compression gain. - -This option is only valid if the C<Method> is ZIP_CM_LZMA. It is ignored -otherwise. - -Defaults to 0. - -=item -Level - -Defines the compression level used by zlib. The value should either be -a number between 0 and 9 (0 means no compression and 9 is maximum -compression), or one of the symbolic constants defined below. - - Z_NO_COMPRESSION - Z_BEST_SPEED - Z_BEST_COMPRESSION - Z_DEFAULT_COMPRESSION - -The default is Z_DEFAULT_COMPRESSION. - -Note, these constants are not imported by C<IO::Compress::Zip> by default. - - use IO::Compress::Zip qw(:strategy); - use IO::Compress::Zip qw(:constants); - use IO::Compress::Zip qw(:all); - -=item -Strategy - -Defines the strategy used to tune the compression. Use one of the symbolic -constants defined below. - - Z_FILTERED - Z_HUFFMAN_ONLY - Z_RLE - Z_FIXED - Z_DEFAULT_STRATEGY - -The default is Z_DEFAULT_STRATEGY. - =item C<< Strict => 0|1 >> This is a placeholder option. @@ -1918,6 +2048,12 @@ See L<IO::Compress::FAQ|IO::Compress::FAQ/"Apache::GZip Revisited"> See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm index d28a6ae6861..edae0c29d27 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zip/Constants.pm @@ -7,7 +7,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT, %ZIP_CM_MIN_VERSIONS); -$VERSION = '2.084'; +$VERSION = '2.093'; @ISA = qw(Exporter); diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm index d0d053be95d..c2fecba974f 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Constants.pm @@ -9,7 +9,7 @@ require Exporter; our ($VERSION, @ISA, @EXPORT); -$VERSION = '2.084'; +$VERSION = '2.093'; @ISA = qw(Exporter); diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm index a88adba273d..6e13d4fb2f1 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Compress/Zlib/Extra.pm @@ -8,9 +8,9 @@ use bytes; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = '2.084'; +$VERSION = '2.093'; -use IO::Compress::Gzip::Constants 2.084 ; +use IO::Compress::Gzip::Constants 2.093 ; sub ExtraFieldError { diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm index 1aa9a8c39b7..3fc176e5006 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Bunzip2.pm @@ -4,12 +4,12 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status); +use IO::Compress::Base::Common 2.093 qw(:Status); -use Compress::Raw::Bzip2 2.084 ; +use Compress::Raw::Bzip2 2.093 ; our ($VERSION, @ISA); -$VERSION = '2.084'; +$VERSION = '2.093'; sub mkUncompObject { diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm index 5601599225f..c8622a59137 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Identity.pm @@ -4,14 +4,14 @@ use warnings; use strict; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status); +use IO::Compress::Base::Common 2.093 qw(:Status); use IO::Compress::Zip::Constants ; our ($VERSION); -$VERSION = '2.084'; +$VERSION = '2.093'; -use Compress::Raw::Zlib 2.084 (); +use Compress::Raw::Zlib 2.093 (); sub mkUncompObject { @@ -139,7 +139,7 @@ sub reset { my $self = shift; - $self->{CompSize} = 0; + $self->{CompSize}->reset(); $self->{UnCompSize} = 0; $self->{CRC32} = Compress::Raw::Zlib::crc32(''); $self->{ADLER32} = Compress::Raw::Zlib::adler32(''); diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm index f51c64d7e54..a27af5ba8e7 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Adapter/Inflate.pm @@ -4,11 +4,11 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status); -use Compress::Raw::Zlib 2.084 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); +use IO::Compress::Base::Common 2.093 qw(:Status); +use Compress::Raw::Zlib 2.093 qw(Z_OK Z_BUF_ERROR Z_STREAM_END Z_FINISH MAX_WBITS); our ($VERSION); -$VERSION = '2.084'; +$VERSION = '2.093'; diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm index be464889ebb..6172737e26e 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyInflate.pm @@ -6,22 +6,22 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 (); +use IO::Compress::Base::Common 2.093 (); -use IO::Uncompress::Adapter::Inflate 2.084 (); +use IO::Uncompress::Adapter::Inflate 2.093 (); -use IO::Uncompress::Base 2.084 ; -use IO::Uncompress::Gunzip 2.084 ; -use IO::Uncompress::Inflate 2.084 ; -use IO::Uncompress::RawInflate 2.084 ; -use IO::Uncompress::Unzip 2.084 ; +use IO::Uncompress::Base 2.093 ; +use IO::Uncompress::Gunzip 2.093 ; +use IO::Uncompress::Inflate 2.093 ; +use IO::Uncompress::RawInflate 2.093 ; +use IO::Uncompress::Unzip 2.093 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyInflateError); -$VERSION = '2.084'; +$VERSION = '2.093'; $AnyInflateError = ''; @ISA = qw(IO::Uncompress::Base Exporter); @@ -48,7 +48,7 @@ sub anyinflate sub getExtraParams { - use IO::Compress::Base::Common 2.084 qw(:Parse); + use IO::Compress::Base::Common 2.093 qw(:Parse); return ( 'rawinflate' => [Parse_boolean, 0] ) ; } @@ -213,7 +213,8 @@ The functional interface needs Perl5.005 or better. =head2 anyinflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<anyinflate> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -226,7 +227,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -323,9 +324,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<anyinflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<anyinflate> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -959,6 +960,12 @@ Same as doing this See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm index c6dfce536b4..251b7cf2632 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/AnyUncompress.pm @@ -4,16 +4,16 @@ use strict; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 (); +use IO::Compress::Base::Common 2.093 (); -use IO::Uncompress::Base 2.084 ; +use IO::Uncompress::Base 2.093 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $AnyUncompressError); -$VERSION = '2.084'; +$VERSION = '2.093'; $AnyUncompressError = ''; @ISA = qw(IO::Uncompress::Base Exporter); @@ -29,26 +29,30 @@ BEGIN { local @INC = @INC; pop @INC if $INC[-1] eq '.'; - eval ' use IO::Uncompress::Adapter::Inflate 2.084 ;'; - eval ' use IO::Uncompress::Adapter::Bunzip2 2.084 ;'; - eval ' use IO::Uncompress::Adapter::LZO 2.084 ;'; - eval ' use IO::Uncompress::Adapter::Lzf 2.084 ;'; - eval ' use IO::Uncompress::Adapter::UnLzma 2.084 ;'; - eval ' use IO::Uncompress::Adapter::UnXz 2.084 ;'; + + # Don't trigger any __DIE__ Hooks. + local $SIG{__DIE__}; + + eval ' use IO::Uncompress::Adapter::Inflate 2.093 ;'; + eval ' use IO::Uncompress::Adapter::Bunzip2 2.093 ;'; + eval ' use IO::Uncompress::Adapter::LZO 2.093 ;'; + eval ' use IO::Uncompress::Adapter::Lzf 2.093 ;'; + eval ' use IO::Uncompress::Adapter::UnLzma 2.093 ;'; + eval ' use IO::Uncompress::Adapter::UnXz 2.093 ;'; eval ' use IO::Uncompress::Adapter::UnZstd 2.083 ;'; - eval ' use IO::Uncompress::Adapter::UnLzip 2.084 ;'; - - eval ' use IO::Uncompress::Bunzip2 2.084 ;'; - eval ' use IO::Uncompress::UnLzop 2.084 ;'; - eval ' use IO::Uncompress::Gunzip 2.084 ;'; - eval ' use IO::Uncompress::Inflate 2.084 ;'; - eval ' use IO::Uncompress::RawInflate 2.084 ;'; - eval ' use IO::Uncompress::Unzip 2.084 ;'; - eval ' use IO::Uncompress::UnLzf 2.084 ;'; - eval ' use IO::Uncompress::UnLzma 2.084 ;'; - eval ' use IO::Uncompress::UnXz 2.084 ;'; - eval ' use IO::Uncompress::UnZstd 2.084 ;'; - eval ' use IO::Uncompress::UnLzip 2.084 ;'; + eval ' use IO::Uncompress::Adapter::UnLzip 2.093 ;'; + + eval ' use IO::Uncompress::Bunzip2 2.093 ;'; + eval ' use IO::Uncompress::UnLzop 2.093 ;'; + eval ' use IO::Uncompress::Gunzip 2.093 ;'; + eval ' use IO::Uncompress::Inflate 2.093 ;'; + eval ' use IO::Uncompress::RawInflate 2.093 ;'; + eval ' use IO::Uncompress::Unzip 2.093 ;'; + eval ' use IO::Uncompress::UnLzf 2.093 ;'; + eval ' use IO::Uncompress::UnLzma 2.093 ;'; + eval ' use IO::Uncompress::UnXz 2.093 ;'; + eval ' use IO::Uncompress::UnZstd 2.093 ;'; + eval ' use IO::Uncompress::UnLzip 2.093 ;'; } @@ -266,7 +270,7 @@ __END__ =head1 NAME -IO::Uncompress::AnyUncompress - Uncompress gzip, zip, bzip2 or lzop file/buffer +IO::Uncompress::AnyUncompress - Uncompress gzip, zip, bzip2, xz, lzma, lzip, lzf or lzop file/buffer =head1 SYNOPSIS @@ -363,7 +367,8 @@ The functional interface needs Perl5.005 or better. =head2 anyuncompress $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<anyuncompress> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -376,7 +381,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -473,9 +478,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<anyuncompress>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<anyuncompress> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -1044,6 +1049,12 @@ Same as doing this =head1 EXAMPLES +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm index 06fb04a81c9..b9901ca1fff 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Base.pm @@ -9,12 +9,12 @@ our (@ISA, $VERSION, @EXPORT_OK, %EXPORT_TAGS); @ISA = qw(IO::File Exporter); -$VERSION = '2.084'; +$VERSION = '2.093'; use constant G_EOF => 0 ; use constant G_ERR => -1 ; -use IO::Compress::Base::Common 2.084 ; +use IO::Compress::Base::Common 2.093 ; use IO::File ; use Symbol; @@ -1010,6 +1010,9 @@ sub nextStream $status == 1 or return $status ; + *$self->{Pending} = '' + if $self !~ /IO::Uncompress::RawInflate/ && ! *$self->{MultiStream}; + *$self->{TotalInflatedBytesRead} = 0 ; *$self->{LineNo} = $. = 0; @@ -1050,6 +1053,10 @@ sub gotoNextStream return 0; } + # Not EOF, so Transparent mode kicks in now for trailing data + # Reset member name in case anyone calls getHeaderInfo()->{Name} + *$self->{Info} = { Name => undef, Type => 'plain' }; + $self->clearError(); *$self->{Type} = 'plain'; *$self->{Plain} = 1; @@ -1527,6 +1534,12 @@ IO::Uncompress::Base - Base Class for IO::Uncompress modules This module is not intended for direct use in application code. Its sole purpose is to be sub-classed by IO::Uncompress modules. +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm index 7a84bcd15cb..8e805d4c9e2 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Bunzip2.pm @@ -4,15 +4,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status ); +use IO::Compress::Base::Common 2.093 qw(:Status ); -use IO::Uncompress::Base 2.084 ; -use IO::Uncompress::Adapter::Bunzip2 2.084 ; +use IO::Uncompress::Base 2.093 ; +use IO::Uncompress::Adapter::Bunzip2 2.093 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $Bunzip2Error); -$VERSION = '2.084'; +$VERSION = '2.093'; $Bunzip2Error = ''; @ISA = qw(IO::Uncompress::Base Exporter); @@ -209,7 +209,8 @@ The functional interface needs Perl5.005 or better. =head2 bunzip2 $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<bunzip2> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -222,7 +223,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -319,9 +320,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<bunzip2>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<bunzip2> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -876,6 +877,12 @@ Same as doing this See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> @@ -886,7 +893,7 @@ L<File::GlobMapper|File::GlobMapper>, L<Archive::Zip|Archive::Zip>, L<Archive::Tar|Archive::Tar>, L<IO::Zlib|IO::Zlib> -The primary site for the bzip2 program is L<http://www.bzip.org>. +The primary site for the bzip2 program is L<https://sourceware.org/bzip2/>. See the module L<Compress::Bzip2|Compress::Bzip2> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm index 46dd108341a..6e57e961184 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Gunzip.pm @@ -9,12 +9,12 @@ use strict ; use warnings; use bytes; -use IO::Uncompress::RawInflate 2.084 ; +use IO::Uncompress::RawInflate 2.093 ; -use Compress::Raw::Zlib 2.084 () ; -use IO::Compress::Base::Common 2.084 qw(:Status ); -use IO::Compress::Gzip::Constants 2.084 ; -use IO::Compress::Zlib::Extra 2.084 ; +use Compress::Raw::Zlib 2.093 () ; +use IO::Compress::Base::Common 2.093 qw(:Status ); +use IO::Compress::Gzip::Constants 2.093 ; +use IO::Compress::Zlib::Extra 2.093 ; require Exporter ; @@ -28,7 +28,7 @@ Exporter::export_ok_tags('all'); $GunzipError = ''; -$VERSION = '2.084'; +$VERSION = '2.093'; sub new { @@ -348,7 +348,8 @@ The functional interface needs Perl5.005 or better. =head2 gunzip $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<gunzip> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -361,7 +362,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -458,9 +459,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<gunzip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<gunzip> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -1082,6 +1083,12 @@ Same as doing this See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm index 4d89db5b195..993a1dddc89 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Inflate.pm @@ -5,15 +5,15 @@ use strict ; use warnings; use bytes; -use IO::Compress::Base::Common 2.084 qw(:Status ); -use IO::Compress::Zlib::Constants 2.084 ; +use IO::Compress::Base::Common 2.093 qw(:Status ); +use IO::Compress::Zlib::Constants 2.093 ; -use IO::Uncompress::RawInflate 2.084 ; +use IO::Uncompress::RawInflate 2.093 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $InflateError); -$VERSION = '2.084'; +$VERSION = '2.093'; $InflateError = ''; @ISA = qw(IO::Uncompress::RawInflate Exporter); @@ -270,7 +270,8 @@ The functional interface needs Perl5.005 or better. =head2 inflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<inflate> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -283,7 +284,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -380,9 +381,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<inflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<inflate> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -954,6 +955,12 @@ Same as doing this See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm index 63703cd9750..2fa318816ac 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/RawInflate.pm @@ -5,16 +5,16 @@ use strict ; use warnings; use bytes; -use Compress::Raw::Zlib 2.084 ; -use IO::Compress::Base::Common 2.084 qw(:Status ); +use Compress::Raw::Zlib 2.093 ; +use IO::Compress::Base::Common 2.093 qw(:Status ); -use IO::Uncompress::Base 2.084 ; -use IO::Uncompress::Adapter::Inflate 2.084 ; +use IO::Uncompress::Base 2.093 ; +use IO::Uncompress::Adapter::Inflate 2.093 ; require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, %DEFLATE_CONSTANTS, $RawInflateError); -$VERSION = '2.084'; +$VERSION = '2.093'; $RawInflateError = ''; @ISA = qw(IO::Uncompress::Base Exporter); @@ -418,7 +418,8 @@ The functional interface needs Perl5.005 or better. =head2 rawinflate $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<rawinflate> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -431,7 +432,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -528,9 +529,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<rawinflate>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<rawinflate> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -1082,6 +1083,12 @@ Same as doing this See L<IO::Compress::FAQ|IO::Compress::FAQ/"Compressed files and Net::FTP"> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm index 4e8a0d67c7a..856487f8fcd 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/lib/IO/Uncompress/Unzip.pm @@ -9,17 +9,20 @@ use warnings; use bytes; use IO::File; -use IO::Uncompress::RawInflate 2.084 ; -use IO::Compress::Base::Common 2.084 qw(:Status ); -use IO::Uncompress::Adapter::Inflate 2.084 ; -use IO::Uncompress::Adapter::Identity 2.084 ; -use IO::Compress::Zlib::Extra 2.084 ; -use IO::Compress::Zip::Constants 2.084 ; +use IO::Uncompress::RawInflate 2.093 ; +use IO::Compress::Base::Common 2.093 qw(:Status ); +use IO::Uncompress::Adapter::Inflate 2.093 ; +use IO::Uncompress::Adapter::Identity 2.093 ; +use IO::Compress::Zlib::Extra 2.093 ; +use IO::Compress::Zip::Constants 2.093 ; -use Compress::Raw::Zlib 2.084 () ; +use Compress::Raw::Zlib 2.093 () ; BEGIN { + # Don't trigger any __DIE__ Hooks. + local $SIG{__DIE__}; + eval{ require IO::Uncompress::Adapter::Bunzip2 ; import IO::Uncompress::Adapter::Bunzip2 } ; eval{ require IO::Uncompress::Adapter::UnLzma ; @@ -31,7 +34,7 @@ require Exporter ; our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnzipError, %headerLookup); -$VERSION = '2.084'; +$VERSION = '2.093'; $UnzipError = ''; @ISA = qw(IO::Uncompress::RawInflate Exporter); @@ -70,6 +73,7 @@ sub getExtraParams 'name' => [IO::Compress::Base::Common::Parse_any, undef], 'stream' => [IO::Compress::Base::Common::Parse_boolean, 0], + 'efs' => [IO::Compress::Base::Common::Parse_boolean, 0], # TODO - This means reading the central directory to get # 1. the local header offsets @@ -86,6 +90,7 @@ sub ckParams $got->setValue('crc32' => 1); *$self->{UnzipData}{Name} = $got->getValue('name'); + *$self->{UnzipData}{efs} = $got->getValue('efs'); return 1; } @@ -551,6 +556,7 @@ sub _readZipHeader($) my $extraField; my @EXTRA = (); my $streamingMode = ($gpFlag & ZIP_GP_FLAG_STREAMING_MASK) ? 1 : 0 ; + my $efs_flag = ($gpFlag & ZIP_GP_FLAG_LANGUAGE_ENCODING) ? 1 : 0; return $self->HeaderError("Encrypted content not supported") if $gpFlag & (ZIP_GP_FLAG_ENCRYPTED_MASK|ZIP_GP_FLAG_STRONG_ENCRYPTED_MASK); @@ -565,6 +571,14 @@ sub _readZipHeader($) { $self->smartReadExact(\$filename, $filename_length) or return $self->TruncatedHeader("Filename"); + + if (*$self->{UnzipData}{efs} && $efs_flag && $] >= 5.008004) + { + require Encode; + eval { $filename = Encode::decode_utf8($filename, 1) } + or Carp::croak "Zip Filename not UTF-8" ; + } + $keep .= $filename ; } @@ -705,6 +719,7 @@ sub _readZipHeader($) 'UncompressedLength' => $uncompressedLength , 'CRC32' => $crc32 , 'Name' => $filename, + 'efs' => $efs_flag, # language encoding flag 'Time' => _dosToUnixTime($lastModTime), 'Stream' => $streamingMode, @@ -1107,7 +1122,8 @@ The functional interface needs Perl5.005 or better. =head2 unzip $input_filename_or_reference => $output_filename_or_reference [, OPTS] C<unzip> expects at least two parameters, -C<$input_filename_or_reference> and C<$output_filename_or_reference>. +C<$input_filename_or_reference> and C<$output_filename_or_reference> +and zero or more optional parameters (see L</Optional Parameters>) =head3 The C<$input_filename_or_reference> parameter @@ -1120,7 +1136,7 @@ It can take one of the following forms: =item A filename -If the <$input_filename_or_reference> parameter is a simple scalar, it is +If the C<$input_filename_or_reference> parameter is a simple scalar, it is assumed to be a filename. This file will be opened for reading and the input data will be read from it. @@ -1217,9 +1233,9 @@ files/buffers. =head2 Optional Parameters -Unless specified below, the optional parameters for C<unzip>, -C<OPTS>, are the same as those used with the OO interface defined in the -L</"Constructor Options"> section below. +The optional parameters for the one-shot function C<unzip> +are (for the most part) identical to those used with the OO interface defined in the +L</"Constructor Options"> section. The exceptions are listed below =over 5 @@ -1431,6 +1447,18 @@ OPTS is a combination of the following options: Open "membername" from the zip file for reading. +=item C<< Efs => 0| 1 >> + +When this option is set to true AND the zip archive being read has +the "Language Encoding Flag" (EFS) set, the member name is assumed to be encoded in UTF-8. + +If the member name in the zip archive is not valid UTF-8 when this optionn is true, +the script will die with an error message. + +Note that this option only works with Perl 5.8.4 or better. + +This option defaults to B<false>. + =item C<< AutoClose => 0|1 >> This option is only valid when the C<$input> parameter is a filehandle. If @@ -1731,6 +1759,10 @@ Skips to the next compressed data stream in the input file/buffer. If a new compressed data stream is found, the eof marker will be cleared and C<$.> will be reset to 0. +If trailing data is present immediately after the zip archive and the +C<Transparent> option is enabled, this method will consider that trailing +data to be another member of the zip archive. + Returns 1 if a new stream was found, 0 if none was found, and -1 if an error was encountered. @@ -1828,6 +1860,12 @@ to read a zip file and unzip its contents to disk. The script is available from L<https://gist.github.com/eqhmcow/5389877> +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + =head1 SEE ALSO L<Compress::Zlib>, L<IO::Compress::Gzip>, L<IO::Uncompress::Gunzip>, L<IO::Compress::Deflate>, L<IO::Uncompress::Inflate>, L<IO::Compress::RawDeflate>, L<IO::Uncompress::RawInflate>, L<IO::Compress::Bzip2>, L<IO::Uncompress::Bunzip2>, L<IO::Compress::Lzma>, L<IO::Uncompress::UnLzma>, L<IO::Compress::Xz>, L<IO::Uncompress::UnXz>, L<IO::Compress::Lzip>, L<IO::Uncompress::UnLzip>, L<IO::Compress::Lzop>, L<IO::Uncompress::UnLzop>, L<IO::Compress::Lzf>, L<IO::Uncompress::UnLzf>, L<IO::Compress::Zstd>, L<IO::Uncompress::UnZstd>, L<IO::Uncompress::AnyInflate>, L<IO::Uncompress::AnyUncompress> diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm b/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm index 037782b9498..12fa26fd05f 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm +++ b/gnu/usr.bin/perl/cpan/IO-Compress/private/MakeUtil.pm @@ -35,8 +35,7 @@ sub MY::libscan my $path = shift; return undef - if $path =~ /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/ || - $path =~ /(~|\.bak|_bak)$/ || + if $path =~ /(~|\.bak|_bak)$/ || $path =~ /\..*\.sw(o|p)$/ || $path =~ /\B\.svn\b/; diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/000prereq.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/000prereq.t index c3395464c49..9467cd37711 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/000prereq.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/000prereq.t @@ -25,7 +25,7 @@ BEGIN if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - my $VERSION = '2.084'; + my $VERSION = '2.093'; my @NAMES = qw( Compress::Raw::Bzip2 Compress::Raw::Zlib @@ -60,8 +60,7 @@ BEGIN ); - my @OPT = qw( - + my @OPT = qw( ); plan tests => 1 + 2 + @NAMES + @OPT + $extra ; diff --git a/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm index 42cdd5990cb..88ed2955a9d 100644 --- a/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm +++ b/gnu/usr.bin/perl/cpan/IPC-Cmd/lib/IPC/Cmd.pm @@ -19,7 +19,7 @@ BEGIN { $HAVE_MONOTONIC ]; - $VERSION = '1.02'; + $VERSION = '1.04'; $VERBOSE = 0; $DEBUG = 0; $WARN = 1; @@ -1204,7 +1204,7 @@ sub run_forked { # which do setsid theirselves -- can't do anything # with those) - POSIX::setsid() || Carp::confess("Error running setsid: " . $!); + POSIX::setsid() == -1 and Carp::confess("Error running setsid: " . $!); if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') { $opts->{'child_BEGIN'}->(); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/bin/json_pp b/gnu/usr.bin/perl/cpan/JSON-PP/bin/json_pp index 5f956b1fc31..72b9db70f1f 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/bin/json_pp +++ b/gnu/usr.bin/perl/cpan/JSON-PP/bin/json_pp @@ -3,6 +3,7 @@ BEGIN { pop @INC if $INC[-1] eq '.' } use strict; use Getopt::Long; +use Encode (); use JSON::PP (); @@ -42,10 +43,17 @@ for my $opt (split /,/, $json_opt) { my %F = ( 'json' => sub { my $json = JSON::PP->new; + my $enc = + /^\x00\x00\x00/s ? "utf-32be" + : /^\x00.\x00/s ? "utf-16be" + : /^.\x00\x00\x00/s ? "utf-32le" + : /^.\x00.\x00/s ? "utf-16le" + : "utf-8"; for my $key (keys %json_opt) { + next if $key eq 'utf8'; $json->$key($json_opt{$key}); } - $json->decode( $_ ); + $json->decode( Encode::decode($enc, $_) ); }, 'eval' => sub { my $v = eval "no strict;\n#line 1 \"input\"\n$_"; @@ -84,8 +92,11 @@ $F{$opt_from} $T{$opt_to} or die "$opt_from: not a valid toformat\n"; -local $/; -$_ = <STDIN>; +{ + local $/; + binmode STDIN; + $_ = <STDIN>; +} $_ = $F{$opt_from}->(); $_ = $T{$opt_to}->(); @@ -163,7 +174,7 @@ options to JSON::PP Acceptable options are: ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref - allow_singlequote allow_barekey allow_bignum loose escape_slash + allow_singlequote allow_barekey allow_bignum loose escape_slash indent_length Multiple options must be separated by commas: diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP.pm b/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP.pm index d8b7ab30656..9f083542851 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP.pm +++ b/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP.pm @@ -14,7 +14,7 @@ use JSON::PP::Boolean; use Carp (); #use Devel::Peek; -$JSON::PP::VERSION = '4.02'; +$JSON::PP::VERSION = '4.04'; @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); @@ -1773,7 +1773,7 @@ JSON::PP - JSON::XS compatible pure-Perl module. =head1 VERSION - 4.02 + 4.04 =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm b/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm index 3e772e92a3e..4e903bd4f10 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/lib/Math/BigInt/FastCalc.pm @@ -8,7 +8,7 @@ use Math::BigInt::Calc 1.999801; our @ISA = qw< Math::BigInt::Calc >; -our $VERSION = '0.5008'; +our $VERSION = '0.5009'; ############################################################################## # global constants, flags and accessory diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigFloat.pm b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigFloat.pm index 8a92b5818da..f1d7a1a0a0a 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigFloat.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigFloat.pm @@ -19,8 +19,9 @@ use warnings; use Carp qw< carp croak >; use Math::BigInt (); -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; +require Exporter; our @ISA = qw/Math::BigInt/; our @EXPORT_OK = qw/bpi/; @@ -28,8 +29,6 @@ our @EXPORT_OK = qw/bpi/; our ($AUTOLOAD, $accuracy, $precision, $div_scale, $round_mode, $rnd_mode, $upgrade, $downgrade, $_trap_nan, $_trap_inf); -my $class = "Math::BigFloat"; - use overload # overload key: with_assign @@ -273,7 +272,7 @@ sub AUTOLOAD { my $name = $AUTOLOAD; $name =~ s/(.*):://; # split package - my $c = $1 || $class; + my $c = $1 || __PACKAGE__; no strict 'refs'; $c->import() if $IMPORT == 0; if (!_method_alias($name)) { @@ -418,7 +417,8 @@ sub new { return $self; } - # Handle hexadecimal numbers. + # Handle hexadecimal numbers. We auto-detect hexadecimal numbers if they + # have a "0x" or "0X" prefix. if ($wanted =~ /^\s*[+-]?0[Xx]/) { $self = $class -> from_hex($wanted); @@ -426,7 +426,42 @@ sub new { return $self; } - # Handle binary numbers. + # Handle octal numbers. We auto-detect octal numbers if they have a "0" + # prefix and a binary exponent. + + if ($wanted =~ / + ^ + \s* + + # sign + [+-]? + + # prefix + 0 + + # significand using the octal digits 0..7 + [0-7]+ (?: _ [0-7]+ )* + (?: + \. + (?: [0-7]+ (?: _ [0-7]+ )* )? + )? + + # exponent (power of 2) using decimal digits + [Pp] + [+-]? + \d+ (?: _ \d+ )* + + \s* + $ + /x) + { + $self = $class -> from_oct($wanted); + $self->round(@r) unless @r >= 2 && !defined $r[0] && !defined $r[1]; + return $self; + } + + # Handle binary numbers. We auto-detect binary numbers if they have a "0b" + # or "0B" prefix. if ($wanted =~ /^\s*[+-]?0[Bb]/) { $self = $class -> from_bin($wanted); @@ -781,6 +816,165 @@ sub from_bin { return $self->bnan(); } +sub from_ieee754 { + my $self = shift; + my $selfref = ref $self; + my $class = $selfref || $self; + + # Don't modify constant (read-only) objects. + + return if $selfref && $self->modify('from_ieee754'); + + my $in = shift; # input string (or raw bytes) + my $format = shift; # format ("binary32", "decimal64" etc.) + my $enc; # significand encoding (applies only to decimal) + my $k; # storage width in bits + my $b; # base + + if ($format =~ /^binary(\d+)\z/) { + $k = $1; + $b = 2; + } elsif ($format =~ /^decimal(\d+)(dpd|bcd)?\z/) { + $k = $1; + $b = 10; + $enc = $2 || 'dpd'; # default is dencely-packed decimals (DPD) + } elsif ($format eq 'half') { + $k = 16; + $b = 2; + } elsif ($format eq 'single') { + $k = 32; + $b = 2; + } elsif ($format eq 'double') { + $k = 64; + $b = 2; + } elsif ($format eq 'quadruple') { + $k = 128; + $b = 2; + } elsif ($format eq 'octuple') { + $k = 256; + $b = 2; + } elsif ($format eq 'sexdecuple') { + $k = 512; + $b = 2; + } + + if ($b == 2) { + + # Get the parameters for this format. + + my $p; # precision (in bits) + my $t; # number of bits in significand + my $w; # number of bits in exponent + + if ($k == 16) { # binary16 (half-precision) + $p = 11; + $t = 10; + $w = 5; + } elsif ($k == 32) { # binary32 (single-precision) + $p = 24; + $t = 23; + $w = 8; + } elsif ($k == 64) { # binary64 (double-precision) + $p = 53; + $t = 52; + $w = 11; + } else { # binaryN (quadruple-precision and above) + if ($k < 128 || $k != 32 * sprintf('%.0f', $k / 32)) { + croak "Number of bits must be 16, 32, 64, or >= 128 and", + " a multiple of 32"; + } + $p = $k - sprintf('%.0f', 4 * log($k) / log(2)) + 13; + $t = $p - 1; + $w = $k - $t - 1; + } + + # The maximum exponent, minimum exponent, and exponent bias. + + my $emax = Math::BigInt -> new(2) -> bpow($w - 1) -> bdec(); + my $emin = 1 - $emax; + my $bias = $emax; + + # Undefined input. + + unless (defined $in) { + carp("Input is undefined"); + return $self -> bzero(); + } + + # Make sure input string is a string of zeros and ones. + + my $len = CORE::length $in; + if (8 * $len == $k) { # bytes + $in = unpack "B*", $in; + } elsif (4 * $len == $k) { # hexadecimal + if ($in =~ /([^\da-f])/i) { + croak "Illegal hexadecimal digit '$1'"; + } + $in = unpack "B*", pack "H*", $in; + } elsif ($len == $k) { # bits + if ($in =~ /([^01])/) { + croak "Illegal binary digit '$1'"; + } + } else { + croak "Unknown input -- $in"; + } + + # Split bit string into sign, exponent, and mantissa/significand. + + my $sign = substr($in, 0, 1) eq '1' ? '-' : '+'; + my $expo = $class -> from_bin(substr($in, 1, $w)); + my $mant = $class -> from_bin(substr($in, $w + 1)); + + my $x; + + $expo -> bsub($bias); # subtract bias + + if ($expo < $emin) { # zero and subnormals + if ($mant == 0) { # zero + $x = $class -> bzero(); + } else { # subnormals + # compute (1/$b)**(N) rather than ($b)**(-N) + $x = $class -> new("0.5"); # 1/$b + $x -> bpow($bias + $t - 1) -> bmul($mant); + $x -> bneg() if $sign eq '-'; + } + } + + elsif ($expo > $emax) { # inf and nan + if ($mant == 0) { # inf + $x = $class -> binf($sign); + } else { # nan + $x = $class -> bnan(); + } + } + + else { # normals + $mant = $class -> new(2) -> bpow($t) -> badd($mant); + if ($expo < $t) { + # compute (1/$b)**(N) rather than ($b)**(-N) + $x = $class -> new("0.5"); # 1/$b + $x -> bpow($t - $expo) -> bmul($mant); + } else { + $x = $class -> new(2); + $x -> bpow($expo - $t) -> bmul($mant); + } + $x -> bneg() if $sign eq '-'; + } + + if ($selfref) { + $self -> {sign} = $x -> {sign}; + $self -> {_m} = $x -> {_m}; + $self -> {_es} = $x -> {_es}; + $self -> {_e} = $x -> {_e}; + } else { + $self = $x; + } + return $self; + } + + croak("The format '$format' is not yet supported."); +} + sub bzero { # create/assign '+0' @@ -3023,7 +3217,7 @@ sub bsqrt { return $x if $x->modify('bsqrt'); - return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0 + return $x->bnan() if $x->{sign} !~ /^\+/; # NaN, -inf or < 0 return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf return $x->round($a, $p, $r) if $x->is_zero() || $x->is_one(); @@ -3783,7 +3977,7 @@ sub mantissa { if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; - $s =~ s/^[+]//; + $s =~ s/^\+//; return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf } my $m = Math::BigInt->new($LIB->_str($x->{_m}), undef, undef); @@ -3798,7 +3992,7 @@ sub exponent { if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; -$s =~ s/^[+-]//; + $s =~ s/^[+-]//; return Math::BigInt->new($s, undef, undef); # -inf, +inf => +inf } Math::BigInt->new($x->{_es} . $LIB->_str($x->{_e}), undef, undef); @@ -3810,9 +4004,9 @@ sub parts { if ($x->{sign} !~ /^[+-]$/) { my $s = $x->{sign}; -$s =~ s/^[+]//; -my $se = $s; -$se =~ s/^[-]//; + $s =~ s/^\+//; + my $se = $s; + $se =~ s/^-//; return ($class->new($s), $class->new($se)); # +inf => inf and -inf, +inf => inf } my $m = Math::BigInt->bzero(); @@ -3981,9 +4175,9 @@ sub bstr { } my $es = '0'; -my $len = 1; -my $cad = 0; -my $dot = '.'; + my $len = 1; + my $cad = 0; + my $dot = '.'; # $x is zero? my $not_zero = !($x->{sign} eq '+' && $LIB->_is_zero($x->{_m})); @@ -4007,8 +4201,8 @@ my $dot = '.'; } elsif ($e > 0) { # expand with zeros $es .= '0' x $e; -$len += $e; -$cad = 0; + $len += $e; + $cad = 0; } } # if not zero @@ -4160,6 +4354,197 @@ sub to_bin { return $x->{sign} eq '-' ? "-$str" : $str; } +sub to_ieee754 { + my $x = shift; + my $format = shift; + my $class = ref $x; + + my $enc; # significand encoding (applies only to decimal) + my $k; # storage width in bits + my $b; # base + + if ($format =~ /^binary(\d+)\z/) { + $k = $1; + $b = 2; + } elsif ($format =~ /^decimal(\d+)(dpd|bcd)?\z/) { + $k = $1; + $b = 10; + $enc = $2 || 'dpd'; # default is dencely-packed decimals (DPD) + } elsif ($format eq 'half') { + $k = 16; + $b = 2; + } elsif ($format eq 'single') { + $k = 32; + $b = 2; + } elsif ($format eq 'double') { + $k = 64; + $b = 2; + } elsif ($format eq 'quadruple') { + $k = 128; + $b = 2; + } elsif ($format eq 'octuple') { + $k = 256; + $b = 2; + } elsif ($format eq 'sexdecuple') { + $k = 512; + $b = 2; + } + + if ($b == 2) { + + # Get the parameters for this format. + + my $p; # precision (in bits) + my $t; # number of bits in significand + my $w; # number of bits in exponent + + if ($k == 16) { # binary16 (half-precision) + $p = 11; + $t = 10; + $w = 5; + } elsif ($k == 32) { # binary32 (single-precision) + $p = 24; + $t = 23; + $w = 8; + } elsif ($k == 64) { # binary64 (double-precision) + $p = 53; + $t = 52; + $w = 11; + } else { # binaryN (quadruple-precition and above) + if ($k < 128 || $k != 32 * sprintf('%.0f', $k / 32)) { + croak "Number of bits must be 16, 32, 64, or >= 128 and", + " a multiple of 32"; + } + $p = $k - sprintf('%.0f', 4 * log($k) / log(2)) + 13; + $t = $p - 1; + $w = $k - $t - 1; + } + + # The maximum exponent, minimum exponent, and exponent bias. + + my $emax = $class -> new(2) -> bpow($w - 1) -> bdec(); + my $emin = 1 - $emax; + my $bias = $emax; + + # Get numerical sign, exponent, and mantissa/significand for bit + # string. + + my $sign = 0; + my $expo; + my $mant; + + if ($x -> is_nan()) { # nan + $sign = 1; + $expo = $emax -> copy() -> binc(); + $mant = $class -> new(2) -> bpow($t - 1); + } elsif ($x -> is_inf()) { # inf + $sign = 1 if $x -> is_neg(); + $expo = $emax -> copy() -> binc(); + $mant = $class -> bzero(); + } elsif ($x -> is_zero()) { # zero + $expo = $emin -> copy() -> bdec(); + $mant = $class -> bzero(); + } else { # normal and subnormal + + $sign = 1 if $x -> is_neg(); + + # Now we need to compute the mantissa and exponent in base $b. + + my $binv = $class -> new("0.5"); + my $b = $class -> new(2); + my $one = $class -> bone(); + + # We start off by initializing the exponent to zero and the + # mantissa to the input value. Then we increase the mantissa and + # decrease the exponent, or vice versa, until the mantissa is in + # the desired range or we hit one of the limits for the exponent. + + $mant = $x -> copy() -> babs(); + + # We need to find the base 2 exponent. First make an estimate of + # the base 2 exponent, before adjusting it below. We could skip + # this estimation and go straight to the while-loops below, but the + # loops are slow, especially when the final exponent is far from + # zero and even more so if the number of digits is large. This + # initial estimation speeds up the computation dramatically. + # + # log2($m * 10**$e) = log10($m + 10**$e) * log(10)/log(2) + # = (log10($m) + $e) * log(10)/log(2) + # = (log($m)/log(10) + $e) * log(10)/log(2) + + my ($m, $e) = $x -> nparts(); + my $ms = $m -> numify(); + my $es = $e -> numify(); + + my $expo_est = (log(abs($ms))/log(10) + $es) * log(10)/log(2); + $expo_est = int($expo_est); + + # Limit the exponent. + + if ($expo_est > $emax) { + $expo_est = $emax; + } elsif ($expo_est < $emin) { + $expo_est = $emin; + } + + # Don't multiply by a number raised to a negative exponent. This + # will cause a division, whose result is truncated to some fixed + # number of digits. Instead, multiply by the inverse number raised + # to a positive exponent. + + $expo = $class -> new($expo_est); + if ($expo_est > 0) { + $mant -> bmul($binv -> copy() -> bpow($expo)); + } elsif ($expo_est < 0) { + my $expo_abs = $expo -> copy() -> bneg(); + $mant -> bmul($b -> copy() -> bpow($expo_abs)); + } + + # Final adjustment. + + while ($mant >= $b && $expo <= $emax) { + $mant -> bmul($binv); + $expo -> binc(); + } + + while ($mant < $one && $expo >= $emin) { + $mant -> bmul($b); + $expo -> bdec(); + } + + # Encode as infinity, normal number or subnormal number? + + if ($expo > $emax) { # overflow => infinity + $expo = $emax -> copy() -> binc(); + $mant = $class -> bzero(); + } elsif ($expo < $emin) { # subnormal number + my $const = $class -> new(2) -> bpow($t - 1); + $mant -> bmul($const); + $mant -> bfround(0); + } else { # normal number + $mant -> bdec(); # remove implicit leading bit + my $const = $class -> new(2) -> bpow($t); + $mant -> bmul($const) -> bfround(0); + } + } + + $expo -> badd($bias); # add bias + + my $signbit = "$sign"; + + my $mantbits = $mant -> to_bin(); + $mantbits = ("0" x ($t - CORE::length($mantbits))) . $mantbits; + + my $expobits = $expo -> to_bin(); + $expobits = ("0" x ($w - CORE::length($expobits))) . $expobits; + + my $bin = $signbit . $expobits . $mantbits; + return pack "B*", $bin; + } + + croak("The format '$format' is not yet supported."); +} + sub as_hex { # return number as hexadecimal string (only for integers defined) @@ -4231,7 +4616,7 @@ sub numify { } # Create a string and let Perl's atoi()/atof() handle the rest. - return 0 + $x -> bsstr(); + return 0 + $x -> bnstr(); } ############################################################################### @@ -4242,7 +4627,7 @@ sub import { my $class = shift; my $l = scalar @_; my $lib = ''; -my @a; + my @a; my $lib_kind = 'try'; $IMPORT=1; for (my $i = 0; $i < $l ; $i++) { @@ -4314,7 +4699,7 @@ sub _len_to_steps { # D = 50 => N => 42, so L = 40 and R = 50 my $l = 40; -my $r = $d; + my $r = $d; # Otherwise this does not work under -Mbignum and we do not yet have "no bignum;" :( $l = $l->numify if ref($l); @@ -4370,7 +4755,6 @@ sub _log { $over->bmul($u); $factor = $class->new(3); $f = $class->new(2); - my $steps = 0; $limit = $class->new("1E-". ($scale-1)); while (3 < 5) { @@ -4717,7 +5101,6 @@ sub _pow { $over = $u->copy(); $limit = $class->new("1E-". ($scale-1)); - #my $steps = 0; while (3 < 5) { # we calculate the next term, and add it to the last # when the next term is below our limit, it won't affect the outcome @@ -4731,8 +5114,6 @@ sub _pow { $factor->binc(); last if $x->{sign} !~ /^[-+]$/; - - #$steps++; } if ($do_invert) { @@ -4795,6 +5176,7 @@ Math::BigFloat - Arbitrary size floating point math package $x = Math::BigFloat->from_oct('0377'); # ditto $x = Math::BigFloat->from_bin('0b1.1001p-4'); # from binary $x = Math::BigFloat->from_bin('0101'); # ditto + $x = Math::BigFloat->from_ieee754($b, "binary64"); # from IEEE-754 bytes $x = Math::BigFloat->bzero(); # create a +0 $x = Math::BigFloat->bone(); # create a +1 $x = Math::BigFloat->bone('-'); # create a -1 @@ -4926,6 +5308,7 @@ Math::BigFloat - Arbitrary size floating point math package $x->as_hex(); # as signed hexadecimal string with prefixed 0x $x->as_bin(); # as signed binary string with prefixed 0b $x->as_oct(); # as signed octal string with prefixed 0 + $x->to_ieee754($format); # to bytes encoded according to IEEE 754-2008 # Other conversion methods @@ -5106,6 +5489,17 @@ using decimal digits. If called as an instance method, the value is assigned to the invocand. +=item from_ieee754() + +Interpret the input as a value encoded as described in IEEE754-2008. The input +can be given as a byte string, hex string or binary string. The input is +assumed to be in big-endian byte-order. + + # both $dbl and $mbf are 3.141592... + $bytes = "\x40\x09\x21\xfb\x54\x44\x2d\x18"; + $dbl = unpack "d>", $bytes; + $mbf = Math::BigFloat -> from_ieee754($bytes, "binary64"); + =item bpi() print Math::BigFloat->bpi(100), "\n"; @@ -5225,6 +5619,29 @@ C<ref($x)-E<gt>new()> can parse to create an object. In Math::BigFloat, C<as_float()> has the same effect as C<copy()>. +=item to_ieee754() + +Encodes the invocand as a byte string in the given format as specified in IEEE +754-2008. Note that the encoded value is the nearest possible representation of +the value. This value might not be exactly the same as the value in the +invocand. + + # $x = 3.1415926535897932385 + $x = Math::BigFloat -> bpi(30); + + $b = $x -> to_ieee754("binary64"); # encode as 8 bytes + $h = unpack "H*", $b; # "400921fb54442d18" + + # 3.141592653589793115997963... + $y = Math::BigFloat -> from_ieee754($h, "binary64"); + +All binary formats in IEEE 754-2008 are accepted. For convenience, som aliases +are recognized: "half" for "binary16", "single" for "binary32", "double" for +"binary64", "quadruple" for "binary128", "octuple" for "binary256", and +"sexdecuple" for "binary512". + +See also L<https://en.wikipedia.org/wiki/IEEE_754>. + =back =head2 ACCURACY AND PRECISION @@ -5552,11 +5969,11 @@ L<http://annocpan.org/dist/Math-BigInt> =item * CPAN Ratings -L<http://cpanratings.perl.org/dist/Math-BigInt> +L<https://cpanratings.perl.org/dist/Math-BigInt> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigInt/> +L<https://metacpan.org/release/Math-BigInt> =item * CPAN Testers Matrix diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt.pm b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt.pm index a443cd4a5d4..185f8028350 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt.pm @@ -1,3 +1,5 @@ +# -*- coding: utf-8-unix -*- + package Math::BigInt; # @@ -20,14 +22,12 @@ use warnings; use Carp qw< carp croak >; -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(objectify bgcd blcm); -my $class = "Math::BigInt"; - # Inside overload, the first arg is always an object. If the original code had # it reversed (like $x = 2 * $y), then the third parameter is true. # In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes @@ -232,9 +232,7 @@ my $LIB = 'Math::BigInt::Calc'; # module to do the low level math # default is Calc.pm my $IMPORT = 0; # was import() called yet? # used to make require work -my %WARN; # warn only once for low-level libs my %CALLBACKS; # callbacks to notify on lib loads -my $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math ############################################################################## # the old code had $rnd_mode, so we need to support it, too @@ -1135,7 +1133,7 @@ sub bpi { if (@_ == 1) { # called like Math::BigInt::bpi(10); $n = $self; - $self = $class; + $self = __PACKAGE__; } $self = ref($self) if ref($self); @@ -1234,6 +1232,24 @@ sub is_negative { $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not } +sub is_non_negative { + # Return true if argument is non-negative (>= 0). + my ($class, $x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); + + return 1 if $x->{sign} =~ /^\+/; + return 1 if $x -> is_zero(); + return 0; +} + +sub is_non_positive { + # Return true if argument is non-positive (<= 0). + my ($class, $x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_); + + return 1 if $x->{sign} =~ /^\-/; + return 1 if $x -> is_zero(); + return 0; +} + sub is_odd { # return true when arg (BINT or num_str) is odd, false for even my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); @@ -2354,7 +2370,7 @@ sub bmodpow { $num->{value} = $value; $num->{sign} = $sign; - return $num; + return $num -> round(@r); } sub bpow { @@ -2401,21 +2417,14 @@ sub bpow { $r[3] = $y; # no push! - # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu - - my $new_sign = '+'; - $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+'); + # 0 ** -y => ( 1 / (0 ** y)) => 1 / 0 => +inf + return $x->binf() if $y->is_negative() && $x->is_zero(); - # 0 ** -7 => ( 1 / (0 ** 7)) => 1 / 0 => +inf - return $x->binf() - if $y->{sign} eq '-' && $x->{sign} eq '+' && $LIB->_is_zero($x->{value}); # 1 ** -y => 1 / (1 ** |y|) - # so do test for negative $y after above's clause - return $x->bnan() if $y->{sign} eq '-' && !$LIB->_is_one($x->{value}); + return $x->bzero() if $y->is_negative() && !$LIB->_is_one($x->{value}); $x->{value} = $LIB->_pow($x->{value}, $y->{value}); - $x->{sign} = $new_sign; - $x->{sign} = '+' if $LIB->_is_zero($y->{value}); + $x->{sign} = $x->is_negative() && $y->is_odd() ? '-' : '+'; $x->round(@r); } @@ -2483,7 +2492,7 @@ sub blog { return $x; } - my ($rc, $exact) = $LIB->_log_int($x->{value}, $base->{value}); + my ($rc) = $LIB->_log_int($x->{value}, $base->{value}); return $x->bnan() unless defined $rc; # not possible to take log? $x->{value} = $rc; $x->round(@r); @@ -2602,6 +2611,126 @@ sub bnok { $n->round(@r); } +sub buparrow { + my $a = shift; + my $y = $a -> uparrow(@_); + $a -> {value} = $y -> {value}; + return $a; +} + +sub uparrow { + # Knuth's up-arrow notation buparrow(a, n, b) + # + # The following is a simple, recursive implementation of the up-arrow + # notation, just to show the idea. Such implementations cause "Deep + # recursion on subroutine ..." warnings, so we use a faster, non-recursive + # algorithm below with @_ as a stack. + # + # sub buparrow { + # my ($a, $n, $b) = @_; + # return $a ** $b if $n == 1; + # return $a * $b if $n == 0; + # return 1 if $b == 0; + # return buparrow($a, $n - 1, buparrow($a, $n, $b - 1)); + # } + + my ($a, $b, $n) = @_; + my $class = ref $a; + croak("a must be non-negative") if $a < 0; + croak("n must be non-negative") if $n < 0; + croak("b must be non-negative") if $b < 0; + + while (@_ >= 3) { + + # return $a ** $b if $n == 1; + + if ($_[-2] == 1) { + my ($a, $n, $b) = splice @_, -3; + push @_, $a ** $b; + next; + } + + # return $a * $b if $n == 0; + + if ($_[-2] == 0) { + my ($a, $n, $b) = splice @_, -3; + push @_, $a * $b; + next; + } + + # return 1 if $b == 0; + + if ($_[-1] == 0) { + splice @_, -3; + push @_, $class -> bone(); + next; + } + + # return buparrow($a, $n - 1, buparrow($a, $n, $b - 1)); + + my ($a, $n, $b) = splice @_, -3; + push @_, ($a, $n - 1, + $a, $n, $b - 1); + + } + + pop @_; +} + +sub backermann { + my $m = shift; + my $y = $m -> ackermann(@_); + $m -> {value} = $y -> {value}; + return $m; +} + +sub ackermann { + # Ackermann's function ackermann(m, n) + # + # The following is a simple, recursive implementation of the ackermann + # function, just to show the idea. Such implementations cause "Deep + # recursion on subroutine ..." warnings, so we use a faster, non-recursive + # algorithm below with @_ as a stack. + # + # sub ackermann { + # my ($m, $n) = @_; + # return $n + 1 if $m == 0; + # return ackermann($m - 1, 1) if $m > 0 && $n == 0; + # return ackermann($m - 1, ackermann($m, $n - 1) if $m > 0 && $n > 0; + # } + + my ($m, $n) = @_; + my $class = ref $m; + croak("m must be non-negative") if $m < 0; + croak("n must be non-negative") if $n < 0; + + my $two = $class -> new("2"); + my $three = $class -> new("3"); + my $thirteen = $class -> new("13"); + + $n = pop; + $n = $class -> new($n) unless ref($n); + while (@_) { + my $m = pop; + if ($m > $three) { + push @_, (--$m) x $n; + while (--$m >= $three) { + push @_, $m; + } + $n = $thirteen; + } elsif ($m == $three) { + $n = $class -> bone() -> blsft($n + $three) -> bsub($three); + } elsif ($m == $two) { + $n -> bmul($two) -> badd($three); + } elsif ($m >= 0) { + $n -> badd($m) -> binc(); + } else { + die "negative m!"; + } + } + $n; +} + sub bsin { # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the # result truncated to an integer. @@ -2654,9 +2783,9 @@ sub batan { return $upgrade->new($x)->batan(@r) if defined $upgrade; # calculate the result and truncate it to integer - my $t = Math::BigFloat->new($x)->batan(@r); + my $tmp = Math::BigFloat->new($x)->batan(@r); - $x->{value} = $LIB->_new($x->as_int()->bstr()); + $x->{value} = $LIB->_new($tmp->as_int()->bstr()); $x->round(@r); } @@ -2902,12 +3031,19 @@ sub blsft { # (BINT or num_str, BINT or num_str) return BINT # compute x << y, base n, y >= 0 - # set up parameters - my ($class, $x, $y, $b, @r) = (ref($_[0]), @_); + my ($class, $x, $y, $b, @r); - # objectify is costly, so avoid it - if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) { - ($class, $x, $y, $b, @r) = objectify(2, @_); + # Objectify the base only when it is defined, since an undefined base, as + # in $x->blsft(3) or $x->blog(3, undef) means use the default base 2. + + if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) { + # E.g., Math::BigInt->blog(256, 5, 2) + ($class, $x, $y, $b, @r) = + defined $_[3] ? objectify(3, @_) : objectify(2, @_); + } else { + # E.g., Math::BigInt::blog(256, 5, 2) or $x->blog(5, 2) + ($class, $x, $y, $b, @r) = + defined $_[2] ? objectify(3, @_) : objectify(2, @_); } return $x if $x -> modify('blsft'); @@ -2915,7 +3051,15 @@ sub blsft { $y -> {sign} !~ /^[+-]$/); return $x -> round(@r) if $y -> is_zero(); - $b = 2 if !defined $b; + $b = defined($b) ? $b -> numify() : 2; + + # While some of the libraries support an arbitrarily large base, not all of + # them do, so rather than returning an incorrect result in those cases, + # disallow bases that don't work with all libraries. + + my $uintmax = ~0; + croak("Base is too large.") if $b > $uintmax; + return $x -> bnan() if $b <= 0 || $y -> {sign} eq '-'; $x -> {value} = $LIB -> _lsft($x -> {value}, $y -> {value}, $b); @@ -3146,7 +3290,7 @@ sub bround { # do not return $x->bnorm(), but $x my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; my ($scale, $mode) = $x->_scale_a(@_); return $x if !defined $scale || $x->modify('bround'); # no-op @@ -3264,7 +3408,7 @@ sub fround { # Exists to make life easier for switch between MBF and MBI (should we # autoload fxxx() like MBF does for bxxx()?) my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; $x->bround(@_); } @@ -3356,6 +3500,31 @@ sub digit { $LIB->_digit($x->{value}, $n || 0); } +sub bdigitsum { + # like digitsum(), but assigns the result to the invocand + my $x = shift; + + return $x if $x -> is_nan(); + return $x -> bnan() if $x -> is_inf(); + + $x -> {value} = $LIB -> _digitsum($x -> {value}); + $x -> {sign} = '+'; + return $x; +} + +sub digitsum { + # compute sum of decimal digits and return it + my $x = shift; + my $class = ref $x; + + return $class -> bnan() if $x -> is_nan(); + return $class -> bnan() if $x -> is_inf(); + + my $y = $class -> bzero(); + $y -> {value} = $LIB -> _digitsum($x -> {value}); + return $y; +} + sub length { my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_); @@ -3652,7 +3821,7 @@ sub bdstr { sub to_hex { # return as hex string, with prefixed 0x my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3663,7 +3832,7 @@ sub to_hex { sub to_oct { # return as octal string, with prefixed 0 my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3674,7 +3843,7 @@ sub to_oct { sub to_bin { # return as binary string, with prefixed 0b my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3685,7 +3854,7 @@ sub to_bin { sub to_bytes { # return a byte string my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); croak("to_bytes() requires a finite, non-negative integer") if $x -> is_neg() || ! $x -> is_int(); @@ -3699,13 +3868,13 @@ sub to_bytes { sub to_base { # return a base anything string my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); croak("the value to convert must be a finite, non-negative integer") if $x -> is_neg() || !$x -> is_int(); my $base = shift; - $base = $class->new($base) unless ref($base); + $base = __PACKAGE__->new($base) unless ref($base); croak("the base must be a finite integer >= 2") if $base < 2 || ! $base -> is_int(); @@ -3729,7 +3898,7 @@ sub to_base { sub as_hex { # return as hex string, with prefixed 0x my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3740,7 +3909,7 @@ sub as_hex { sub as_oct { # return as octal string, with prefixed 0 my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3751,7 +3920,7 @@ sub as_oct { sub as_bin { # return as binary string, with prefixed 0b my $x = shift; - $x = $class->new($x) if !ref($x); + $x = __PACKAGE__->new($x) if !ref($x); return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc @@ -3768,7 +3937,7 @@ sub as_bin { sub numify { # Make a Perl scalar number from a Math::BigInt object. my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; if ($x -> is_nan()) { require Math::Complex; @@ -3817,7 +3986,7 @@ sub objectify { # Check the context. unless (wantarray) { - croak("${class}::objectify() needs list context"); + croak(__PACKAGE__ . "::objectify() needs list context"); } # Get the number of arguments to objectify. @@ -3935,10 +4104,9 @@ sub objectify { sub import { my $class = shift; $IMPORT++; # remember we did import() - my @a; - my $l = scalar @_; + my @a; # unrecognized arguments my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die - for (my $i = 0; $i < $l ; $i++) { + for (my $i = 0; $i <= $#_ ; $i++) { if ($_[$i] eq ':constant') { # this causes overlord er load to step in overload::constant @@ -3951,7 +4119,9 @@ sub import { } elsif ($_[$i] =~ /^(lib|try|only)\z/) { # this causes a different low lib to take care... $LIB = $_[$i+1] || ''; - # lib => 1 (warn on fallback), try => 0 (no warn), only => 2 (die on fallback) + # try => 0 (no warn) + # lib => 1 (warn on fallback) + # only => 2 (die on fallback) $warn_or_die = 1 if $_[$i] eq 'lib'; $warn_or_die = 2 if $_[$i] eq 'only'; $i++; @@ -3968,77 +4138,34 @@ sub import { # try to load core math lib my @c = split /\s*,\s*/, $LIB; foreach (@c) { - $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters + tr/a-zA-Z0-9://cd; # limit to sane characters } push @c, \'Calc' # if all fail, try these if $warn_or_die < 2; # but not for "only" - $LIB = ''; # signal error + $LIB = ''; # signal error foreach my $l (@c) { # fallback libraries are "marked" as \'string', extract string if nec. my $lib = $l; $lib = $$l if ref($l); - next if ($lib || '') eq ''; + next unless defined($lib) && CORE::length($lib); $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i; $lib =~ s/\.pm$//; - if ($] < 5.006) { - # Perl < 5.6.0 dies with "out of memory!" when eval("") and ':constant' is - # used in the same script, or eval("") inside import(). - my @parts = split /::/, $lib; # Math::BigInt => Math BigInt - my $file = pop @parts; - $file .= '.pm'; # BigInt => BigInt.pm - require File::Spec; - $file = File::Spec->catfile (@parts, $file); - eval { - require "$file"; - $lib->import(@c); - } - } else { - eval "use $lib qw/@c/;"; - } + my @parts = split /::/, $lib; # Math::BigInt => Math BigInt + $parts[-1] .= '.pm'; # BigInt => BigInt.pm + require File::Spec; + my $file = File::Spec->catfile(@parts); + eval { require $file; }; if ($@ eq '') { - my $ok = 1; - # loaded it ok, see if the api_version() is high enough - if ($lib->can('api_version') && $lib->api_version() >= 1.0) { - $ok = 0; - # api_version matches, check if it really provides anything we need - for my $method (qw/ - one two ten - str num - add mul div sub dec inc - acmp len digit is_one is_zero is_even is_odd - is_two is_ten - zeros new copy check - from_hex from_oct from_bin as_hex as_bin as_oct - rsft lsft xor and or - mod sqrt root fac pow modinv modpow log_int gcd - /) { - if (!$lib->can("_$method")) { - if (($WARN{$lib} || 0) < 2) { - carp("$lib is missing method '_$method'"); - $WARN{$lib} = 1; # still warn about the lib - } - $ok++; - last; - } - } - } - if ($ok == 0) { - $LIB = $lib; - if ($warn_or_die > 0 && ref($l)) { - my $msg = "Math::BigInt: couldn't load specified" - . " math lib(s), fallback to $lib"; - carp($msg) if $warn_or_die == 1; - croak($msg) if $warn_or_die == 2; - } - last; # found a usable one, break - } else { - if (($WARN{$lib} || 0) < 2) { - my $ver = eval "\$$lib\::VERSION" || 'unknown'; - carp("Cannot load outdated $lib v$ver, please upgrade"); - $WARN{$lib} = 2; # never warn again - } + $lib->import(); + $LIB = $lib; + if ($warn_or_die > 0 && ref($l)) { + my $msg = "Math::BigInt: couldn't load specified" + . " math lib(s), fallback to $lib"; + carp($msg) if $warn_or_die == 1; + croak($msg) if $warn_or_die == 2; } + last; # found a usable one, break } } if ($LIB eq '') { @@ -4210,7 +4337,7 @@ sub _split { sub _trailing_zeros { # return the amount of trailing zeros in $x (as scalar) my $x = shift; - $x = $class->new($x) unless ref $x; + $x = __PACKAGE__->new($x) unless ref $x; return 0 if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf etc @@ -4423,6 +4550,8 @@ Math::BigInt - Arbitrary size integer/float math package $x->blog($base); # logarithm of $x to base $base (e.g., base 2) $x->bexp(); # calculate e ** $x where e is Euler's number $x->bnok($y); # x over y (binomial coefficient n over k) + $x->buparrow($n, $y); # Knuth's up-arrow notation + $x->backermann($y); # the Ackermann function $x->bsin(); # sine $x->bcos(); # cosine $x->batan(); # inverse tangent @@ -4987,6 +5116,18 @@ neither positive nor negative. Returns true if the invocand is negative and false otherwise. A C<NaN> is neither positive nor negative. +=item is_non_positive() + + $x->is_non_positive(); # true if <= 0 + +Returns true if the invocand is negative or zero. + +=item is_non_negative() + + $x->is_non_negative(); # true if >= 0 + +Returns true if the invocand is positive or zero. + =item is_odd() $x->is_odd(); # true if odd, false for even @@ -5292,6 +5433,38 @@ pseudo-code: The behaviour is identical to the behaviour of the Maple and Mathematica function for negative integers n, k. +=item buparrow() + +=item uparrow() + + $a -> buparrow($n, $b); # modifies $a + $x = $a -> uparrow($n, $b); # does not modify $a + +This method implements Knuth's up-arrow notation, where $n is a non-negative +integer representing the number of up-arrows. $n = 0 gives multiplication, $n = +1 gives exponentiation, $n = 2 gives tetration, $n = 3 gives hexation etc. The +following illustrates the relation between the first values of $n. + +See L<https://en.wikipedia.org/wiki/Knuth%27s_up-arrow_notation>. + +=item backermann() + +=item ackermann() + + $m -> backermann($n); # modifies $a + $x = $m -> ackermann($n); # does not modify $a + +This method implements the Ackermann function: + + / n + 1 if m = 0 + A(m, n) = | A(m-1, 1) if m > 0 and n = 0 + \ A(m-1, A(m, n-1)) if m > 0 and n > 0 + +Its value grows rapidly, even for small inputs. For example, A(4, 2) is an +integer of 19729 decimal digits. + +See https://en.wikipedia.org/wiki/Ackermann_function + =item bsin() my $x = Math::BigInt->new(1); @@ -5590,6 +5763,18 @@ If you want $x to have a certain sign, use one of the following methods: If C<$n> is negative, returns the digit counting from left. +=item digitsum() + + $x->digitsum(); + +Computes the sum of the base 10 digits and returns it. + +=item bdigitsum() + + $x->bdigitsum(); + +Computes the sum of the base 10 digits and assigns the result to the invocand. + =item length() $x->length(); @@ -6696,11 +6881,11 @@ L<http://annocpan.org/dist/Math-BigInt> =item * CPAN Ratings -L<http://cpanratings.perl.org/dist/Math-BigInt> +L<https://cpanratings.perl.org/dist/Math-BigInt> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigInt/> +L<https://metacpan.org/release/Math-BigInt> =item * CPAN Testers Matrix diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm index 2bb06a0976b..cd8f1ee44e6 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Calc.pm @@ -7,7 +7,7 @@ use warnings; use Carp qw< carp croak >; use Math::BigInt::Lib; -our $VERSION = '1.999816'; +our $VERSION = '1.999818'; our @ISA = ('Math::BigInt::Lib'); @@ -35,9 +35,6 @@ our @ISA = ('Math::BigInt::Lib'); ############################################################################## # global constants, flags and accessory -# announce that we are compatible with MBI v1.83 and up -sub api_version () { 2; } - # constants for easier life my ($BASE, $BASE_LEN, $RBASE, $MAX_VAL); my ($AND_BITS, $XOR_BITS, $OR_BITS); @@ -50,9 +47,7 @@ sub _base_len { my ($class, $b, $int) = @_; if (defined $b) { - # avoid redefinitions - undef &_mul; - undef &_div; + no warnings "redefine"; if ($] >= 5.008 && $int && $b > 7) { $BASE_LEN = $b; @@ -403,13 +398,14 @@ sub _mul_use_mul { my ($c, $xv, $yv) = @_; if (@$yv == 1) { - # shortcut for two very short numbers (improved by Nathan Zook) - # works also if xv and yv are the same reference, and handles also $x == 0 + # shortcut for two very short numbers (improved by Nathan Zook) works + # also if xv and yv are the same reference, and handles also $x == 0 if (@$xv == 1) { if (($xv->[0] *= $yv->[0]) >= $BASE) { - $xv->[0] = $xv->[0] - ($xv->[1] = int($xv->[0] * $RBASE)) * $BASE; + my $rem = $xv->[0] % $BASE; + $xv->[1] = ($xv->[0] - $rem) * $RBASE; + $xv->[0] = $rem; } - ; return $xv; } # $x * 0 => 0 @@ -417,56 +413,44 @@ sub _mul_use_mul { @$xv = (0); return $xv; } + # multiply a large number a by a single element one, so speed up my $y = $yv->[0]; my $car = 0; + my $rem; foreach my $i (@$xv) { $i = $i * $y + $car; - $car = int($i * $RBASE); - $i -= $car * $BASE; + $rem = $i % $BASE; + $car = ($i - $rem) * $RBASE; + $i = $rem; } push @$xv, $car if $car != 0; return $xv; } + # shortcut for result $x == 0 => result = 0 return $xv if @$xv == 1 && $xv->[0] == 0; # since multiplying $x with $x fails, make copy in this case - $yv = [ @$xv ] if $xv == $yv; # same references? + $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); - my ($prod, $car, $cty, $xi, $yi); - + my ($prod, $rem, $car, $cty, $xi, $yi); for $xi (@$xv) { $car = 0; $cty = 0; - - # slow variant - # for $yi (@$yv) - # { - # $prod = $xi * $yi + ($prod[$cty] || 0) + $car; - # $prod[$cty++] = - # $prod - ($car = int($prod * RBASE)) * $BASE; # see USE_MUL - # } - # $prod[$cty] += $car if $car; # need really to check for 0? - # $xi = shift @prod; - - # faster variant # looping through this if $xi == 0 is silly - so optimize it away! - $xi = (shift @prod || 0), next if $xi == 0; + $xi = (shift(@prod) || 0), next if $xi == 0; for $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; - ## this is actually a tad slower - ## $prod = $prod[$cty]; $prod += ($car + $xi * $yi); # no ||0 here - $prod[$cty++] = - $prod - ($car = int($prod * $RBASE)) * $BASE; # see USE_MUL + $rem = $prod % $BASE; + $car = int(($prod - $rem) * $RBASE); + $prod[$cty++] = $rem; } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy + $prod[$cty] += $car if $car; # need really to check for 0? + $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; - # can't have leading zeros - # __strip_zeros($xv); $xv; } @@ -478,11 +462,11 @@ sub _mul_use_div_64 { my ($c, $xv, $yv) = @_; use integer; + if (@$yv == 1) { - # shortcut for two small numbers, also handles $x == 0 + # shortcut for two very short numbers (improved by Nathan Zook) works + # also if xv and yv are the same reference, and handles also $x == 0 if (@$xv == 1) { - # shortcut for two very short numbers (improved by Nathan Zook) - # works also if xv and yv are the same reference, and handles also $x == 0 if (($xv->[0] *= $yv->[0]) >= $BASE) { $xv->[0] = $xv->[0] - ($xv->[1] = $xv->[0] / $BASE) * $BASE; @@ -494,6 +478,7 @@ sub _mul_use_div_64 { @$xv = (0); return $xv; } + # multiply a large number a by a single element one, so speed up my $y = $yv->[0]; my $car = 0; @@ -505,11 +490,12 @@ sub _mul_use_div_64 { push @$xv, $car if $car != 0; return $xv; } + # shortcut for result $x == 0 => result = 0 - return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); + return $xv if @$xv == 1 && $xv->[0] == 0; # since multiplying $x with $x fails, make copy in this case - $yv = $c->_copy($xv) if $xv == $yv; # same references? + $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); my ($prod, $car, $cty, $xi, $yi); @@ -517,13 +503,13 @@ sub _mul_use_div_64 { $car = 0; $cty = 0; # looping through this if $xi == 0 is silly - so optimize it away! - $xi = (shift @prod || 0), next if $xi == 0; + $xi = (shift(@prod) || 0), next if $xi == 0; for $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; $prod[$cty++] = $prod - ($car = $prod / $BASE) * $BASE; } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy + $prod[$cty] += $car if $car; # need really to check for 0? + $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; $xv; @@ -536,15 +522,14 @@ sub _mul_use_div { my ($c, $xv, $yv) = @_; if (@$yv == 1) { - # shortcut for two small numbers, also handles $x == 0 + # shortcut for two very short numbers (improved by Nathan Zook) works + # also if xv and yv are the same reference, and handles also $x == 0 if (@$xv == 1) { - # shortcut for two very short numbers (improved by Nathan Zook) - # works also if xv and yv are the same reference, and handles also $x == 0 if (($xv->[0] *= $yv->[0]) >= $BASE) { - $xv->[0] = - $xv->[0] - ($xv->[1] = int($xv->[0] / $BASE)) * $BASE; + my $rem = $xv->[0] % $BASE; + $xv->[1] = ($xv->[0] - $rem) / $BASE; + $xv->[0] = $rem; } - ; return $xv; } # $x * 0 => 0 @@ -552,42 +537,44 @@ sub _mul_use_div { @$xv = (0); return $xv; } + # multiply a large number a by a single element one, so speed up my $y = $yv->[0]; my $car = 0; + my $rem; foreach my $i (@$xv) { $i = $i * $y + $car; - $car = int($i / $BASE); - $i -= $car * $BASE; - # This (together with use integer;) does not work on 32-bit Perls - #$i = $i * $y + $car; $i -= ($car = $i / $BASE) * $BASE; + $rem = $i % $BASE; + $car = ($i - $rem) / $BASE; + $i = $rem; } push @$xv, $car if $car != 0; return $xv; } + # shortcut for result $x == 0 => result = 0 - return $xv if ( ((@$xv == 1) && ($xv->[0] == 0)) ); + return $xv if @$xv == 1 && $xv->[0] == 0; # since multiplying $x with $x fails, make copy in this case - $yv = $c->_copy($xv) if $xv == $yv; # same references? + $yv = $c->_copy($xv) if $xv == $yv; # same references? my @prod = (); - my ($prod, $car, $cty, $xi, $yi); + my ($prod, $rem, $car, $cty, $xi, $yi); for $xi (@$xv) { $car = 0; $cty = 0; # looping through this if $xi == 0 is silly - so optimize it away! - $xi = (shift @prod || 0), next if $xi == 0; + $xi = (shift(@prod) || 0), next if $xi == 0; for $yi (@$yv) { $prod = $xi * $yi + ($prod[$cty] || 0) + $car; - $prod[$cty++] = $prod - ($car = int($prod / $BASE)) * $BASE; + $rem = $prod % $BASE; + $car = ($prod - $rem) / $BASE; + $prod[$cty++] = $rem; } - $prod[$cty] += $car if $car; # need really to check for 0? - $xi = shift @prod || 0; # || 0 makes v5.005_3 happy + $prod[$cty] += $car if $car; # need really to check for 0? + $xi = shift(@prod) || 0; # || 0 makes v5.005_3 happy } push @$xv, @prod; - # can't have leading zeros - # __strip_zeros($xv); $xv; } @@ -595,28 +582,19 @@ sub _div_use_mul { # ref to array, ref to array, modify first array and return remainder if # in list context - # see comments in _div_use_div() for more explanations - my ($c, $x, $yorg) = @_; # the general div algorithm here is about O(N*N) and thus quite slow, so # we first check for some special cases and use shortcuts to handle them. - # This works, because we store the numbers in a chunked format where each - # element contains 5..7 digits (depending on system). - # if both numbers have only one element: if (@$x == 1 && @$yorg == 1) { # shortcut, $yorg and $x are two small numbers - if (wantarray) { - my $rem = [ $x->[0] % $yorg->[0] ]; - bless $rem, $c; - $x->[0] = int($x->[0] / $yorg->[0]); - return ($x, $rem); - } else { - $x->[0] = int($x->[0] / $yorg->[0]); - return $x; - } + my $rem = [ $x->[0] % $yorg->[0] ]; + bless $rem, $c; + $x->[0] = ($x->[0] - $rem->[0]) / $yorg->[0]; + return ($x, $rem) if wantarray; + return $x; } # if x has more than one, but y has only one element: @@ -631,120 +609,120 @@ sub _div_use_mul { my $b; while ($j-- > 0) { $b = $r * $BASE + $x->[$j]; - $x->[$j] = int($b/$y); $r = $b % $y; + $x->[$j] = ($b - $r) / $y; } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero + pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero return ($x, $rem) if wantarray; return $x; } # now x and y have more than one element - # check whether y has more elements than x, if yet, the result will be 0 + # check whether y has more elements than x, if so, the result is 0 if (@$yorg > @$x) { my $rem; - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now + $rem = $c->_copy($x) if wantarray; # make copy + @$x = 0; # set to 0 + return ($x, $rem) if wantarray; # including remainder? + return $x; # only x, which is [0] now } + # check whether the numbers have the same number of elements, in that case # the result will fit into one element and can be computed efficiently if (@$yorg == @$x) { + my $cmp = 0; + for (my $j = $#$x ; $j >= 0 ; --$j) { + last if $cmp = $x->[$j] - $yorg->[$j]; + } - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) { - my $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? + if ($cmp == 0) { # x = y + @$x = 1; + return $x, $c->_zero() if wantarray; return $x; } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) { - # same length, so make full compare - my $a = 0; - my $j = @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) { - last if ($a = $x->[$j] - $yorg->[$j]); - $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) { - # a = 0 => x == y => rem 0 - # a < 0 => x < y => rem = x - my $rem = $a == 0 ? $c->_zero() : $c->_copy($x); - @$x = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x, $rem) if wantarray; - return $x; + if ($cmp < 0) { # x < y + if (wantarray) { + my $rem = $c->_copy($x); + @$x = 0; + return $x, $rem; } - # $x >= $y, so proceed normally + @$x = 0; + return $x; } } # all other cases: - my $y = $c->_copy($yorg); # always make copy to preserve + my $y = $c->_copy($yorg); # always make copy to preserve - my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, $tmp, $q, $u2, $u1, $u0); - - $car = $bar = $prd = 0; - if (($dd = int($BASE / ($y->[-1] + 1))) != 1) { - for $xi (@$x) { + my $tmp = $y->[-1] + 1; + my $rem = $BASE % $tmp; + my $dd = ($BASE - $rem) / $tmp; + if ($dd != 1) { + my $car = 0; + for my $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL + $xi -= ($car = int($xi * $RBASE)) * $BASE; # see USE_MUL } push(@$x, $car); $car = 0; - for $yi (@$y) { + for my $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL + $yi -= ($car = int($yi * $RBASE)) * $BASE; # see USE_MUL } } else { push(@$x, 0); } - @q = (); - ($v2, $v1) = @$y[-2, -1]; + + # @q will accumulate the final result, $q contains the current computed + # part of the final result + + my @q = (); + my ($v2, $v1) = @$y[-2, -1]; $v2 = 0 unless $v2; while ($#$x > $#$y) { - ($u2, $u1, $u0) = @$x[-3 .. -1]; + my ($u2, $u1, $u0) = @$x[-3 .. -1]; $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1)); - --$q while ($v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2); + my $tmp = $u0 * $BASE + $u1; + my $rem = $tmp % $v1; + my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); + --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; if ($q) { - ($car, $bar) = (0, 0); - for ($yi = 0, $xi = $#$x - $#$y-1; $yi <= $#$y; ++$yi, ++$xi) { + my $prd; + my ($car, $bar) = (0, 0); + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $prd -= ($car = int($prd * $RBASE)) * $BASE; # see USE_MUL + $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; - for ($yi = 0, $xi = $#$x - $#$y-1; $yi <= $#$y; ++$yi, ++$xi) { + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE)); + if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); } } } pop(@$x); unshift(@q, $q); } + if (wantarray) { my $d = bless [], $c; if ($dd != 1) { - $car = 0; - for $xi (reverse @$x) { + my $car = 0; + my ($prd, $rem); + for my $xi (reverse @$x) { $prd = $car * $BASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; # see USE_MUL - unshift(@$d, $tmp); + $rem = $prd % $dd; + $tmp = ($prd - $rem) / $dd; + $car = $rem; + unshift @$d, $tmp; } } else { @$d = @$x; @@ -762,29 +740,29 @@ sub _div_use_mul { sub _div_use_div_64 { # ref to array, ref to array, modify first array and return remainder if # in list context - # This version works on 64 bit integers - my ($c, $x, $yorg) = @_; + # This version works on integers use integer; + + my ($c, $x, $yorg) = @_; + # the general div algorithm here is about O(N*N) and thus quite slow, so # we first check for some special cases and use shortcuts to handle them. - # This works, because we store the numbers in a chunked format where each - # element contains 5..7 digits (depending on system). - # if both numbers have only one element: if (@$x == 1 && @$yorg == 1) { # shortcut, $yorg and $x are two small numbers if (wantarray) { my $rem = [ $x->[0] % $yorg->[0] ]; bless $rem, $c; - $x->[0] = int($x->[0] / $yorg->[0]); + $x->[0] = $x->[0] / $yorg->[0]; return ($x, $rem); } else { - $x->[0] = int($x->[0] / $yorg->[0]); + $x->[0] = $x->[0] / $yorg->[0]; return $x; } } + # if x has more than one, but y has only one element: if (@$yorg == 1) { my $rem; @@ -797,78 +775,67 @@ sub _div_use_div_64 { my $b; while ($j-- > 0) { $b = $r * $BASE + $x->[$j]; - $x->[$j] = int($b/$y); $r = $b % $y; + $x->[$j] = $b / $y; } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero + pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero return ($x, $rem) if wantarray; return $x; } + # now x and y have more than one element - # check whether y has more elements than x, if yet, the result will be 0 + # check whether y has more elements than x, if so, the result is 0 if (@$yorg > @$x) { my $rem; - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now + $rem = $c->_copy($x) if wantarray; # make copy + @$x = 0; # set to 0 + return ($x, $rem) if wantarray; # including remainder? + return $x; # only x, which is [0] now } + # check whether the numbers have the same number of elements, in that case # the result will fit into one element and can be computed efficiently if (@$yorg == @$x) { - my $rem; - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) { - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; + my $cmp = 0; + for (my $j = $#$x ; $j >= 0 ; --$j) { + last if $cmp = $x->[$j] - $yorg->[$j]; } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) { - # same length, so make full compare + if ($cmp == 0) { # x = y + @$x = 1; + return $x, $c->_zero() if wantarray; + return $x; + } - my $a = 0; - my $j = @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) { - last if ($a = $x->[$j] - $yorg->[$j]); - $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) { - $rem = $c->_zero(); # a = 0 => x == y => rem 0 - $rem = $c->_copy($x) if $a != 0; # a < 0 => x < y => rem = x - @$x = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x, $rem) if wantarray; # including remainder? - return $x; + if ($cmp < 0) { # x < y + if (wantarray) { + my $rem = $c->_copy($x); + @$x = 0; + return $x, $rem; } - # $x >= $y, so proceed normally + @$x = 0; + return $x; } } # all other cases: - my $y = $c->_copy($yorg); # always make copy to preserve - - my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, $tmp, $q, $u2, $u1, $u0); + my $y = $c->_copy($yorg); # always make copy to preserve - $car = $bar = $prd = 0; - if (($dd = int($BASE / ($y->[-1] + 1))) != 1) { - for $xi (@$x) { + my $tmp; + my $dd = $BASE / ($y->[-1] + 1); + if ($dd != 1) { + my $car = 0; + for my $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi / $BASE)) * $BASE; + $xi -= ($car = $xi / $BASE) * $BASE; } push(@$x, $car); $car = 0; - for $yi (@$y) { + for my $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi / $BASE)) * $BASE; + $yi -= ($car = $yi / $BASE) * $BASE; } } else { push(@$x, 0); @@ -877,43 +844,48 @@ sub _div_use_div_64 { # @q will accumulate the final result, $q contains the current computed # part of the final result - @q = (); - ($v2, $v1) = @$y[-2, -1]; + my @q = (); + my ($v2, $v1) = @$y[-2, -1]; $v2 = 0 unless $v2; while ($#$x > $#$y) { - ($u2, $u1, $u0) = @$x[-3..-1]; + my ($u2, $u1, $u0) = @$x[-3 .. -1]; $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1)); - --$q while ($v2 * $q > ($u0 * $BASE +$ u1- $q*$v1) * $BASE + $u2); + my $tmp = $u0 * $BASE + $u1; + my $rem = $tmp % $v1; + my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); + --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; if ($q) { - ($car, $bar) = (0, 0); - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + my $prd; + my ($car, $bar) = (0, 0); + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $prd = $q * $y->[$yi] + $car; $prd -= ($car = int($prd / $BASE)) * $BASE; - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE)); + if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); } } } pop(@$x); unshift(@q, $q); } + if (wantarray) { my $d = bless [], $c; if ($dd != 1) { - $car = 0; - for $xi (reverse @$x) { + my $car = 0; + my $prd; + for my $xi (reverse @$x) { $prd = $car * $BASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; - unshift(@$d, $tmp); + $car = $prd - ($tmp = $prd / $dd) * $dd; + unshift @$d, $tmp; } } else { @$d = @$x; @@ -931,27 +903,22 @@ sub _div_use_div_64 { sub _div_use_div { # ref to array, ref to array, modify first array and return remainder if # in list context + my ($c, $x, $yorg) = @_; # the general div algorithm here is about O(N*N) and thus quite slow, so # we first check for some special cases and use shortcuts to handle them. - # This works, because we store the numbers in a chunked format where each - # element contains 5..7 digits (depending on system). - # if both numbers have only one element: if (@$x == 1 && @$yorg == 1) { # shortcut, $yorg and $x are two small numbers - if (wantarray) { - my $rem = [ $x->[0] % $yorg->[0] ]; - bless $rem, $c; - $x->[0] = int($x->[0] / $yorg->[0]); - return ($x, $rem); - } else { - $x->[0] = int($x->[0] / $yorg->[0]); - return $x; - } + my $rem = [ $x->[0] % $yorg->[0] ]; + bless $rem, $c; + $x->[0] = ($x->[0] - $rem->[0]) / $yorg->[0]; + return ($x, $rem) if wantarray; + return $x; } + # if x has more than one, but y has only one element: if (@$yorg == 1) { my $rem; @@ -964,80 +931,72 @@ sub _div_use_div { my $b; while ($j-- > 0) { $b = $r * $BASE + $x->[$j]; - $x->[$j] = int($b/$y); $r = $b % $y; + $x->[$j] = ($b - $r) / $y; } - pop @$x if @$x > 1 && $x->[-1] == 0; # splice up a leading zero + pop(@$x) if @$x > 1 && $x->[-1] == 0; # remove any trailing zero return ($x, $rem) if wantarray; return $x; } + # now x and y have more than one element - # check whether y has more elements than x, if yet, the result will be 0 + # check whether y has more elements than x, if so, the result is 0 if (@$yorg > @$x) { my $rem; - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; # only x, which is [0] now + $rem = $c->_copy($x) if wantarray; # make copy + @$x = 0; # set to 0 + return ($x, $rem) if wantarray; # including remainder? + return $x; # only x, which is [0] now } + # check whether the numbers have the same number of elements, in that case # the result will fit into one element and can be computed efficiently if (@$yorg == @$x) { - my $rem; - # if $yorg has more digits than $x (it's leading element is longer than - # the one from $x), the result will also be 0: - if (length(int($yorg->[-1])) > length(int($x->[-1]))) { - $rem = $c->_copy($x) if wantarray; # make copy - @$x = 0; # set to 0 - return ($x, $rem) if wantarray; # including remainder? - return $x; + my $cmp = 0; + for (my $j = $#$x ; $j >= 0 ; --$j) { + last if $cmp = $x->[$j] - $yorg->[$j]; } - # now calculate $x / $yorg - if (length(int($yorg->[-1])) == length(int($x->[-1]))) { - # same length, so make full compare + if ($cmp == 0) { # x = y + @$x = 1; + return $x, $c->_zero() if wantarray; + return $x; + } - my $a = 0; - my $j = @$x - 1; - # manual way (abort if unequal, good for early ne) - while ($j >= 0) { - last if ($a = $x->[$j] - $yorg->[$j]); - $j--; - } - # $a contains the result of the compare between X and Y - # a < 0: x < y, a == 0: x == y, a > 0: x > y - if ($a <= 0) { - $rem = $c->_zero(); # a = 0 => x == y => rem 0 - $rem = $c->_copy($x) if $a != 0; # a < 0 => x < y => rem = x + if ($cmp < 0) { # x < y + if (wantarray) { + my $rem = $c->_copy($x); @$x = 0; - $x->[0] = 0; # if $a < 0 - $x->[0] = 1 if $a == 0; # $x == $y - return ($x, $rem) if wantarray; # including remainder? - return $x; + return $x, $rem; } - # $x >= $y, so proceed normally - + @$x = 0; + return $x; } } # all other cases: - my $y = $c->_copy($yorg); # always make copy to preserve - - my ($car, $bar, $prd, $dd, $xi, $yi, @q, $v2, $v1, @d, $tmp, $q, $u2, $u1, $u0); + my $y = $c->_copy($yorg); # always make copy to preserve - $car = $bar = $prd = 0; - if (($dd = int($BASE / ($y->[-1] + 1))) != 1) { - for $xi (@$x) { + my $tmp = $y->[-1] + 1; + my $rem = $BASE % $tmp; + my $dd = ($BASE - $rem) / $tmp; + if ($dd != 1) { + my $car = 0; + for my $xi (@$x) { $xi = $xi * $dd + $car; - $xi -= ($car = int($xi / $BASE)) * $BASE; + $rem = $xi % $BASE; + $car = ($xi - $rem) / $BASE; + $xi = $rem; } push(@$x, $car); $car = 0; - for $yi (@$y) { + for my $yi (@$y) { $yi = $yi * $dd + $car; - $yi -= ($car = int($yi / $BASE)) * $BASE; + $rem = $yi % $BASE; + $car = ($yi - $rem) / $BASE; + $yi = $rem; } } else { push(@$x, 0); @@ -1046,43 +1005,52 @@ sub _div_use_div { # @q will accumulate the final result, $q contains the current computed # part of the final result - @q = (); - ($v2, $v1) = @$y[-2, -1]; + my @q = (); + my ($v2, $v1) = @$y[-2, -1]; $v2 = 0 unless $v2; while ($#$x > $#$y) { - ($u2, $u1, $u0) = @$x[-3..-1]; + my ($u2, $u1, $u0) = @$x[-3 .. -1]; $u2 = 0 unless $u2; #warn "oups v1 is 0, u0: $u0 $y->[-2] $y->[-1] l ",scalar @$y,"\n" # if $v1 == 0; - $q = (($u0 == $v1) ? $MAX_VAL : int(($u0 * $BASE + $u1) / $v1)); - --$q while ($v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2); + my $tmp = $u0 * $BASE + $u1; + my $rem = $tmp % $v1; + my $q = $u0 == $v1 ? $MAX_VAL : (($tmp - $rem) / $v1); + --$q while $v2 * $q > ($u0 * $BASE + $u1 - $q * $v1) * $BASE + $u2; if ($q) { - ($car, $bar) = (0, 0); - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + my $prd; + my ($car, $bar) = (0, 0); + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $prd = $q * $y->[$yi] + $car; - $prd -= ($car = int($prd / $BASE)) * $BASE; - $x->[$xi] += $BASE if ($bar = (($x->[$xi] -= $prd + $bar) < 0)); + $rem = $prd % $BASE; + $car = ($prd - $rem) / $BASE; + $prd -= $car * $BASE; + $x->[$xi] += $BASE if $bar = (($x->[$xi] -= $prd + $bar) < 0); } if ($x->[-1] < $car + $bar) { $car = 0; --$q; - for ($yi = 0, $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { + for (my $yi = 0, my $xi = $#$x - $#$y - 1; $yi <= $#$y; ++$yi, ++$xi) { $x->[$xi] -= $BASE - if ($car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE)); + if $car = (($x->[$xi] += $y->[$yi] + $car) >= $BASE); } } } pop(@$x); unshift(@q, $q); } + if (wantarray) { my $d = bless [], $c; if ($dd != 1) { - $car = 0; - for $xi (reverse @$x) { + my $car = 0; + my ($prd, $rem); + for my $xi (reverse @$x) { $prd = $car * $BASE + $xi; - $car = $prd - ($tmp = int($prd / $dd)) * $dd; - unshift(@$d, $tmp); + $rem = $prd % $dd; + $tmp = ($prd - $rem) / $dd; + $car = $rem; + unshift @$d, $tmp; } } else { @$d = @$x; @@ -1385,7 +1353,7 @@ sub _rsft { $dst++; } splice(@$x, $dst) if $dst > 0; # kill left-over array elems - pop @$x if $x->[-1] == 0 && @$x > 1; # kill last element if 0 + pop(@$x) if $x->[-1] == 0 && @$x > 1; # kill last element if 0 } # else rem == 0 $x; } @@ -1393,49 +1361,64 @@ sub _rsft { sub _lsft { my ($c, $x, $n, $b) = @_; - return $x if $c->_is_zero($x); - - # Handle the special case when the base is a power of 10. Don't check - # whether log($b)/log(10) is an integer, because log(1000)/log(10) is not - # exactly 3. - - my $log10 = sprintf "%.0f", log($b) / log(10); - if ($b == 10 ** $log10) { - $b = 10; - $n = $c->_mul($n, $c->_new($log10)); - - # shortcut (faster) for shifting by 10) since we are in base 10eX - # multiples of $BASE_LEN: - my $src = @$x; # source - my $len = $c->_num($n); # shift-len as normal int - my $rem = $len % $BASE_LEN; # remainder to shift - my $dst = $src + int($len / $BASE_LEN); # destination - my $vd; # further speedup - $x->[$src] = 0; # avoid first ||0 for speed - my $z = '0' x $BASE_LEN; - while ($src >= 0) { - $vd = $x->[$src]; - $vd = $z . $vd; - $vd = substr($vd, -$BASE_LEN + $rem, $BASE_LEN - $rem); - $vd .= $src > 0 ? substr($z . $x->[$src - 1], -$BASE_LEN, $rem) - : '0' x $rem; - $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN; - $x->[$dst] = int($vd); - $dst--; - $src--; + return $x if $c->_is_zero($x) || $c->_is_zero($n); + + # For backwards compatibility, allow the base $b to be a scalar. + + $b = $c->_new($b) unless ref $b; + + # If the base is a power of 10, use shifting, since the internal + # representation is in base 10eX. + + my $bstr = $c->_str($b); + if ($bstr =~ /^1(0+)\z/) { + + # Adjust $n so that we're shifting in base 10. Do this by multiplying + # $n by the base 10 logarithm of $b: $b ** $n = 10 ** (log10($b) * $n). + + my $log10b = length($1); + $n = $c->_mul($c->_new($log10b), $n); + $n = $c->_num($n); # shift-len as normal int + + # $q is the number of places to shift the elements within the array, + # and $r is the number of places to shift the values within the + # elements. + + my $r = $n % $BASE_LEN; + my $q = ($n - $r) / $BASE_LEN; + + # If we must shift the values within the elements ... + + if ($r) { + my $i = @$x; # index + $x->[$i] = 0; # initialize most significant element + my $z = '0' x $BASE_LEN; + my $vd; + while ($i >= 0) { + $vd = $x->[$i]; + $vd = $z . $vd; + $vd = substr($vd, $r - $BASE_LEN, $BASE_LEN - $r); + $vd .= $i > 0 ? substr($z . $x->[$i - 1], -$BASE_LEN, $r) + : '0' x $r; + $vd = substr($vd, -$BASE_LEN, $BASE_LEN) if length($vd) > $BASE_LEN; + $x->[$i] = int($vd); # e.g., "0...048" -> 48 etc. + $i--; + } + + pop(@$x) if $x->[-1] == 0; # if most significant element is zero } - # set lowest parts to 0 - while ($dst >= 0) { - $x->[$dst--] = 0; + + # If we must shift the elements within the array ... + + if ($q) { + unshift @$x, (0) x $q; } - # fix spurious last zero element - splice @$x, -1 if $x->[-1] == 0; - return $x; + } else { - $b = $c->_new($b); - #print $c->_str($b); - return $c->_mul($x, $c->_pow($b, $n)); + $x = $c->_mul($x, $c->_pow($b, $n)); } + + return $x; } sub _pow { diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Scalar.pm b/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Scalar.pm index 1bfd338d981..d703806bcce 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Scalar.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Scalar.pm @@ -14,8 +14,6 @@ our @ISA = qw(Exporter); our $VERSION = '0.13'; -sub api_version() { 1; } - ############################################################################## # global constants, flags and accessory diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbf.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbf.t index 51377400c12..c8184cb8610 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbf.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbf.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2818; +use Test::More tests => 2830; use lib 't'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbi.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbi.t index 7003104913e..7c24404738a 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbi.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bare_mbi.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 4026; # tests in require'd file +use Test::More tests => 4038; # tests in require'd file use lib 't'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.inc b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.inc index 4858e2e983f..af6e422e882 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.inc +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.inc @@ -37,7 +37,7 @@ while (<DATA>) { $try = qq|\$x = $CLASS->new("$args[0]");|; if ($f eq "bnorm") { $try .= qq| \$x;|; - } elsif ($f =~ /^is_(zero|one|odd|even|negative|positive|nan|int)$/) { + } elsif ($f =~ /^is_(zero|one|odd|even||(non_)?(negative|positive)|nan|int)$/) { $try .= qq| \$x->$f();|; } elsif ($f eq "is_inf") { $try .= qq| \$x->is_inf("$args[1]");|; @@ -2183,6 +2183,22 @@ NaN:0 -inf:1 +inf:0 +&is_non_positive +0:1 +1:0 +-1:1 +NaN:0 +-inf:1 ++inf:0 + +&is_non_negative +0:1 +1:1 +-1:0 +NaN:0 +-inf:0 ++inf:1 + &parts 0:0 0 1:1 0 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.t index 992ee0416ad..8b0079fedc9 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigfltpm.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2818 # tests in require'd file +use Test::More tests => 2830 # tests in require'd file + 19; # tests in this file use Math::BigInt only => 'Calc'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintc.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintc.t index 517da4601da..f9c16d233b0 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintc.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintc.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 379; +use Test::More tests => 460; use Math::BigInt::Calc; @@ -261,6 +261,27 @@ $y = $LIB->_new("45"); is($LIB->_str($LIB->_rsft($x, $y, 10)), 0, qq|$LIB->_str($LIB->_rsft(\$x, \$y, 10)) = 0|); +# _lsft() with large bases + +for my $xstr ("1", "2", "3") { + for my $nstr ("1", "2", "3") { + for my $bpow (25, 50, 75) { + my $bstr = "1" . ("0" x $bpow); + my $expected = $xstr . ("0" x ($bpow * $nstr)); + my $xobj = $LIB->_new($xstr); + my $nobj = $LIB->_new($nstr); + my $bobj = $LIB->_new($bstr); + + is($LIB->_str($LIB->_lsft($xobj, $nobj, $bobj)), $expected, + qq|$LIB->_str($LIB->_lsft($LIB->_new("$xstr"), | + . qq|$LIB->_new("$nstr"), | + . qq|$LIB->_new("$bstr")))|); + is($LIB->_str($nobj), $nstr, q|$n is unmodified|); + is($LIB->_str($bobj), $bstr, q|$b is unmodified|); + } + } +} + # _acmp $x = $LIB->_new("123456789"); diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.inc b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.inc index d98807f4bfd..9dd331ab175 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.inc +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.inc @@ -68,7 +68,7 @@ while (<DATA>) { $try = qq|\$x = $CLASS->new("$args[0]");|; if ($f eq "bnorm") { $try = qq|\$x = $CLASS->bnorm("$args[0]");|; - } elsif ($f =~ /^is_(zero|one|odd|even|negative|positive|nan|int)$/) { + } elsif ($f =~ /^is_(zero|one|odd|even|(non_)?(negative|positive)|nan|int)$/) { $try .= " \$x->$f() || 0;"; } elsif ($f eq "is_inf") { $try .= qq| \$x->is_inf("$args[1]");|; @@ -787,17 +787,26 @@ SKIP: { my @bl = $LIB->_base_len(); my $bl = $bl[5]; - $x = '1' x $bl . '0' x $bl . '1' x $bl . '0' x $bl; + # Compute the value. + $x = ('1' x $bl) . ('0' x $bl) . ('1' x $bl) . ('0' x $bl); $y = '1' x (2 * $bl); $x = $CLASS->new($x)->bmul($y); - # result is 123..$bl . $bl x (3*bl-1) . $bl...321 . '0' x $bl + + # Build the expected output. $y = ''; - my $d = ''; - for (my $i = 1; $i <= $bl; $i++) { - $y .= $i; - $d = $i . $d; + if ($bl >= 2) { + $y .= '123456790' x int(($bl - 2) / 9); + $y .= substr '123456790', 0, ($bl - 2) % 9; + $y .= ($bl - 1) % 9; + } + $y .= ((($bl - 1) % 9) + 1) x ($bl * 3); + if ($bl >= 2) { + $y .= substr '098765432', -(($bl - 1) % 9); + $y .= '098765432' x int(($bl - 2) / 9); } - $y .= $bl x (3 * $bl - 1) . $d . '0' x $bl; + $y .= '1'; + $y .= '0' x $bl; + is($x, $y, "testing number with a zero-hole of BASE_LEN_SMALL"); ######################################################################### @@ -1077,6 +1086,22 @@ invalid:0 -inf:0 invalid:0 +&is_non_negative +0:1 +-1:0 +1:1 ++inf:1 +-inf:0 +NaN:0 + +&is_non_positive +0:1 +-1:1 +1:0 ++inf:0 +-inf:1 +NaN:0 + &is_int -inf:0 +inf:0 @@ -2850,9 +2875,9 @@ abc:12:NaN -inf:NaN:NaN # -3:-inf:0 --3:-3:NaN --3:-2:NaN --3:-1:NaN +-3:-3:0 +-3:-2:0 +-3:-1:0 -3:0:1 -3:1:-3 -3:2:9 @@ -2861,9 +2886,9 @@ abc:12:NaN -3:NaN:NaN # -2:-inf:0 --2:-3:NaN --2:-2:NaN --2:-1:NaN +-2:-3:0 +-2:-2:0 +-2:-1:0 -2:0:1 -2:1:-2 -2:2:4 @@ -2905,9 +2930,9 @@ abc:12:NaN 1:NaN:NaN # 2:-inf:0 -2:-3:NaN -2:-2:NaN -2:-1:NaN +2:-3:0 +2:-2:0 +2:-1:0 2:0:1 2:1:2 2:2:4 @@ -2916,9 +2941,9 @@ abc:12:NaN 2:NaN:NaN # 3:-inf:0 -3:-3:NaN -3:-2:NaN -3:-1:NaN +3:-3:0 +3:-2:0 +3:-1:0 3:0:1 3:1:3 3:2:9 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.t index 1616064745f..7d05dc9e98f 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bigintpm.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 4026 # tests in require'd file +use Test::More tests => 4038 # tests in require'd file + 20; # tests in this file use Math::BigInt only => 'Calc'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling.t index be72db4a8dd..c3c9affebb2 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling.t @@ -6,7 +6,7 @@ use strict; use warnings; use lib 't'; -my $VERSION = '1.999816'; # adjust manually to match latest release +my $VERSION = '1.999818'; # adjust manually to match latest release use Test::More tests => 5; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbf.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbf.t index 584ea675e7b..2f5d3fc1e79 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbf.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbf.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2818 # tests in require'd file +use Test::More tests => 2830 # tests in require'd file + 6; # tests in this file use lib 't'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbi.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbi.t index 3ee6953afa2..97bcdee397e 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbi.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/sub_mbi.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 4026 # tests in require'd file +use Test::More tests => 4038 # tests in require'd file + 5; # tests in this file use lib 't'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.inc b/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.inc index 9cdba4edfb6..d58376f2444 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.inc +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.inc @@ -80,7 +80,7 @@ while (<DATA>) { $try = qq|\$x = $CLASS->new("$args[0]");|; if ($f eq "bnorm") { $try = qq|\$x = $CLASS->bnorm("$args[0]");|; - } elsif ($f =~ /^is_(zero|one|odd|even|negative|positive|nan|int)$/) { + } elsif ($f =~ /^is_(zero|one|odd|even||(non_)?(negative|positive)|nan|int)$/) { $try .= " \$x->$f();"; } elsif ($f =~ /^(to|as)_(hex|oct|bin)$/) { $try .= " \$x->$f();"; @@ -304,6 +304,22 @@ NaNneg:0 -inf:0 NaNneg:0 +&is_non_negative +0:1 +-1:0 +1:1 ++inf:1 +-inf:0 +NaN:0 + +&is_non_positive +0:1 +-1:1 +1:0 ++inf:0 +-inf:1 +NaN:0 + &is_odd abc:0 0:0 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.t index b373ceb56ae..552c8ae5117 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/upgrade.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 2196 # tests in require'd file +use Test::More tests => 2208 # tests in require'd file + 2; # tests in this file use Math::BigInt upgrade => 'Math::BigFloat'; diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/with_sub.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/with_sub.t index ca789275124..0ce15d10cb9 100755 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/with_sub.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/with_sub.t @@ -5,7 +5,7 @@ use strict; use warnings; -use Test::More tests => 2818 # tests in require'd file +use Test::More tests => 2830 # tests in require'd file + 1; # tests in this file use Math::BigFloat with => 'Math::BigInt::Subclass', diff --git a/gnu/usr.bin/perl/cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm b/gnu/usr.bin/perl/cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm index 89e22b57207..b0685d2ec12 100644 --- a/gnu/usr.bin/perl/cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm +++ b/gnu/usr.bin/perl/cpan/Module-Load-Conditional/lib/Module/Load/Conditional.pm @@ -22,7 +22,7 @@ BEGIN { $FIND_VERSION $ERROR $CHECK_INC_HASH $FORCE_SAFE_INC ]; use Exporter; @ISA = qw[Exporter]; - $VERSION = '0.68'; + $VERSION = '0.70'; $VERBOSE = 0; $DEPRECATED = 0; $FIND_VERSION = 1; @@ -259,13 +259,19 @@ sub check_install { last DIR unless $FIND_VERSION; ### otherwise, the user wants us to find the version from files - my $mod_info = Module::Metadata->new_from_handle( $fh, $filename ); - my $ver = $mod_info->version( $args->{module} ); - if( defined $ver ) { - $href->{version} = $ver; + { + local $SIG{__WARN__} = sub {}; + my $ver = eval { + my $mod_info = Module::Metadata->new_from_handle( $fh, $filename ); + $mod_info->version( $args->{module} ); + }; - last DIR; + if( defined $ver ) { + $href->{version} = $ver; + + last DIR; + } } } } diff --git a/gnu/usr.bin/perl/cpan/Module-Metadata/lib/Module/Metadata.pm b/gnu/usr.bin/perl/cpan/Module-Metadata/lib/Module/Metadata.pm index ecc535f03b0..0309d768ae8 100644 --- a/gnu/usr.bin/perl/cpan/Module-Metadata/lib/Module/Metadata.pm +++ b/gnu/usr.bin/perl/cpan/Module-Metadata/lib/Module/Metadata.pm @@ -1,6 +1,6 @@ # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- # vim:ts=8:sw=2:et:sta:sts=2:tw=78 -package Module::Metadata; # git description: v1.000035-3-gaa51be1 +package Module::Metadata; # git description: v1.000036-4-g435a294 # ABSTRACT: Gather package and POD information from perl module files # Adapted from Perl-licensed code originally distributed with @@ -14,7 +14,7 @@ sub __clean_eval { eval $_[0] } use strict; use warnings; -our $VERSION = '1.000036'; +our $VERSION = '1.000037'; use Carp qw/croak/; use File::Spec; @@ -383,7 +383,7 @@ sub _init { my $handle = delete $props{handle}; my( %valid_props, @valid_props ); - @valid_props = qw( collect_pod inc ); + @valid_props = qw( collect_pod inc decode_pod ); @valid_props{@valid_props} = delete( @props{@valid_props} ); warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); @@ -542,6 +542,7 @@ sub _parse_fh { my $pod_sect = ''; my $pod_data = ''; my $in_end = 0; + my $encoding = ''; while (defined( my $line = <$fh> )) { my $line_num = $.; @@ -570,6 +571,9 @@ sub _parse_fh { $pod_sect = $1; } elsif ( $self->{collect_pod} ) { + if ( $self->{decode_pod} && $line =~ /^=encoding ([\w-]+)/ ) { + $encoding = $1; + } $pod_data .= "$line\n"; } next; @@ -658,6 +662,11 @@ sub _parse_fh { $pod{$pod_sect} = $pod_data; } + if ( $self->{decode_pod} && $encoding ) { + require Encode; + $_ = Encode::decode( $encoding, $_ ) for values %pod; + } + $self->{versions} = \%vers; $self->{packages} = \@packages; $self->{pod} = \%pod; @@ -841,7 +850,7 @@ Module::Metadata - Gather package and POD information from perl module files =head1 VERSION -version 1.000036 +version 1.000037 =head1 SYNOPSIS @@ -865,7 +874,7 @@ in the CPAN toolchain. =head1 CLASS METHODS -=head2 C<< new_from_file($filename, collect_pod => 1) >> +=head2 C<< new_from_file($filename, collect_pod => 1, decode_pod => 1) >> Constructs a C<Module::Metadata> object given the path to a file. Returns undef if the filename does not exist. @@ -878,7 +887,10 @@ If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then it is skipped before processing, and the content of the file is also decoded appropriately starting from perl 5.8. -=head2 C<< new_from_handle($handle, $filename, collect_pod => 1) >> +Alternatively, if C<decode_pod> is set, it will decode the collected pod +sections according to the C<=encoding> declaration. + +=head2 C<< new_from_handle($handle, $filename, collect_pod => 1, decode_pod => 1) >> This works just like C<new_from_file>, except that a handle can be provided as the first argument. @@ -891,15 +903,15 @@ mandatory or undef will be returned. You are responsible for setting the decoding layers on C<$handle> if required. -=head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >> +=head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs, decode_pod => 1) >> Constructs a C<Module::Metadata> object given a module or package name. Returns undef if the module cannot be found. -In addition to accepting the C<collect_pod> argument as described above, -this method accepts a C<inc> argument which is a reference to an array of -directories to search for the module. If none are given, the default is -@INC. +In addition to accepting the C<collect_pod> and C<decode_pod> arguments as +described above, this method accepts a C<inc> argument which is a reference to +an array of directories to search for the module. If none are given, the +default is @INC. If the file that contains the module begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then it is skipped before processing, and the @@ -1070,7 +1082,7 @@ assistance from David Golden (xdg) <dagolden@cpan.org>. =head1 CONTRIBUTORS -=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran tokuhirom Christian Walde Tatsuhiko Miyagawa Peter Rabbitson Steve Hay Jerry D. Hedden Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass 'BinGOs' Williams Josh Jore Kent Fredric +=for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Tomas Doran Olivier Mengué Graham Knop tokuhirom Tatsuhiko Miyagawa Christian Walde Leon Timmermans Peter Rabbitson Steve Hay Jerry D. Hedden Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass 'BinGOs' Williams Josh Jore Kent Fredric =over 4 @@ -1096,7 +1108,7 @@ Chris Nehren <apeiron@cpan.org> =item * -Graham Knop <haarg@haarg.org> +Tomas Doran <bobtfish@bobtfish.net> =item * @@ -1104,7 +1116,7 @@ Olivier Mengué <dolmen@cpan.org> =item * -Tomas Doran <bobtfish@bobtfish.net> +Graham Knop <haarg@haarg.org> =item * @@ -1112,11 +1124,15 @@ tokuhirom <tokuhirom@gmail.com> =item * +Tatsuhiko Miyagawa <miyagawa@bulknews.net> + +=item * + Christian Walde <walde.christian@googlemail.com> =item * -Tatsuhiko Miyagawa <miyagawa@bulknews.net> +Leon Timmermans <fawaka@gmail.com> =item * diff --git a/gnu/usr.bin/perl/cpan/Module-Metadata/t/metadata.t b/gnu/usr.bin/perl/cpan/Module-Metadata/t/metadata.t index 0f2e414c7fc..3eea8d96663 100644 --- a/gnu/usr.bin/perl/cpan/Module-Metadata/t/metadata.t +++ b/gnu/usr.bin/perl/cpan/Module-Metadata/t/metadata.t @@ -3,6 +3,7 @@ use strict; use warnings; +use Encode 'decode'; use Test::More 0.82; use IO::File; use File::Spec; @@ -16,7 +17,7 @@ use GeneratePackage; my $tmpdir = GeneratePackage::tmpdir(); -plan tests => 71; +plan tests => 72; require_ok('Module::Metadata'); @@ -209,13 +210,15 @@ $VERSION = '0.01'; package Simple::Ex; $VERSION = '0.02'; +=encoding UTF-8 + =head1 NAME Simple - It's easy. =head1 AUTHOR -Simple Simon +Símple Simon You can find me on the IRC channel #simon on irc.perl.org. @@ -270,7 +273,7 @@ You can find me on the IRC channel my %expected = ( NAME => q|Simple - It's easy.|, AUTHOR => <<'EXPECTED' -Simple Simon +Símple Simon You can find me on the IRC channel #simon on irc.perl.org. @@ -282,6 +285,13 @@ EXPECTED } is( $pod{NAME}, $expected{NAME}, 'collected NAME pod section' ); is( $pod{AUTHOR}, $expected{AUTHOR}, 'collected AUTHOR pod section' ); + + my $pm_info2 = Module::Metadata->new_from_module( + 'Simple', inc => [ 'lib', @INC ], collect_pod => 1, decode_pod => 1 ); + my $author = $pm_info2->pod( 'AUTHOR' ); + $author =~ s/^\s+//; + $author =~ s/\s+$//; + is( $author, decode('UTF-8', $expected{AUTHOR} ), 'collected AUTHOR pod section in UTF-8' ); } { diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Find.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Find.pm deleted file mode 100644 index f258f26df68..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Find.pm +++ /dev/null @@ -1,553 +0,0 @@ -############################################################################# -# Pod/Find.pm -- finds files containing POD documentation -# -# Author: Marek Rouchal <marekr@cpan.org> -# -# Copyright (C) 1999-2000 by Marek Rouchal (and borrowing code -# from Nick Ing-Simmon's PodToHtml). All rights reserved. -# This file is part of "PodParser". Pod::Find is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Find; -use strict; - -use vars qw($VERSION); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later -use Carp; - -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} - -############################################################################# - -=head1 NAME - -Pod::Find - find POD documents in directory trees - -=head1 SYNOPSIS - - use Pod::Find qw(pod_find simplify_name); - my %pods = pod_find({ -verbose => 1, -inc => 1 }); - foreach(keys %pods) { - print "found library POD `$pods{$_}' in $_\n"; - } - - print "podname=",simplify_name('a/b/c/mymodule.pod'),"\n"; - - $location = pod_where( { -inc => 1 }, "Pod::Find" ); - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<Pod::Find> provides a set of functions to locate POD files. Note that -no function is exported by default to avoid pollution of your namespace, -so be sure to specify them in the B<use> statement if you need them: - - use Pod::Find qw(pod_find); - -From this version on the typical SCM (software configuration management) -directories are ignored. These are: RCS, CVS, SCCS, .svn, .hg, .git, .sync - -=cut - -#use diagnostics; -use Exporter; -use File::Spec; -use File::Find; -use Cwd qw(abs_path cwd); - -use vars qw(@ISA @EXPORT_OK $VERSION); -@ISA = qw(Exporter); -@EXPORT_OK = qw(&pod_find &simplify_name &pod_where &contains_pod); - -# package global variables -my $SIMPLIFY_RX; - -=head2 C<pod_find( { %opts } , @directories )> - -The function B<pod_find> searches for POD documents in a given set of -files and/or directories. It returns a hash with the file names as keys -and the POD name as value. The POD name is derived from the file name -and its position in the directory tree. - -E.g. when searching in F<$HOME/perl5lib>, the file -F<$HOME/perl5lib/MyModule.pm> would get the POD name I<MyModule>, -whereas F<$HOME/perl5lib/Myclass/Subclass.pm> would be -I<Myclass::Subclass>. The name information can be used for POD -translators. - -Only text files containing at least one valid POD command are found. - -A warning is printed if more than one POD file with the same POD name -is found, e.g. F<CPAN.pm> in different directories. This usually -indicates duplicate occurrences of modules in the I<@INC> search path. - -B<OPTIONS> The first argument for B<pod_find> may be a hash reference -with options. The rest are either directories that are searched -recursively or files. The POD names of files are the plain basenames -with any Perl-like extension (.pm, .pl, .pod) stripped. - -=over 4 - -=item C<-verbose =E<gt> 1> - -Print progress information while scanning. - -=item C<-perl =E<gt> 1> - -Apply Perl-specific heuristics to find the correct PODs. This includes -stripping Perl-like extensions, omitting subdirectories that are numeric -but do I<not> match the current Perl interpreter's version id, suppressing -F<site_perl> as a module hierarchy name etc. - -=item C<-script =E<gt> 1> - -Search for PODs in the current Perl interpreter's installation -B<scriptdir>. This is taken from the local L<Config|Config> module. - -=item C<-inc =E<gt> 1> - -Search for PODs in the current Perl interpreter's I<@INC> paths. This -automatically considers paths specified in the C<PERL5LIB> environment -as this is included in I<@INC> by the Perl interpreter itself. - -=back - -=cut - -# return a hash of the POD files found -# first argument may be a hashref (options), -# rest is a list of directories to search recursively -sub pod_find -{ - my %opts; - if(ref $_[0]) { - %opts = %{shift()}; - } - - $opts{-verbose} ||= 0; - $opts{-perl} ||= 0; - - my (@search) = @_; - - if($opts{-script}) { - require Config; - push(@search, $Config::Config{scriptdir}) - if -d $Config::Config{scriptdir}; - $opts{-perl} = 1; - } - - if($opts{-inc}) { - if ($^O eq 'MacOS') { - # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS - my @new_INC = @INC; - for (@new_INC) { - if ( $_ eq '.' ) { - $_ = ':'; - } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { - $_ = ':'. $_; - } else { - $_ =~ s{^\./}{:}; - } - } - push(@search, grep($_ ne File::Spec->curdir, @new_INC)); - } else { - my %seen; - my $curdir = File::Spec->curdir; - foreach(@INC) { - next if $_ eq $curdir; - my $path = abs_path($_); - push(@search, $path) unless $seen{$path}++; - } - } - - $opts{-perl} = 1; - } - - if($opts{-perl}) { - require Config; - # this code simplifies the POD name for Perl modules: - # * remove "site_perl" - # * remove e.g. "i586-linux" (from 'archname') - # * remove e.g. 5.00503 - # * remove pod/ if followed by *.pod (e.g. in pod/perlfunc.pod) - - # Mac OS: - # * remove ":?site_perl:" - # * remove :?pod: if followed by *.pod (e.g. in :pod:perlfunc.pod) - - if ($^O eq 'MacOS') { - $SIMPLIFY_RX = - qq!^(?i:\:?site_perl\:|\:?pod\:(?=.*?\\.pod\\z))*!; - } else { - $SIMPLIFY_RX = - qq!^(?i:site(_perl)?/|\Q$Config::Config{archname}\E/|\\d+\\.\\d+([_.]?\\d+)?/|pod/(?=.*?\\.pod\\z))*!; - } - } - - my %dirs_visited; - my %pods; - my %names; - my $pwd = cwd(); - - foreach my $try (@search) { - unless(File::Spec->file_name_is_absolute($try)) { - # make path absolute - $try = File::Spec->catfile($pwd,$try); - } - # simplify path - # on VMS canonpath will vmsify:[the.path], but File::Find::find - # wants /unixy/paths - if ($^O eq 'VMS') { - $try = VMS::Filespec::unixify($try); - } - else { - $try = File::Spec->canonpath($try); - } - my $name; - if(-f $try) { - if($name = _check_and_extract_name($try, $opts{-verbose})) { - _check_for_duplicates($try, $name, \%names, \%pods); - } - next; - } - my $root_rx = $^O eq 'MacOS' ? qq!^\Q$try\E! : qq!^\Q$try\E/!; - $root_rx=~ s|//$|/|; # remove trailing double slash - File::Find::find( sub { - my $item = $File::Find::name; - if(-d) { - if($item =~ m{/(?:RCS|CVS|SCCS|\.svn|\.hg|\.git|\.sync)$}) { - $File::Find::prune = 1; - return; - } - elsif($dirs_visited{$item}) { - warn "Directory '$item' already seen, skipping.\n" - if($opts{-verbose}); - $File::Find::prune = 1; - return; - } - else { - $dirs_visited{$item} = 1; - } - if($opts{-perl} && /^(\d+\.[\d_]+)\z/s && eval "$1" != $]) { - $File::Find::prune = 1; - warn "Perl $] version mismatch on $_, skipping.\n" - if($opts{-verbose}); - } - return; - } - if($name = _check_and_extract_name($item, $opts{-verbose}, $root_rx)) { - _check_for_duplicates($item, $name, \%names, \%pods); - } - }, $try); # end of File::Find::find - } - chdir $pwd; - return %pods; -} - -sub _check_for_duplicates { - my ($file, $name, $names_ref, $pods_ref) = @_; - if($$names_ref{$name}) { - warn "Duplicate POD found (shadowing?): $name ($file)\n"; - warn ' Already seen in ', - join(' ', grep($$pods_ref{$_} eq $name, keys %$pods_ref)),"\n"; - } - else { - $$names_ref{$name} = 1; - } - return $$pods_ref{$file} = $name; -} - -sub _check_and_extract_name { - my ($file, $verbose, $root_rx) = @_; - - # check extension or executable flag - # this involves testing the .bat extension on Win32! - unless(-f $file && -T $file && ($file =~ /\.(pod|pm|plx?)\z/i || -x $file )) { - return; - } - - return unless contains_pod($file,$verbose); - - # strip non-significant path components - # TODO what happens on e.g. Win32? - my $name = $file; - if(defined $root_rx) { - $name =~ s/$root_rx//is; - $name =~ s/$SIMPLIFY_RX//is if(defined $SIMPLIFY_RX); - } - else { - if ($^O eq 'MacOS') { - $name =~ s/^.*://s; - } else { - $name =~ s{^.*/}{}s; - } - } - _simplify($name); - $name =~ s{/+}{::}g; - if ($^O eq 'MacOS') { - $name =~ s{:+}{::}g; # : -> :: - } else { - $name =~ s{/+}{::}g; # / -> :: - } - return $name; -} - -=head2 C<simplify_name( $str )> - -The function B<simplify_name> is equivalent to B<basename>, but also -strips Perl-like extensions (.pm, .pl, .pod) and extensions like -F<.bat>, F<.cmd> on Win32 and OS/2, or F<.com> on VMS, respectively. - -=cut - -# basic simplification of the POD name: -# basename & strip extension -sub simplify_name { - my ($str) = @_; - # remove all path components - if ($^O eq 'MacOS') { - $str =~ s/^.*://s; - } else { - $str =~ s{^.*/}{}s; - } - _simplify($str); - return $str; -} - -# internal sub only -sub _simplify { - # strip Perl's own extensions - $_[0] =~ s/\.(pod|pm|plx?)\z//i; - # strip meaningless extensions on Win32 and OS/2 - $_[0] =~ s/\.(bat|exe|cmd)\z//i if($^O =~ /mswin|os2/i); - # strip meaningless extensions on VMS - $_[0] =~ s/\.(com)\z//i if($^O eq 'VMS'); -} - -# contribution from Tim Jenness <t.jenness@jach.hawaii.edu> - -=head2 C<pod_where( { %opts }, $pod )> - -Returns the location of a pod document given a search directory -and a module (e.g. C<File::Find>) or script (e.g. C<perldoc>) name. - -Options: - -=over 4 - -=item C<-inc =E<gt> 1> - -Search @INC for the pod and also the C<scriptdir> defined in the -L<Config|Config> module. - -=item C<-dirs =E<gt> [ $dir1, $dir2, ... ]> - -Reference to an array of search directories. These are searched in order -before looking in C<@INC> (if B<-inc>). Current directory is used if -none are specified. - -=item C<-verbose =E<gt> 1> - -List directories as they are searched - -=back - -Returns the full path of the first occurrence to the file. -Package names (eg 'A::B') are automatically converted to directory -names in the selected directory. (eg on unix 'A::B' is converted to -'A/B'). Additionally, '.pm', '.pl' and '.pod' are appended to the -search automatically if required. - -A subdirectory F<pod/> is also checked if it exists in any of the given -search directories. This ensures that e.g. L<perlfunc|perlfunc> is -found. - -It is assumed that if a module name is supplied, that that name -matches the file name. Pods are not opened to check for the 'NAME' -entry. - -A check is made to make sure that the file that is found does -contain some pod documentation. - -=cut - -sub pod_where { - - # default options - my %options = ( - '-inc' => 0, - '-verbose' => 0, - '-dirs' => [ File::Spec->curdir ], - ); - - # Check for an options hash as first argument - if (defined $_[0] && ref($_[0]) eq 'HASH') { - my $opt = shift; - - # Merge default options with supplied options - %options = (%options, %$opt); - } - - # Check usage - carp 'Usage: pod_where({options}, $pod)' unless (scalar(@_)); - - # Read argument - my $pod = shift; - - # Split on :: and then join the name together using File::Spec - my @parts = split (/::/, $pod); - - # Get full directory list - my @search_dirs = @{ $options{'-dirs'} }; - - if ($options{'-inc'}) { - - require Config; - - # Add @INC - if ($^O eq 'MacOS' && $options{'-inc'}) { - # tolerate '.', './some_dir' and '(../)+some_dir' on Mac OS - my @new_INC = @INC; - for (@new_INC) { - if ( $_ eq '.' ) { - $_ = ':'; - } elsif ( $_ =~ s{^((?:\.\./)+)}{':' x (length($1)/3)}e ) { - $_ = ':'. $_; - } else { - $_ =~ s{^\./}{:}; - } - } - push (@search_dirs, @new_INC); - } elsif ($options{'-inc'}) { - push (@search_dirs, @INC); - } - - # Add location of pod documentation for perl man pages (eg perlfunc) - # This is a pod directory in the private install tree - #my $perlpoddir = File::Spec->catdir($Config::Config{'installprivlib'}, - # 'pod'); - #push (@search_dirs, $perlpoddir) - # if -d $perlpoddir; - - # Add location of binaries such as pod2text - push (@search_dirs, $Config::Config{'scriptdir'}) - if -d $Config::Config{'scriptdir'}; - } - - warn 'Search path is: '.join(' ', @search_dirs)."\n" - if $options{'-verbose'}; - - # Loop over directories - Dir: foreach my $dir ( @search_dirs ) { - - # Don't bother if can't find the directory - if (-d $dir) { - warn "Looking in directory $dir\n" - if $options{'-verbose'}; - - # Now concatenate this directory with the pod we are searching for - my $fullname = File::Spec->catfile($dir, @parts); - $fullname = VMS::Filespec::unixify($fullname) if $^O eq 'VMS'; - warn "Filename is now $fullname\n" - if $options{'-verbose'}; - - # Loop over possible extensions - foreach my $ext ('', '.pod', '.pm', '.pl') { - my $fullext = $fullname . $ext; - if (-f $fullext && - contains_pod($fullext, $options{'-verbose'}) ) { - warn "FOUND: $fullext\n" if $options{'-verbose'}; - return $fullext; - } - } - } else { - warn "Directory $dir does not exist\n" - if $options{'-verbose'}; - next Dir; - } - # for some strange reason the path on MacOS/darwin/cygwin is - # 'pods' not 'pod' - # this could be the case also for other systems that - # have a case-tolerant file system, but File::Spec - # does not recognize 'darwin' yet. And cygwin also has "pods", - # but is not case tolerant. Oh well... - if((File::Spec->case_tolerant || $^O =~ /macos|darwin|cygwin/i) - && -d File::Spec->catdir($dir,'pods')) { - $dir = File::Spec->catdir($dir,'pods'); - redo Dir; - } - if(-d File::Spec->catdir($dir,'pod')) { - $dir = File::Spec->catdir($dir,'pod'); - redo Dir; - } - } - # No match; - return; -} - -=head2 C<contains_pod( $file , $verbose )> - -Returns true if the supplied filename (not POD module) contains some pod -information. - -=cut - -sub contains_pod { - my $file = shift; - my $verbose = 0; - $verbose = shift if @_; - - # check for one line of POD - my $podfh; - if ($] < 5.006) { - $podfh = gensym(); - } - - unless(open($podfh,"<$file")) { - warn "Error: $file is unreadable: $!\n"; - return; - } - - local $/ = undef; - my $pod = <$podfh>; - close($podfh) || die "Error closing $file: $!\n"; - unless($pod =~ /^=(head\d|pod|over|item|cut)\b/m) { - warn "No POD in $file, skipping.\n" - if($verbose); - return 0; - } - - return 1; -} - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Marek Rouchal E<lt>marekr@cpan.orgE<gt>, -heavily borrowing code from Nick Ing-Simmons' PodToHtml. - -Tim Jenness E<lt>t.jenness@jach.hawaii.eduE<gt> provided -C<pod_where> and C<contains_pod>. - -B<Pod::Find> is part of the L<Pod::Parser> distribution. - -=head1 SEE ALSO - -L<Pod::Parser>, L<Pod::Checker>, L<perldoc> - -=cut - -1; - diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/InputObjects.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/InputObjects.pm deleted file mode 100644 index c4d6fc24691..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/InputObjects.pm +++ /dev/null @@ -1,946 +0,0 @@ -############################################################################# -# Pod/InputObjects.pm -- package which defines objects for input streams -# and paragraphs and commands when parsing POD docs. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::InputObjects; -use strict; - -use vars qw($VERSION); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::InputObjects - objects representing POD input paragraphs, commands, etc. - -=head1 SYNOPSIS - - use Pod::InputObjects; - -=head1 REQUIRES - -perl5.004, Carp - -=head1 EXPORTS - -Nothing. - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -This module defines some basic input objects used by B<Pod::Parser> when -reading and parsing POD text from an input source. The following objects -are defined: - -=begin __PRIVATE__ - -=over 4 - -=item package B<Pod::InputSource> - -An object corresponding to a source of POD input text. It is mostly a -wrapper around a filehandle or C<IO::Handle>-type object (or anything -that implements the C<getline()> method) which keeps track of some -additional information relevant to the parsing of PODs. - -=back - -=end __PRIVATE__ - -=over 4 - -=item package B<Pod::Paragraph> - -An object corresponding to a paragraph of POD input text. It may be a -plain paragraph, a verbatim paragraph, or a command paragraph (see -L<perlpod>). - -=item package B<Pod::InteriorSequence> - -An object corresponding to an interior sequence command from the POD -input text (see L<perlpod>). - -=item package B<Pod::ParseTree> - -An object corresponding to a tree of parsed POD text. Each "node" in -a parse-tree (or I<ptree>) is either a text-string or a reference to -a B<Pod::InteriorSequence> object. The nodes appear in the parse-tree -in the order in which they were parsed from left-to-right. - -=back - -Each of these input objects are described in further detail in the -sections which follow. - -=cut - -############################################################################# - -package Pod::InputSource; - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<Pod::InputSource> - -This object corresponds to an input source or stream of POD -documentation. When parsing PODs, it is necessary to associate and store -certain context information with each input source. All of this -information is kept together with the stream itself in one of these -C<Pod::InputSource> objects. Each such object is merely a wrapper around -an C<IO::Handle> object of some kind (or at least something that -implements the C<getline()> method). They have the following -methods/attributes: - -=end __PRIVATE__ - -=cut - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<new()> - - my $pod_input1 = Pod::InputSource->new(-handle => $filehandle); - my $pod_input2 = new Pod::InputSource(-handle => $filehandle, - -name => $name); - my $pod_input3 = new Pod::InputSource(-handle => \*STDIN); - my $pod_input4 = Pod::InputSource->new(-handle => \*STDIN, - -name => "(STDIN)"); - -This is a class method that constructs a C<Pod::InputSource> object and -returns a reference to the new input source object. It takes one or more -keyword arguments in the form of a hash. The keyword C<-handle> is -required and designates the corresponding input handle. The keyword -C<-name> is optional and specifies the name associated with the input -handle (typically a file name). - -=end __PRIVATE__ - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { -name => '(unknown)', - -handle => undef, - -was_cutting => 0, - @_ }; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<name()> - - my $filename = $pod_input->name(); - $pod_input->name($new_filename_to_use); - -This method gets/sets the name of the input source (usually a filename). -If no argument is given, it returns a string containing the name of -the input source; otherwise it sets the name of the input source to the -contents of the given argument. - -=end __PRIVATE__ - -=cut - -sub name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## allow 'filename' as an alias for 'name' -*filename = \&name; - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<handle()> - - my $handle = $pod_input->handle(); - -Returns a reference to the handle object from which input is read (the -one used to contructed this input source object). - -=end __PRIVATE__ - -=cut - -sub handle { - return $_[0]->{'-handle'}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head2 B<was_cutting()> - - print "Yes.\n" if ($pod_input->was_cutting()); - -The value of the C<cutting> state (that the B<cutting()> method would -have returned) immediately before any input was read from this input -stream. After all input from this stream has been read, the C<cutting> -state is restored to this value. - -=end __PRIVATE__ - -=cut - -sub was_cutting { - (@_ > 1) and $_[0]->{-was_cutting} = $_[1]; - return $_[0]->{-was_cutting}; -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::Paragraph; - -##--------------------------------------------------------------------------- - -=head1 B<Pod::Paragraph> - -An object representing a paragraph of POD input text. -It has the following methods/attributes: - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::Paragraph-E<gt>B<new()> - - my $pod_para1 = Pod::Paragraph->new(-text => $text); - my $pod_para2 = Pod::Paragraph->new(-name => $cmd, - -text => $text); - my $pod_para3 = new Pod::Paragraph(-text => $text); - my $pod_para4 = new Pod::Paragraph(-name => $cmd, - -text => $text); - my $pod_para5 = Pod::Paragraph->new(-name => $cmd, - -text => $text, - -file => $filename, - -line => $line_number); - -This is a class method that constructs a C<Pod::Paragraph> object and -returns a reference to the new paragraph object. It may be given one or -two keyword arguments. The C<-text> keyword indicates the corresponding -text of the POD paragraph. The C<-name> keyword indicates the name of -the corresponding POD command, such as C<head1> or C<item> (it should -I<not> contain the C<=> prefix); this is needed only if the POD -paragraph corresponds to a command paragraph. The C<-file> and C<-line> -keywords indicate the filename and line number corresponding to the -beginning of the paragraph - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { - -name => undef, - -text => (@_ == 1) ? shift : undef, - -file => '<unknown-file>', - -line => 0, - -prefix => '=', - -separator => ' ', - -ptree => [], - @_ - }; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<cmd_name()> - - my $para_cmd = $pod_para->cmd_name(); - -If this paragraph is a command paragraph, then this method will return -the name of the command (I<without> any leading C<=> prefix). - -=cut - -sub cmd_name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## let name() be an alias for cmd_name() -*name = \&cmd_name; - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<text()> - - my $para_text = $pod_para->text(); - -This method will return the corresponding text of the paragraph. - -=cut - -sub text { - (@_ > 1) and $_[0]->{'-text'} = $_[1]; - return $_[0]->{'-text'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<raw_text()> - - my $raw_pod_para = $pod_para->raw_text(); - -This method will return the I<raw> text of the POD paragraph, exactly -as it appeared in the input. - -=cut - -sub raw_text { - return $_[0]->{'-text'} unless (defined $_[0]->{'-name'}); - return $_[0]->{'-prefix'} . $_[0]->{'-name'} . - $_[0]->{'-separator'} . $_[0]->{'-text'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<cmd_prefix()> - - my $prefix = $pod_para->cmd_prefix(); - -If this paragraph is a command paragraph, then this method will return -the prefix used to denote the command (which should be the string "=" -or "=="). - -=cut - -sub cmd_prefix { - return $_[0]->{'-prefix'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<cmd_separator()> - - my $separator = $pod_para->cmd_separator(); - -If this paragraph is a command paragraph, then this method will return -the text used to separate the command name from the rest of the -paragraph (if any). - -=cut - -sub cmd_separator { - return $_[0]->{'-separator'}; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<parse_tree()> - - my $ptree = $pod_parser->parse_text( $pod_para->text() ); - $pod_para->parse_tree( $ptree ); - $ptree = $pod_para->parse_tree(); - -This method will get/set the corresponding parse-tree of the paragraph's text. - -=cut - -sub parse_tree { - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; -} - -## let ptree() be an alias for parse_tree() -*ptree = \&parse_tree; - -##--------------------------------------------------------------------------- - -=head2 $pod_para-E<gt>B<file_line()> - - my ($filename, $line_number) = $pod_para->file_line(); - my $position = $pod_para->file_line(); - -Returns the current filename and line number for the paragraph -object. If called in a list context, it returns a list of two -elements: first the filename, then the line number. If called in -a scalar context, it returns a string containing the filename, followed -by a colon (':'), followed by the line number. - -=cut - -sub file_line { - my @loc = ($_[0]->{'-file'} || '<unknown-file>', - $_[0]->{'-line'} || 0); - return (wantarray) ? @loc : join(':', @loc); -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::InteriorSequence; - -##--------------------------------------------------------------------------- - -=head1 B<Pod::InteriorSequence> - -An object representing a POD interior sequence command. -It has the following methods/attributes: - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::InteriorSequence-E<gt>B<new()> - - my $pod_seq1 = Pod::InteriorSequence->new(-name => $cmd - -ldelim => $delimiter); - my $pod_seq2 = new Pod::InteriorSequence(-name => $cmd, - -ldelim => $delimiter); - my $pod_seq3 = new Pod::InteriorSequence(-name => $cmd, - -ldelim => $delimiter, - -file => $filename, - -line => $line_number); - - my $pod_seq4 = new Pod::InteriorSequence(-name => $cmd, $ptree); - my $pod_seq5 = new Pod::InteriorSequence($cmd, $ptree); - -This is a class method that constructs a C<Pod::InteriorSequence> object -and returns a reference to the new interior sequence object. It should -be given two keyword arguments. The C<-ldelim> keyword indicates the -corresponding left-delimiter of the interior sequence (e.g. 'E<lt>'). -The C<-name> keyword indicates the name of the corresponding interior -sequence command, such as C<I> or C<B> or C<C>. The C<-file> and -C<-line> keywords indicate the filename and line number corresponding -to the beginning of the interior sequence. If the C<$ptree> argument is -given, it must be the last argument, and it must be either string, or -else an array-ref suitable for passing to B<Pod::ParseTree::new> (or -it may be a reference to a Pod::ParseTree object). - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - ## See if first argument has no keyword - if (((@_ <= 2) or (@_ % 2)) and $_[0] !~ /^-\w/) { - ## Yup - need an implicit '-name' before first parameter - unshift @_, '-name'; - } - - ## See if odd number of args - if ((@_ % 2) != 0) { - ## Yup - need an implicit '-ptree' before the last parameter - splice @_, $#_, 0, '-ptree'; - } - - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. Note that we default - ## certain values by specifying them *before* the arguments passed. - ## If they are in the argument list, they will override the defaults. - my $self = { - -name => (@_ == 1) ? $_[0] : undef, - -file => '<unknown-file>', - -line => 0, - -ldelim => '<', - -rdelim => '>', - @_ - }; - - ## Initialize contents if they haven't been already - my $ptree = $self->{'-ptree'} || new Pod::ParseTree(); - if ( ref $ptree =~ /^(ARRAY)?$/ ) { - ## We have an array-ref, or a normal scalar. Pass it as an - ## an argument to the ptree-constructor - $ptree = new Pod::ParseTree($1 ? [$ptree] : $ptree); - } - $self->{'-ptree'} = $ptree; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<cmd_name()> - - my $seq_cmd = $pod_seq->cmd_name(); - -The name of the interior sequence command. - -=cut - -sub cmd_name { - (@_ > 1) and $_[0]->{'-name'} = $_[1]; - return $_[0]->{'-name'}; -} - -## let name() be an alias for cmd_name() -*name = \&cmd_name; - -##--------------------------------------------------------------------------- - -## Private subroutine to set the parent pointer of all the given -## children that are interior-sequences to be $self - -sub _set_child2parent_links { - my ($self, @children) = @_; - ## Make sure any sequences know who their parent is - for (@children) { - next unless (length and ref and ref ne 'SCALAR'); - if (UNIVERSAL::isa($_, 'Pod::InteriorSequence') or - UNIVERSAL::can($_, 'nested')) - { - $_->nested($self); - } - } -} - -## Private subroutine to unset child->parent links - -sub _unset_child2parent_links { - my $self = shift; - $self->{'-parent_sequence'} = undef; - my $ptree = $self->{'-ptree'}; - for (@$ptree) { - next unless (length and ref and ref ne 'SCALAR'); - $_->_unset_child2parent_links() - if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); - } -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<prepend()> - - $pod_seq->prepend($text); - $pod_seq1->prepend($pod_seq2); - -Prepends the given string or parse-tree or sequence object to the parse-tree -of this interior sequence. - -=cut - -sub prepend { - my $self = shift; - $self->{'-ptree'}->prepend(@_); - _set_child2parent_links($self, @_); - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<append()> - - $pod_seq->append($text); - $pod_seq1->append($pod_seq2); - -Appends the given string or parse-tree or sequence object to the parse-tree -of this interior sequence. - -=cut - -sub append { - my $self = shift; - $self->{'-ptree'}->append(@_); - _set_child2parent_links($self, @_); - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<nested()> - - $outer_seq = $pod_seq->nested || print "not nested"; - -If this interior sequence is nested inside of another interior -sequence, then the outer/parent sequence that contains it is -returned. Otherwise C<undef> is returned. - -=cut - -sub nested { - my $self = shift; - (@_ == 1) and $self->{'-parent_sequence'} = shift; - return $self->{'-parent_sequence'} || undef; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<raw_text()> - - my $seq_raw_text = $pod_seq->raw_text(); - -This method will return the I<raw> text of the POD interior sequence, -exactly as it appeared in the input. - -=cut - -sub raw_text { - my $self = shift; - my $text = $self->{'-name'} . $self->{'-ldelim'}; - for ( $self->{'-ptree'}->children ) { - $text .= (ref $_) ? $_->raw_text : $_; - } - $text .= $self->{'-rdelim'}; - return $text; -} - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<left_delimiter()> - - my $ldelim = $pod_seq->left_delimiter(); - -The leftmost delimiter beginning the argument text to the interior -sequence (should be "<"). - -=cut - -sub left_delimiter { - (@_ > 1) and $_[0]->{'-ldelim'} = $_[1]; - return $_[0]->{'-ldelim'}; -} - -## let ldelim() be an alias for left_delimiter() -*ldelim = \&left_delimiter; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<right_delimiter()> - -The rightmost delimiter beginning the argument text to the interior -sequence (should be ">"). - -=cut - -sub right_delimiter { - (@_ > 1) and $_[0]->{'-rdelim'} = $_[1]; - return $_[0]->{'-rdelim'}; -} - -## let rdelim() be an alias for right_delimiter() -*rdelim = \&right_delimiter; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<parse_tree()> - - my $ptree = $pod_parser->parse_text($paragraph_text); - $pod_seq->parse_tree( $ptree ); - $ptree = $pod_seq->parse_tree(); - -This method will get/set the corresponding parse-tree of the interior -sequence's text. - -=cut - -sub parse_tree { - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; -} - -## let ptree() be an alias for parse_tree() -*ptree = \&parse_tree; - -##--------------------------------------------------------------------------- - -=head2 $pod_seq-E<gt>B<file_line()> - - my ($filename, $line_number) = $pod_seq->file_line(); - my $position = $pod_seq->file_line(); - -Returns the current filename and line number for the interior sequence -object. If called in a list context, it returns a list of two -elements: first the filename, then the line number. If called in -a scalar context, it returns a string containing the filename, followed -by a colon (':'), followed by the line number. - -=cut - -sub file_line { - my @loc = ($_[0]->{'-file'} || '<unknown-file>', - $_[0]->{'-line'} || 0); - return (wantarray) ? @loc : join(':', @loc); -} - -##--------------------------------------------------------------------------- - -=head2 Pod::InteriorSequence::B<DESTROY()> - -This method performs any necessary cleanup for the interior-sequence. -If you override this method then it is B<imperative> that you invoke -the parent method from within your own method, otherwise -I<interior-sequence storage will not be reclaimed upon destruction!> - -=cut - -sub DESTROY { - ## We need to get rid of all child->parent pointers throughout the - ## tree so their reference counts will go to zero and they can be - ## garbage-collected - _unset_child2parent_links(@_); -} - -##--------------------------------------------------------------------------- - -############################################################################# - -package Pod::ParseTree; - -##--------------------------------------------------------------------------- - -=head1 B<Pod::ParseTree> - -This object corresponds to a tree of parsed POD text. As POD text is -scanned from left to right, it is parsed into an ordered list of -text-strings and B<Pod::InteriorSequence> objects (in order of -appearance). A B<Pod::ParseTree> object corresponds to this list of -strings and sequences. Each interior sequence in the parse-tree may -itself contain a parse-tree (since interior sequences may be nested). - -=cut - -##--------------------------------------------------------------------------- - -=head2 Pod::ParseTree-E<gt>B<new()> - - my $ptree1 = Pod::ParseTree->new; - my $ptree2 = new Pod::ParseTree; - my $ptree4 = Pod::ParseTree->new($array_ref); - my $ptree3 = new Pod::ParseTree($array_ref); - -This is a class method that constructs a C<Pod::Parse_tree> object and -returns a reference to the new parse-tree. If a single-argument is given, -it must be a reference to an array, and is used to initialize the root -(top) of the parse tree. - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my $this = shift; - my $class = ref($this) || $this; - - my $self = (@_ == 1 and ref $_[0]) ? $_[0] : []; - - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - return $self; -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<top()> - - my $top_node = $ptree->top(); - $ptree->top( $top_node ); - $ptree->top( @children ); - -This method gets/sets the top node of the parse-tree. If no arguments are -given, it returns the topmost node in the tree (the root), which is also -a B<Pod::ParseTree>. If it is given a single argument that is a reference, -then the reference is assumed to a parse-tree and becomes the new top node. -Otherwise, if arguments are given, they are treated as the new list of -children for the top node. - -=cut - -sub top { - my $self = shift; - if (@_ > 0) { - @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; - } - return $self; -} - -## let parse_tree() & ptree() be aliases for the 'top' method -*parse_tree = *ptree = \⊤ - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<children()> - -This method gets/sets the children of the top node in the parse-tree. -If no arguments are given, it returns the list (array) of children -(each of which should be either a string or a B<Pod::InteriorSequence>. -Otherwise, if arguments are given, they are treated as the new list of -children for the top node. - -=cut - -sub children { - my $self = shift; - if (@_ > 0) { - @{ $self } = (@_ == 1 and ref $_[0]) ? ${ @_ } : @_; - } - return @{ $self }; -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<prepend()> - -This method prepends the given text or parse-tree to the current parse-tree. -If the first item on the parse-tree is text and the argument is also text, -then the text is prepended to the first item (not added as a separate string). -Otherwise the argument is added as a new string or parse-tree I<before> -the current one. - -=cut - -use vars qw(@ptree); ## an alias used for performance reasons - -sub prepend { - my $self = shift; - local *ptree = $self; - for (@_) { - next unless length; - if (@ptree && !(ref $ptree[0]) && !(ref $_)) { - $ptree[0] = $_ . $ptree[0]; - } - else { - unshift @ptree, $_; - } - } -} - -##--------------------------------------------------------------------------- - -=head2 $ptree-E<gt>B<append()> - -This method appends the given text or parse-tree to the current parse-tree. -If the last item on the parse-tree is text and the argument is also text, -then the text is appended to the last item (not added as a separate string). -Otherwise the argument is added as a new string or parse-tree I<after> -the current one. - -=cut - -sub append { - my $self = shift; - local *ptree = $self; - my $can_append = @ptree && !(ref $ptree[-1]); - for (@_) { - if (ref) { - push @ptree, $_; - } - elsif(!length) { - next; - } - elsif ($can_append) { - $ptree[-1] .= $_; - } - else { - push @ptree, $_; - } - } -} - -=head2 $ptree-E<gt>B<raw_text()> - - my $ptree_raw_text = $ptree->raw_text(); - -This method will return the I<raw> text of the POD parse-tree -exactly as it appeared in the input. - -=cut - -sub raw_text { - my $self = shift; - my $text = ''; - for ( @$self ) { - $text .= (ref $_) ? $_->raw_text : $_; - } - return $text; -} - -##--------------------------------------------------------------------------- - -## Private routines to set/unset child->parent links - -sub _unset_child2parent_links { - my $self = shift; - local *ptree = $self; - for (@ptree) { - next unless (defined and length and ref and ref ne 'SCALAR'); - $_->_unset_child2parent_links() - if UNIVERSAL::isa($_, 'Pod::InteriorSequence'); - } -} - -sub _set_child2parent_links { - ## nothing to do, Pod::ParseTrees cant have parent pointers -} - -=head2 Pod::ParseTree::B<DESTROY()> - -This method performs any necessary cleanup for the parse-tree. -If you override this method then it is B<imperative> -that you invoke the parent method from within your own method, -otherwise I<parse-tree storage will not be reclaimed upon destruction!> - -=cut - -sub DESTROY { - ## We need to get rid of all child->parent pointers throughout the - ## tree so their reference counts will go to zero and they can be - ## garbage-collected - _unset_child2parent_links(@_); -} - -############################################################################# - -=head1 SEE ALSO - -B<Pod::InputObjects> is part of the L<Pod::Parser> distribution. - -See L<Pod::Parser>, L<Pod::Select> - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Brad Appleton E<lt>bradapp@enteract.comE<gt> - -=cut - -1; diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/ParseUtils.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/ParseUtils.pm deleted file mode 100644 index 2afd0cd420e..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/ParseUtils.pm +++ /dev/null @@ -1,861 +0,0 @@ -############################################################################# -# Pod/ParseUtils.pm -- helpers for POD parsing and conversion -# -# Copyright (C) 1999-2000 by Marek Rouchal. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::ParseUtils; -use strict; - -use vars qw($VERSION); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -=head1 NAME - -Pod::ParseUtils - helpers for POD parsing and conversion - -=head1 SYNOPSIS - - use Pod::ParseUtils; - - my $list = new Pod::List; - my $link = Pod::Hyperlink->new('Pod::Parser'); - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<Pod::ParseUtils> contains a few object-oriented helper packages for -POD parsing and processing (i.e. in POD formatters and translators). - -=cut - -#----------------------------------------------------------------------------- -# Pod::List -# -# class to hold POD list info (=over, =item, =back) -#----------------------------------------------------------------------------- - -package Pod::List; - -use Carp; - -=head2 Pod::List - -B<Pod::List> can be used to hold information about POD lists -(written as =over ... =item ... =back) for further processing. -The following methods are available: - -=over 4 - -=item Pod::List-E<gt>new() - -Create a new list object. Properties may be specified through a hash -reference like this: - - my $list = Pod::List->new({ -start => $., -indent => 4 }); - -See the individual methods/properties for details. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-file} ||= 'unknown'; - $self->{-start} ||= 'unknown'; - $self->{-indent} ||= 4; # perlpod: "should be the default" - $self->{_items} = []; - $self->{-type} ||= ''; -} - -=item $list-E<gt>file() - -Without argument, retrieves the file name the list is in. This must -have been set before by either specifying B<-file> in the B<new()> -method or by calling the B<file()> method with a scalar argument. - -=cut - -# The POD file name the list appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $list-E<gt>start() - -Without argument, retrieves the line number where the list started. -This must have been set before by either specifying B<-start> in the -B<new()> method or by calling the B<start()> method with a scalar -argument. - -=cut - -# The line in the file the node appears -sub start { - return (@_ > 1) ? ($_[0]->{-start} = $_[1]) : $_[0]->{-start}; -} - -=item $list-E<gt>indent() - -Without argument, retrieves the indent level of the list as specified -in C<=over n>. This must have been set before by either specifying -B<-indent> in the B<new()> method or by calling the B<indent()> method -with a scalar argument. - -=cut - -# indent level -sub indent { - return (@_ > 1) ? ($_[0]->{-indent} = $_[1]) : $_[0]->{-indent}; -} - -=item $list-E<gt>type() - -Without argument, retrieves the list type, which can be an arbitrary value, -e.g. C<OL>, C<UL>, ... when thinking the HTML way. -This must have been set before by either specifying -B<-type> in the B<new()> method or by calling the B<type()> method -with a scalar argument. - -=cut - -# The type of the list (UL, OL, ...) -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -=item $list-E<gt>rx() - -Without argument, retrieves a regular expression for simplifying the -individual item strings once the list type has been determined. Usage: -E.g. when converting to HTML, one might strip the leading number in -an ordered list as C<E<lt>OLE<gt>> already prints numbers itself. -This must have been set before by either specifying -B<-rx> in the B<new()> method or by calling the B<rx()> method -with a scalar argument. - -=cut - -# The regular expression to simplify the items -sub rx { - return (@_ > 1) ? ($_[0]->{-rx} = $_[1]) : $_[0]->{-rx}; -} - -=item $list-E<gt>item() - -Without argument, retrieves the array of the items in this list. -The items may be represented by any scalar. -If an argument has been given, it is pushed on the list of items. - -=cut - -# The individual =items of this list -sub item { - my ($self,$item) = @_; - if(defined $item) { - push(@{$self->{_items}}, $item); - return $item; - } - else { - return @{$self->{_items}}; - } -} - -=item $list-E<gt>parent() - -Without argument, retrieves information about the parent holding this -list, which is represented as an arbitrary scalar. -This must have been set before by either specifying -B<-parent> in the B<new()> method or by calling the B<parent()> method -with a scalar argument. - -=cut - -# possibility for parsers/translators to store information about the -# lists's parent object -sub parent { - return (@_ > 1) ? ($_[0]->{-parent} = $_[1]) : $_[0]->{-parent}; -} - -=item $list-E<gt>tag() - -Without argument, retrieves information about the list tag, which can be -any scalar. -This must have been set before by either specifying -B<-tag> in the B<new()> method or by calling the B<tag()> method -with a scalar argument. - -=back - -=cut - -# possibility for parsers/translators to store information about the -# list's object -sub tag { - return (@_ > 1) ? ($_[0]->{-tag} = $_[1]) : $_[0]->{-tag}; -} - -#----------------------------------------------------------------------------- -# Pod::Hyperlink -# -# class to manipulate POD hyperlinks (L<>) -#----------------------------------------------------------------------------- - -package Pod::Hyperlink; - -=head2 Pod::Hyperlink - -B<Pod::Hyperlink> is a class for manipulation of POD hyperlinks. Usage: - - my $link = Pod::Hyperlink->new('alternative text|page/"section in page"'); - -The B<Pod::Hyperlink> class is mainly designed to parse the contents of the -C<LE<lt>...E<gt>> sequence, providing a simple interface for accessing the -different parts of a POD hyperlink for further processing. It can also be -used to construct hyperlinks. - -=over 4 - -=item Pod::Hyperlink-E<gt>new() - -The B<new()> method can either be passed a set of key/value pairs or a single -scalar value, namely the contents of a C<LE<lt>...E<gt>> sequence. An object -of the class C<Pod::Hyperlink> is returned. The value C<undef> indicates a -failure, the error message is stored in C<$@>. - -=cut - -use Carp; - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = +{}; - bless $self, $class; - $self->initialize(); - if(defined $_[0]) { - if(ref($_[0])) { - # called with a list of parameters - %$self = %{$_[0]}; - $self->_construct_text(); - } - else { - # called with L<> contents - return unless($self->parse($_[0])); - } - } - return $self; -} - -sub initialize { - my $self = shift; - $self->{-line} ||= 'undef'; - $self->{-file} ||= 'undef'; - $self->{-page} ||= ''; - $self->{-node} ||= ''; - $self->{-alttext} ||= ''; - $self->{-type} ||= 'undef'; - $self->{_warnings} = []; -} - -=item $link-E<gt>parse($string) - -This method can be used to (re)parse a (new) hyperlink, i.e. the contents -of a C<LE<lt>...E<gt>> sequence. The result is stored in the current object. -Warnings are stored in the B<warnings> property. -E.g. sections like C<LE<lt>open(2)E<gt>> are deprecated, as they do not point -to Perl documents. C<LE<lt>DBI::foo(3p)E<gt>> is wrong as well, the manpage -section can simply be dropped. - -=cut - -sub parse { - my $self = shift; - local($_) = $_[0]; - # syntax check the link and extract destination - my ($alttext,$page,$node,$type,$quoted) = (undef,'','','',0); - - $self->{_warnings} = []; - - # collapse newlines with whitespace - s/\s*\n+\s*/ /g; - - # strip leading/trailing whitespace - if(s/^[\s\n]+//) { - $self->warning('ignoring leading whitespace in link'); - } - if(s/[\s\n]+$//) { - $self->warning('ignoring trailing whitespace in link'); - } - unless(length($_)) { - _invalid_link('empty link'); - return; - } - - ## Check for different possibilities. This is tedious and error-prone - # we match all possibilities (alttext, page, section/item) - #warn "DEBUG: link=$_\n"; - - # only page - # problem: a lot of people use (), or (1) or the like to indicate - # man page sections. But this collides with L<func()> that is supposed - # to point to an internal function... - my $page_rx = '[\w.-]+(?:::[\w.-]+)*(?:[(](?:\d\w*|)[)]|)'; - # page name only - if(/^($page_rx)$/o) { - $page = $1; - $type = 'page'; - } - # alttext, page and "section" - elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*"(.+)"$}o) { - ($alttext, $page, $node) = ($1, $2, $3); - $type = 'section'; - $quoted = 1; #... therefore | and / are allowed - } - # alttext and page - elsif(/^(.*?)\s*[|]\s*($page_rx)$/o) { - ($alttext, $page) = ($1, $2); - $type = 'page'; - } - # alttext and "section" - elsif(m{^(.*?)\s*[|]\s*(?:/\s*|)"(.+)"$}) { - ($alttext, $node) = ($1,$2); - $type = 'section'; - $quoted = 1; - } - # page and "section" - elsif(m{^($page_rx)\s*/\s*"(.+)"$}o) { - ($page, $node) = ($1, $2); - $type = 'section'; - $quoted = 1; - } - # page and item - elsif(m{^($page_rx)\s*/\s*(.+)$}o) { - ($page, $node) = ($1, $2); - $type = 'item'; - } - # only "section" - elsif(m{^/?"(.+)"$}) { - $node = $1; - $type = 'section'; - $quoted = 1; - } - # only item - elsif(m{^\s*/(.+)$}) { - $node = $1; - $type = 'item'; - } - - # non-standard: Hyperlink with alt-text - doesn't remove protocol prefix, maybe it should? - elsif(/^ \s* (.*?) \s* [|] \s* (\w+:[^:\s] [^\s|]*?) \s* $/ix) { - ($alttext,$node) = ($1,$2); - $type = 'hyperlink'; - } - - # non-standard: Hyperlink - elsif(/^(\w+:[^:\s]\S*)$/i) { - $node = $1; - $type = 'hyperlink'; - } - # alttext, page and item - elsif(m{^(.*?)\s*[|]\s*($page_rx)\s*/\s*(.+)$}o) { - ($alttext, $page, $node) = ($1, $2, $3); - $type = 'item'; - } - # alttext and item - elsif(m{^(.*?)\s*[|]\s*/(.+)$}) { - ($alttext, $node) = ($1,$2); - } - # must be an item or a "malformed" section (without "") - else { - $node = $_; - $type = 'item'; - } - # collapse whitespace in nodes - $node =~ s/\s+/ /gs; - - # empty alternative text expands to node name - if(defined $alttext) { - if(!length($alttext)) { - $alttext = $node || $page; - } - } - else { - $alttext = ''; - } - - if($page =~ /[(]\w*[)]$/) { - $self->warning("(section) in '$page' deprecated"); - } - if(!$quoted && $node =~ m{[|/]} && $type ne 'hyperlink') { - $self->warning("node '$node' contains non-escaped | or /"); - } - if($alttext =~ m{[|/]}) { - $self->warning("alternative text '$node' contains non-escaped | or /"); - } - $self->{-page} = $page; - $self->{-node} = $node; - $self->{-alttext} = $alttext; - #warn "DEBUG: page=$page section=$section item=$item alttext=$alttext\n"; - $self->{-type} = $type; - $self->_construct_text(); - 1; -} - -sub _construct_text { - my $self = shift; - my $alttext = $self->alttext(); - my $type = $self->type(); - my $section = $self->node(); - my $page = $self->page(); - my $page_ext = ''; - $page =~ s/([(]\w*[)])$// && ($page_ext = $1); - if($alttext) { - $self->{_text} = $alttext; - } - elsif($type eq 'hyperlink') { - $self->{_text} = $section; - } - else { - $self->{_text} = ($section || '') . - (($page && $section) ? ' in ' : '') . - "$page$page_ext"; - } - # for being marked up later - # use the non-standard markers P<> and Q<>, so that the resulting - # text can be parsed by the translators. It's their job to put - # the correct hypertext around the linktext - if($alttext) { - $self->{_markup} = "Q<$alttext>"; - } - elsif($type eq 'hyperlink') { - $self->{_markup} = "Q<$section>"; - } - else { - $self->{_markup} = (!$section ? '' : "Q<$section>") . - ($page ? ($section ? ' in ':'') . "P<$page>$page_ext" : ''); - } -} - -=item $link-E<gt>markup($string) - -Set/retrieve the textual value of the link. This string contains special -markers C<PE<lt>E<gt>> and C<QE<lt>E<gt>> that should be expanded by the -translator's interior sequence expansion engine to the -formatter-specific code to highlight/activate the hyperlink. The details -have to be implemented in the translator. - -=cut - -#' retrieve/set markuped text -sub markup { - return (@_ > 1) ? ($_[0]->{_markup} = $_[1]) : $_[0]->{_markup}; -} - -=item $link-E<gt>text() - -This method returns the textual representation of the hyperlink as above, -but without markers (read only). Depending on the link type this is one of -the following alternatives (the + and * denote the portions of the text -that are marked up): - - +perl+ L<perl> - *$|* in +perlvar+ L<perlvar/$|> - *OPTIONS* in +perldoc+ L<perldoc/"OPTIONS"> - *DESCRIPTION* L<"DESCRIPTION"> - -=cut - -# The complete link's text -sub text { - return $_[0]->{_text}; -} - -=item $link-E<gt>warning() - -After parsing, this method returns any warnings encountered during the -parsing process. - -=cut - -# Set/retrieve warnings -sub warning { - my $self = shift; - if(@_) { - push(@{$self->{_warnings}}, @_); - return @_; - } - return @{$self->{_warnings}}; -} - -=item $link-E<gt>file() - -=item $link-E<gt>line() - -Just simple slots for storing information about the line and the file -the link was encountered in. Has to be filled in manually. - -=cut - -# The line in the file the link appears -sub line { - return (@_ > 1) ? ($_[0]->{-line} = $_[1]) : $_[0]->{-line}; -} - -# The POD file name the link appears in -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $link-E<gt>page() - -This method sets or returns the POD page this link points to. - -=cut - -# The POD page the link appears on -sub page { - if (@_ > 1) { - $_[0]->{-page} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-page}; -} - -=item $link-E<gt>node() - -As above, but the destination node text of the link. - -=cut - -# The link destination -sub node { - if (@_ > 1) { - $_[0]->{-node} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-node}; -} - -=item $link-E<gt>alttext() - -Sets or returns an alternative text specified in the link. - -=cut - -# Potential alternative text -sub alttext { - if (@_ > 1) { - $_[0]->{-alttext} = $_[1]; - $_[0]->_construct_text(); - } - return $_[0]->{-alttext}; -} - -=item $link-E<gt>type() - -The node type, either C<section> or C<item>. As an unofficial type, -there is also C<hyperlink>, derived from e.g. C<LE<lt>http://perl.comE<gt>> - -=cut - -# The type: item or headn -sub type { - return (@_ > 1) ? ($_[0]->{-type} = $_[1]) : $_[0]->{-type}; -} - -=item $link-E<gt>link() - -Returns the link as contents of C<LE<lt>E<gt>>. Reciprocal to B<parse()>. - -=back - -=cut - -# The link itself -sub link { - my $self = shift; - my $link = $self->page() || ''; - if($self->node()) { - my $node = $self->node(); - $node =~ s/\|/E<verbar>/g; - $node =~ s{/}{E<sol>}g; - if($self->type() eq 'section') { - $link .= ($link ? '/' : '') . '"' . $node . '"'; - } - elsif($self->type() eq 'hyperlink') { - $link = $self->node(); - } - else { # item - $link .= '/' . $node; - } - } - if($self->alttext()) { - my $text = $self->alttext(); - $text =~ s/\|/E<verbar>/g; - $text =~ s{/}{E<sol>}g; - $link = "$text|$link"; - } - return $link; -} - -sub _invalid_link { - my ($msg) = @_; - # this sets @_ - #eval { die "$msg\n" }; - #chomp $@; - $@ = $msg; # this seems to work, too! - return; -} - -#----------------------------------------------------------------------------- -# Pod::Cache -# -# class to hold POD page details -#----------------------------------------------------------------------------- - -package Pod::Cache; - -=head2 Pod::Cache - -B<Pod::Cache> holds information about a set of POD documents, -especially the nodes for hyperlinks. -The following methods are available: - -=over 4 - -=item Pod::Cache-E<gt>new() - -Create a new cache object. This object can hold an arbitrary number of -POD documents of class Pod::Cache::Item. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my $self = []; - bless $self, $class; - return $self; -} - -=item $cache-E<gt>item() - -Add a new item to the cache. Without arguments, this method returns a -list of all cache elements. - -=cut - -sub item { - my ($self,%param) = @_; - if(%param) { - my $item = Pod::Cache::Item->new(%param); - push(@$self, $item); - return $item; - } - else { - return @{$self}; - } -} - -=item $cache-E<gt>find_page($name) - -Look for a POD document named C<$name> in the cache. Returns the -reference to the corresponding Pod::Cache::Item object or undef if -not found. - -=back - -=cut - -sub find_page { - my ($self,$page) = @_; - foreach(@$self) { - if($_->page() eq $page) { - return $_; - } - } - return; -} - -package Pod::Cache::Item; - -=head2 Pod::Cache::Item - -B<Pod::Cache::Item> holds information about individual POD documents, -that can be grouped in a Pod::Cache object. -It is intended to hold information about the hyperlink nodes of POD -documents. -The following methods are available: - -=over 4 - -=item Pod::Cache::Item-E<gt>new() - -Create a new object. - -=cut - -sub new { - my $this = shift; - my $class = ref($this) || $this; - my %params = @_; - my $self = {%params}; - bless $self, $class; - $self->initialize(); - return $self; -} - -sub initialize { - my $self = shift; - $self->{-nodes} = [] unless(defined $self->{-nodes}); -} - -=item $cacheitem-E<gt>page() - -Set/retrieve the POD document name (e.g. "Pod::Parser"). - -=cut - -# The POD page -sub page { - return (@_ > 1) ? ($_[0]->{-page} = $_[1]) : $_[0]->{-page}; -} - -=item $cacheitem-E<gt>description() - -Set/retrieve the POD short description as found in the C<=head1 NAME> -section. - -=cut - -# The POD description, taken out of NAME if present -sub description { - return (@_ > 1) ? ($_[0]->{-description} = $_[1]) : $_[0]->{-description}; -} - -=item $cacheitem-E<gt>path() - -Set/retrieve the POD file storage path. - -=cut - -# The file path -sub path { - return (@_ > 1) ? ($_[0]->{-path} = $_[1]) : $_[0]->{-path}; -} - -=item $cacheitem-E<gt>file() - -Set/retrieve the POD file name. - -=cut - -# The POD file name -sub file { - return (@_ > 1) ? ($_[0]->{-file} = $_[1]) : $_[0]->{-file}; -} - -=item $cacheitem-E<gt>nodes() - -Add a node (or a list of nodes) to the document's node list. Note that -the order is kept, i.e. start with the first node and end with the last. -If no argument is given, the current list of nodes is returned in the -same order the nodes have been added. -A node can be any scalar, but usually is a pair of node string and -unique id for the C<find_node> method to work correctly. - -=cut - -# The POD nodes -sub nodes { - my ($self,@nodes) = @_; - if(@nodes) { - push(@{$self->{-nodes}}, @nodes); - return @nodes; - } - else { - return @{$self->{-nodes}}; - } -} - -=item $cacheitem-E<gt>find_node($name) - -Look for a node or index entry named C<$name> in the object. -Returns the unique id of the node (i.e. the second element of the array -stored in the node array) or undef if not found. - -=cut - -sub find_node { - my ($self,$node) = @_; - my @search; - push(@search, @{$self->{-nodes}}) if($self->{-nodes}); - push(@search, @{$self->{-idx}}) if($self->{-idx}); - foreach(@search) { - if($_->[0] eq $node) { - return $_->[1]; # id - } - } - return; -} - -=item $cacheitem-E<gt>idx() - -Add an index entry (or a list of them) to the document's index list. Note that -the order is kept, i.e. start with the first node and end with the last. -If no argument is given, the current list of index entries is returned in the -same order the entries have been added. -An index entry can be any scalar, but usually is a pair of string and -unique id. - -=back - -=cut - -# The POD index entries -sub idx { - my ($self,@idx) = @_; - if(@idx) { - push(@{$self->{-idx}}, @idx); - return @idx; - } - else { - return @{$self->{-idx}}; - } -} - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Marek Rouchal E<lt>marekr@cpan.orgE<gt>, borrowing -a lot of things from L<pod2man> and L<pod2roff> as well as other POD -processing tools by Tom Christiansen, Brad Appleton and Russ Allbery. - -B<Pod::ParseUtils> is part of the L<Pod::Parser> distribution. - -=head1 SEE ALSO - -L<pod2man>, L<pod2roff>, L<Pod::Parser>, L<Pod::Checker>, -L<pod2html> - -=cut - -1; diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Parser.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Parser.pm deleted file mode 100644 index 63edcd2e197..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Parser.pm +++ /dev/null @@ -1,1836 +0,0 @@ -############################################################################# -# Pod/Parser.pm -- package which defines a base class for parsing POD docs. -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Parser; -use strict; - -## These "variables" are used as local "glob aliases" for performance -use vars qw($VERSION @ISA %myData %myOpts @input_stack); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::Parser - base class for creating POD filters and translators - -=head1 SYNOPSIS - - use Pod::Parser; - - package MyParser; - @ISA = qw(Pod::Parser); - - sub command { - my ($parser, $command, $paragraph, $line_num) = @_; - ## Interpret the command and its text; sample actions might be: - if ($command eq 'head1') { ... } - elsif ($command eq 'head2') { ... } - ## ... other commands and their actions - my $out_fh = $parser->output_handle(); - my $expansion = $parser->interpolate($paragraph, $line_num); - print $out_fh $expansion; - } - - sub verbatim { - my ($parser, $paragraph, $line_num) = @_; - ## Format verbatim paragraph; sample actions might be: - my $out_fh = $parser->output_handle(); - print $out_fh $paragraph; - } - - sub textblock { - my ($parser, $paragraph, $line_num) = @_; - ## Translate/Format this block of text; sample actions might be: - my $out_fh = $parser->output_handle(); - my $expansion = $parser->interpolate($paragraph, $line_num); - print $out_fh $expansion; - } - - sub interior_sequence { - my ($parser, $seq_command, $seq_argument) = @_; - ## Expand an interior sequence; sample actions might be: - return "*$seq_argument*" if ($seq_command eq 'B'); - return "`$seq_argument'" if ($seq_command eq 'C'); - return "_${seq_argument}_'" if ($seq_command eq 'I'); - ## ... other sequence commands and their resulting text - } - - package main; - - ## Create a parser object and have it parse file whose name was - ## given on the command-line (use STDIN if no files were given). - $parser = new MyParser(); - $parser->parse_from_filehandle(\*STDIN) if (@ARGV == 0); - for (@ARGV) { $parser->parse_from_file($_); } - -=head1 REQUIRES - -perl5.005, Pod::InputObjects, Exporter, Symbol, Carp - -=head1 EXPORTS - -Nothing. - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<Pod::Parser> is a base class for creating POD filters and translators. -It handles most of the effort involved with parsing the POD sections -from an input stream, leaving subclasses free to be concerned only with -performing the actual translation of text. - -B<Pod::Parser> parses PODs, and makes method calls to handle the various -components of the POD. Subclasses of B<Pod::Parser> override these methods -to translate the POD into whatever output format they desire. - -=head1 QUICK OVERVIEW - -To create a POD filter for translating POD documentation into some other -format, you create a subclass of B<Pod::Parser> which typically overrides -just the base class implementation for the following methods: - -=over 2 - -=item * - -B<command()> - -=item * - -B<verbatim()> - -=item * - -B<textblock()> - -=item * - -B<interior_sequence()> - -=back - -You may also want to override the B<begin_input()> and B<end_input()> -methods for your subclass (to perform any needed per-file and/or -per-document initialization or cleanup). - -If you need to perform any preprocessing of input before it is parsed -you may want to override one or more of B<preprocess_line()> and/or -B<preprocess_paragraph()>. - -Sometimes it may be necessary to make more than one pass over the input -files. If this is the case you have several options. You can make the -first pass using B<Pod::Parser> and override your methods to store the -intermediate results in memory somewhere for the B<end_pod()> method to -process. You could use B<Pod::Parser> for several passes with an -appropriate state variable to control the operation for each pass. If -your input source can't be reset to start at the beginning, you can -store it in some other structure as a string or an array and have that -structure implement a B<getline()> method (which is all that -B<parse_from_filehandle()> uses to read input). - -Feel free to add any member data fields you need to keep track of things -like current font, indentation, horizontal or vertical position, or -whatever else you like. Be sure to read L<"PRIVATE METHODS AND DATA"> -to avoid name collisions. - -For the most part, the B<Pod::Parser> base class should be able to -do most of the input parsing for you and leave you free to worry about -how to interpret the commands and translate the result. - -Note that all we have described here in this quick overview is the -simplest most straightforward use of B<Pod::Parser> to do stream-based -parsing. It is also possible to use the B<Pod::Parser::parse_text> function -to do more sophisticated tree-based parsing. See L<"TREE-BASED PARSING">. - -=head1 PARSING OPTIONS - -A I<parse-option> is simply a named option of B<Pod::Parser> with a -value that corresponds to a certain specified behavior. These various -behaviors of B<Pod::Parser> may be enabled/disabled by setting -or unsetting one or more I<parse-options> using the B<parseopts()> method. -The set of currently accepted parse-options is as follows: - -=over 3 - -=item B<-want_nonPODs> (default: unset) - -Normally (by default) B<Pod::Parser> will only provide access to -the POD sections of the input. Input paragraphs that are not part -of the POD-format documentation are not made available to the caller -(not even using B<preprocess_paragraph()>). Setting this option to a -non-empty, non-zero value will allow B<preprocess_paragraph()> to see -non-POD sections of the input as well as POD sections. The B<cutting()> -method can be used to determine if the corresponding paragraph is a POD -paragraph, or some other input paragraph. - -=item B<-process_cut_cmd> (default: unset) - -Normally (by default) B<Pod::Parser> handles the C<=cut> POD directive -by itself and does not pass it on to the caller for processing. Setting -this option to a non-empty, non-zero value will cause B<Pod::Parser> to -pass the C<=cut> directive to the caller just like any other POD command -(and hence it may be processed by the B<command()> method). - -B<Pod::Parser> will still interpret the C<=cut> directive to mean that -"cutting mode" has been (re)entered, but the caller will get a chance -to capture the actual C<=cut> paragraph itself for whatever purpose -it desires. - -=item B<-warnings> (default: unset) - -Normally (by default) B<Pod::Parser> recognizes a bare minimum of -pod syntax errors and warnings and issues diagnostic messages -for errors, but not for warnings. (Use B<Pod::Checker> to do more -thorough checking of POD syntax.) Setting this option to a non-empty, -non-zero value will cause B<Pod::Parser> to issue diagnostics for -the few warnings it recognizes as well as the errors. - -=back - -Please see L<"parseopts()"> for a complete description of the interface -for the setting and unsetting of parse-options. - -=cut - -############################################################################# - -#use diagnostics; -use Pod::InputObjects; -use Carp; -use Exporter; -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} -@ISA = qw(Exporter); - -############################################################################# - -=head1 RECOMMENDED SUBROUTINE/METHOD OVERRIDES - -B<Pod::Parser> provides several methods which most subclasses will probably -want to override. These methods are as follows: - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<command()> - - $parser->command($cmd,$text,$line_num,$pod_para); - -This method should be overridden by subclasses to take the appropriate -action when a POD command paragraph (denoted by a line beginning with -"=") is encountered. When such a POD directive is seen in the input, -this method is called and is passed: - -=over 3 - -=item C<$cmd> - -the name of the command for this POD paragraph - -=item C<$text> - -the paragraph text for the given POD paragraph command. - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C<Pod::Paragraph> object which contains further -information about the paragraph command (see L<Pod::InputObjects> -for details). - -=back - -B<Note> that this method I<is> called for C<=pod> paragraphs. - -The base class implementation of this method simply treats the raw POD -command as normal block of paragraph text (invoking the B<textblock()> -method with the command paragraph). - -=cut - -sub command { - my ($self, $cmd, $text, $line_num, $pod_para) = @_; - ## Just treat this like a textblock - $self->textblock($pod_para->raw_text(), $line_num, $pod_para); -} - -##--------------------------------------------------------------------------- - -=head1 B<verbatim()> - - $parser->verbatim($text,$line_num,$pod_para); - -This method may be overridden by subclasses to take the appropriate -action when a block of verbatim text is encountered. It is passed the -following parameters: - -=over 3 - -=item C<$text> - -the block of text for the verbatim paragraph - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C<Pod::Paragraph> object which contains further -information about the paragraph (see L<Pod::InputObjects> -for details). - -=back - -The base class implementation of this method simply prints the textblock -(unmodified) to the output filehandle. - -=cut - -sub verbatim { - my ($self, $text, $line_num, $pod_para) = @_; - my $out_fh = $self->{_OUTPUT}; - print $out_fh $text; -} - -##--------------------------------------------------------------------------- - -=head1 B<textblock()> - - $parser->textblock($text,$line_num,$pod_para); - -This method may be overridden by subclasses to take the appropriate -action when a normal block of POD text is encountered (although the base -class method will usually do what you want). It is passed the following -parameters: - -=over 3 - -=item C<$text> - -the block of text for the a POD paragraph - -=item C<$line_num> - -the line-number of the beginning of the paragraph - -=item C<$pod_para> - -a reference to a C<Pod::Paragraph> object which contains further -information about the paragraph (see L<Pod::InputObjects> -for details). - -=back - -In order to process interior sequences, subclasses implementations of -this method will probably want to invoke either B<interpolate()> or -B<parse_text()>, passing it the text block C<$text>, and the corresponding -line number in C<$line_num>, and then perform any desired processing upon -the returned result. - -The base class implementation of this method simply prints the text block -as it occurred in the input stream). - -=cut - -sub textblock { - my ($self, $text, $line_num, $pod_para) = @_; - my $out_fh = $self->{_OUTPUT}; - print $out_fh $self->interpolate($text, $line_num); -} - -##--------------------------------------------------------------------------- - -=head1 B<interior_sequence()> - - $parser->interior_sequence($seq_cmd,$seq_arg,$pod_seq); - -This method should be overridden by subclasses to take the appropriate -action when an interior sequence is encountered. An interior sequence is -an embedded command within a block of text which appears as a command -name (usually a single uppercase character) followed immediately by a -string of text which is enclosed in angle brackets. This method is -passed the sequence command C<$seq_cmd> and the corresponding text -C<$seq_arg>. It is invoked by the B<interpolate()> method for each interior -sequence that occurs in the string that it is passed. It should return -the desired text string to be used in place of the interior sequence. -The C<$pod_seq> argument is a reference to a C<Pod::InteriorSequence> -object which contains further information about the interior sequence. -Please see L<Pod::InputObjects> for details if you need to access this -additional information. - -Subclass implementations of this method may wish to invoke the -B<nested()> method of C<$pod_seq> to see if it is nested inside -some other interior-sequence (and if so, which kind). - -The base class implementation of the B<interior_sequence()> method -simply returns the raw text of the interior sequence (as it occurred -in the input) to the caller. - -=cut - -sub interior_sequence { - my ($self, $seq_cmd, $seq_arg, $pod_seq) = @_; - ## Just return the raw text of the interior sequence - return $pod_seq->raw_text(); -} - -############################################################################# - -=head1 OPTIONAL SUBROUTINE/METHOD OVERRIDES - -B<Pod::Parser> provides several methods which subclasses may want to override -to perform any special pre/post-processing. These methods do I<not> have to -be overridden, but it may be useful for subclasses to take advantage of them. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<new()> - - my $parser = Pod::Parser->new(); - -This is the constructor for B<Pod::Parser> and its subclasses. You -I<do not> need to override this method! It is capable of constructing -subclass objects as well as base class objects, provided you use -any of the following constructor invocation styles: - - my $parser1 = MyParser->new(); - my $parser2 = new MyParser(); - my $parser3 = $parser2->new(); - -where C<MyParser> is some subclass of B<Pod::Parser>. - -Using the syntax C<MyParser::new()> to invoke the constructor is I<not> -recommended, but if you insist on being able to do this, then the -subclass I<will> need to override the B<new()> constructor method. If -you do override the constructor, you I<must> be sure to invoke the -B<initialize()> method of the newly blessed object. - -Using any of the above invocations, the first argument to the -constructor is always the corresponding package name (or object -reference). No other arguments are required, but if desired, an -associative array (or hash-table) my be passed to the B<new()> -constructor, as in: - - my $parser1 = MyParser->new( MYDATA => $value1, MOREDATA => $value2 ); - my $parser2 = new MyParser( -myflag => 1 ); - -All arguments passed to the B<new()> constructor will be treated as -key/value pairs in a hash-table. The newly constructed object will be -initialized by copying the contents of the given hash-table (which may -have been empty). The B<new()> constructor for this class and all of its -subclasses returns a blessed reference to the initialized object (hash-table). - -=cut - -sub new { - ## Determine if we were called via an object-ref or a classname - my ($this,%params) = @_; - my $class = ref($this) || $this; - ## Any remaining arguments are treated as initial values for the - ## hash that is used to represent this object. - my $self = { %params }; - ## Bless ourselves into the desired class and perform any initialization - bless $self, $class; - $self->initialize(); - return $self; -} - -##--------------------------------------------------------------------------- - -=head1 B<initialize()> - - $parser->initialize(); - -This method performs any necessary object initialization. It takes no -arguments (other than the object instance of course, which is typically -copied to a local variable named C<$self>). If subclasses override this -method then they I<must> be sure to invoke C<$self-E<gt>SUPER::initialize()>. - -=cut - -sub initialize { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<begin_pod()> - - $parser->begin_pod(); - -This method is invoked at the beginning of processing for each POD -document that is encountered in the input. Subclasses should override -this method to perform any per-document initialization. - -=cut - -sub begin_pod { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<begin_input()> - - $parser->begin_input(); - -This method is invoked by B<parse_from_filehandle()> immediately I<before> -processing input from a filehandle. The base class implementation does -nothing, however, subclasses may override it to perform any per-file -initializations. - -Note that if multiple files are parsed for a single POD document -(perhaps the result of some future C<=include> directive) this method -is invoked for every file that is parsed. If you wish to perform certain -initializations once per document, then you should use B<begin_pod()>. - -=cut - -sub begin_input { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<end_input()> - - $parser->end_input(); - -This method is invoked by B<parse_from_filehandle()> immediately I<after> -processing input from a filehandle. The base class implementation does -nothing, however, subclasses may override it to perform any per-file -cleanup actions. - -Please note that if multiple files are parsed for a single POD document -(perhaps the result of some kind of C<=include> directive) this method -is invoked for every file that is parsed. If you wish to perform certain -cleanup actions once per document, then you should use B<end_pod()>. - -=cut - -sub end_input { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<end_pod()> - - $parser->end_pod(); - -This method is invoked at the end of processing for each POD document -that is encountered in the input. Subclasses should override this method -to perform any per-document finalization. - -=cut - -sub end_pod { - #my $self = shift; - #return; -} - -##--------------------------------------------------------------------------- - -=head1 B<preprocess_line()> - - $textline = $parser->preprocess_line($text, $line_num); - -This method should be overridden by subclasses that wish to perform -any kind of preprocessing for each I<line> of input (I<before> it has -been determined whether or not it is part of a POD paragraph). The -parameter C<$text> is the input line; and the parameter C<$line_num> is -the line number of the corresponding text line. - -The value returned should correspond to the new text to use in its -place. If the empty string or an undefined value is returned then no -further processing will be performed for this line. - -Please note that the B<preprocess_line()> method is invoked I<before> -the B<preprocess_paragraph()> method. After all (possibly preprocessed) -lines in a paragraph have been assembled together and it has been -determined that the paragraph is part of the POD documentation from one -of the selected sections, then B<preprocess_paragraph()> is invoked. - -The base class implementation of this method returns the given text. - -=cut - -sub preprocess_line { - my ($self, $text, $line_num) = @_; - return $text; -} - -##--------------------------------------------------------------------------- - -=head1 B<preprocess_paragraph()> - - $textblock = $parser->preprocess_paragraph($text, $line_num); - -This method should be overridden by subclasses that wish to perform any -kind of preprocessing for each block (paragraph) of POD documentation -that appears in the input stream. The parameter C<$text> is the POD -paragraph from the input file; and the parameter C<$line_num> is the -line number for the beginning of the corresponding paragraph. - -The value returned should correspond to the new text to use in its -place If the empty string is returned or an undefined value is -returned, then the given C<$text> is ignored (not processed). - -This method is invoked after gathering up all the lines in a paragraph -and after determining the cutting state of the paragraph, -but before trying to further parse or interpret them. After -B<preprocess_paragraph()> returns, the current cutting state (which -is returned by C<$self-E<gt>cutting()>) is examined. If it evaluates -to true then input text (including the given C<$text>) is cut (not -processed) until the next POD directive is encountered. - -Please note that the B<preprocess_line()> method is invoked I<before> -the B<preprocess_paragraph()> method. After all (possibly preprocessed) -lines in a paragraph have been assembled together and either it has been -determined that the paragraph is part of the POD documentation from one -of the selected sections or the C<-want_nonPODs> option is true, -then B<preprocess_paragraph()> is invoked. - -The base class implementation of this method returns the given text. - -=cut - -sub preprocess_paragraph { - my ($self, $text, $line_num) = @_; - return $text; -} - -############################################################################# - -=head1 METHODS FOR PARSING AND PROCESSING - -B<Pod::Parser> provides several methods to process input text. These -methods typically won't need to be overridden (and in some cases they -can't be overridden), but subclasses may want to invoke them to exploit -their functionality. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<parse_text()> - - $ptree1 = $parser->parse_text($text, $line_num); - $ptree2 = $parser->parse_text({%opts}, $text, $line_num); - $ptree3 = $parser->parse_text(\%opts, $text, $line_num); - -This method is useful if you need to perform your own interpolation -of interior sequences and can't rely upon B<interpolate> to expand -them in simple bottom-up order. - -The parameter C<$text> is a string or block of text to be parsed -for interior sequences; and the parameter C<$line_num> is the -line number corresponding to the beginning of C<$text>. - -B<parse_text()> will parse the given text into a parse-tree of "nodes." -and interior-sequences. Each "node" in the parse tree is either a -text-string, or a B<Pod::InteriorSequence>. The result returned is a -parse-tree of type B<Pod::ParseTree>. Please see L<Pod::InputObjects> -for more information about B<Pod::InteriorSequence> and B<Pod::ParseTree>. - -If desired, an optional hash-ref may be specified as the first argument -to customize certain aspects of the parse-tree that is created and -returned. The set of recognized option keywords are: - -=over 3 - -=item B<-expand_seq> =E<gt> I<code-ref>|I<method-name> - -Normally, the parse-tree returned by B<parse_text()> will contain an -unexpanded C<Pod::InteriorSequence> object for each interior-sequence -encountered. Specifying B<-expand_seq> tells B<parse_text()> to "expand" -every interior-sequence it sees by invoking the referenced function -(or named method of the parser object) and using the return value as the -expanded result. - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $sequence ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $sequence ) - -where C<$parser> is a reference to the parser object, and C<$sequence> -is a reference to the interior-sequence object. -[I<NOTE>: If the B<interior_sequence()> method is specified, then it is -invoked according to the interface specified in L<"interior_sequence()">]. - -=item B<-expand_text> =E<gt> I<code-ref>|I<method-name> - -Normally, the parse-tree returned by B<parse_text()> will contain a -text-string for each contiguous sequence of characters outside of an -interior-sequence. Specifying B<-expand_text> tells B<parse_text()> to -"preprocess" every such text-string it sees by invoking the referenced -function (or named method of the parser object) and using the return value -as the preprocessed (or "expanded") result. [Note that if the result is -an interior-sequence, then it will I<not> be expanded as specified by the -B<-expand_seq> option; Any such recursive expansion needs to be handled by -the specified callback routine.] - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $text, $ptree_node ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $text, $ptree_node ) - -where C<$parser> is a reference to the parser object, C<$text> is the -text-string encountered, and C<$ptree_node> is a reference to the current -node in the parse-tree (usually an interior-sequence object or else the -top-level node of the parse-tree). - -=item B<-expand_ptree> =E<gt> I<code-ref>|I<method-name> - -Rather than returning a C<Pod::ParseTree>, pass the parse-tree as an -argument to the referenced subroutine (or named method of the parser -object) and return the result instead of the parse-tree object. - -If a subroutine reference was given, it is invoked as: - - &$code_ref( $parser, $ptree ) - -and if a method-name was given, it is invoked as: - - $parser->method_name( $ptree ) - -where C<$parser> is a reference to the parser object, and C<$ptree> -is a reference to the parse-tree object. - -=back - -=cut - -sub parse_text { - my $self = shift; - local $_ = ''; - - ## Get options and set any defaults - my %opts = (ref $_[0]) ? %{ shift() } : (); - my $expand_seq = $opts{'-expand_seq'} || undef; - my $expand_text = $opts{'-expand_text'} || undef; - my $expand_ptree = $opts{'-expand_ptree'} || undef; - - my $text = shift; - my $line = shift; - my $file = $self->input_file(); - my $cmd = ""; - - ## Convert method calls into closures, for our convenience - my $xseq_sub = $expand_seq; - my $xtext_sub = $expand_text; - my $xptree_sub = $expand_ptree; - if (defined $expand_seq and $expand_seq eq 'interior_sequence') { - ## If 'interior_sequence' is the method to use, we have to pass - ## more than just the sequence object, we also need to pass the - ## sequence name and text. - $xseq_sub = sub { - my ($sself, $iseq) = @_; - my $args = join('', $iseq->parse_tree->children); - return $sself->interior_sequence($iseq->name, $args, $iseq); - }; - } - ref $xseq_sub or $xseq_sub = sub { shift()->$expand_seq(@_) }; - ref $xtext_sub or $xtext_sub = sub { shift()->$expand_text(@_) }; - ref $xptree_sub or $xptree_sub = sub { shift()->$expand_ptree(@_) }; - - ## Keep track of the "current" interior sequence, and maintain a stack - ## of "in progress" sequences. - ## - ## NOTE that we push our own "accumulator" at the very beginning of the - ## stack. It's really a parse-tree, not a sequence; but it implements - ## the methods we need so we can use it to gather-up all the sequences - ## and strings we parse. Thus, by the end of our parsing, it should be - ## the only thing left on our stack and all we have to do is return it! - ## - my $seq = Pod::ParseTree->new(); - my @seq_stack = ($seq); - my ($ldelim, $rdelim) = ('', ''); - - ## Iterate over all sequence starts text (NOTE: split with - ## capturing parens keeps the delimiters) - $_ = $text; - my @tokens = split /([A-Z]<(?:<+(?:\r?\n|[ \t]))?)/; - while ( @tokens ) { - $_ = shift @tokens; - ## Look for the beginning of a sequence - if ( /^([A-Z])(<(?:<+(?:\r?\n|[ \t]))?)$/ ) { - ## Push a new sequence onto the stack of those "in-progress" - my $ldelim_orig; - ($cmd, $ldelim_orig) = ($1, $2); - ($ldelim = $ldelim_orig) =~ s/\s+$//; - ($rdelim = $ldelim) =~ tr/</>/; - $seq = Pod::InteriorSequence->new( - -name => $cmd, - -ldelim => $ldelim_orig, -rdelim => $rdelim, - -file => $file, -line => $line - ); - (@seq_stack > 1) and $seq->nested($seq_stack[-1]); - push @seq_stack, $seq; - } - ## Look for sequence ending - elsif ( @seq_stack > 1 ) { - ## Make sure we match the right kind of closing delimiter - my ($seq_end, $post_seq) = ('', ''); - if ( ($ldelim eq '<' and /\A(.*?)(>)/s) - or /\A(.*?)(\s+$rdelim)/s ) - { - ## Found end-of-sequence, capture the interior and the - ## closing the delimiter, and put the rest back on the - ## token-list - $post_seq = substr($_, length($1) + length($2)); - ($_, $seq_end) = ($1, $2); - (length $post_seq) and unshift @tokens, $post_seq; - } - if (length) { - ## In the middle of a sequence, append this text to it, and - ## don't forget to "expand" it if that's what the caller wanted - $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); - $_ .= $seq_end; - } - if (length $seq_end) { - ## End of current sequence, record terminating delimiter - $seq->rdelim($seq_end); - ## Pop it off the stack of "in progress" sequences - pop @seq_stack; - ## Append result to its parent in current parse tree - $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) - : $seq); - ## Remember the current cmd-name and left-delimiter - if(@seq_stack > 1) { - $cmd = $seq_stack[-1]->name; - $ldelim = $seq_stack[-1]->ldelim; - $rdelim = $seq_stack[-1]->rdelim; - } else { - $cmd = $ldelim = $rdelim = ''; - } - } - } - elsif (length) { - ## In the middle of a sequence, append this text to it, and - ## don't forget to "expand" it if that's what the caller wanted - $seq->append($expand_text ? &$xtext_sub($self,$_,$seq) : $_); - } - ## Keep track of line count - $line += /\n/; - ## Remember the "current" sequence - $seq = $seq_stack[-1]; - } - - ## Handle unterminated sequences - my $errorsub = (@seq_stack > 1) ? $self->errorsub() : undef; - while (@seq_stack > 1) { - ($cmd, $file, $line) = ($seq->name, $seq->file_line); - $ldelim = $seq->ldelim; - ($rdelim = $ldelim) =~ tr/</>/; - $rdelim =~ s/^(\S+)(\s*)$/$2$1/; - pop @seq_stack; - my $errmsg = "*** ERROR: unterminated ${cmd}${ldelim}...${rdelim}". - " at line $line in file $file\n"; - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $self->$errorsub($errmsg) - or carp($errmsg); - $seq_stack[-1]->append($expand_seq ? &$xseq_sub($self,$seq) : $seq); - $seq = $seq_stack[-1]; - } - - ## Return the resulting parse-tree - my $ptree = (pop @seq_stack)->parse_tree; - return $expand_ptree ? &$xptree_sub($self, $ptree) : $ptree; -} - -##--------------------------------------------------------------------------- - -=head1 B<interpolate()> - - $textblock = $parser->interpolate($text, $line_num); - -This method translates all text (including any embedded interior sequences) -in the given text string C<$text> and returns the interpolated result. The -parameter C<$line_num> is the line number corresponding to the beginning -of C<$text>. - -B<interpolate()> merely invokes a private method to recursively expand -nested interior sequences in bottom-up order (innermost sequences are -expanded first). If there is a need to expand nested sequences in -some alternate order, use B<parse_text> instead. - -=cut - -sub interpolate { - my($self, $text, $line_num) = @_; - my %parse_opts = ( -expand_seq => 'interior_sequence' ); - my $ptree = $self->parse_text( \%parse_opts, $text, $line_num ); - return join '', $ptree->children(); -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<parse_paragraph()> - - $parser->parse_paragraph($text, $line_num); - -This method takes the text of a POD paragraph to be processed, along -with its corresponding line number, and invokes the appropriate method -(one of B<command()>, B<verbatim()>, or B<textblock()>). - -For performance reasons, this method is invoked directly without any -dynamic lookup; Hence subclasses may I<not> override it! - -=end __PRIVATE__ - -=cut - -sub parse_paragraph { - my ($self, $text, $line_num) = @_; - local *myData = $self; ## alias to avoid deref-ing overhead - local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options - local $_; - - ## See if we want to preprocess nonPOD paragraphs as well as POD ones. - my $wantNonPods = $myOpts{'-want_nonPODs'}; - - ## Update cutting status - $myData{_CUTTING} = 0 if $text =~ /^={1,2}\S/; - - ## Perform any desired preprocessing if we wanted it this early - $wantNonPods and $text = $self->preprocess_paragraph($text, $line_num); - - ## Ignore up until next POD directive if we are cutting - return if $myData{_CUTTING}; - - ## Now we know this is block of text in a POD section! - - ##----------------------------------------------------------------- - ## This is a hook (hack ;-) for Pod::Select to do its thing without - ## having to override methods, but also without Pod::Parser assuming - ## $self is an instance of Pod::Select (if the _SELECTED_SECTIONS - ## field exists then we assume there is an is_selected() method for - ## us to invoke (calling $self->can('is_selected') could verify this - ## but that is more overhead than I want to incur) - ##----------------------------------------------------------------- - - ## Ignore this block if it isn't in one of the selected sections - if (exists $myData{_SELECTED_SECTIONS}) { - $self->is_selected($text) or return ($myData{_CUTTING} = 1); - } - - ## If we haven't already, perform any desired preprocessing and - ## then re-check the "cutting" state - unless ($wantNonPods) { - $text = $self->preprocess_paragraph($text, $line_num); - return 1 unless ((defined $text) and (length $text)); - return 1 if ($myData{_CUTTING}); - } - - ## Look for one of the three types of paragraphs - my ($pfx, $cmd, $arg, $sep) = ('', '', '', ''); - my $pod_para = undef; - if ($text =~ /^(={1,2})(?=\S)/) { - ## Looks like a command paragraph. Capture the command prefix used - ## ("=" or "=="), as well as the command-name, its paragraph text, - ## and whatever sequence of characters was used to separate them - $pfx = $1; - $_ = substr($text, length $pfx); - ($cmd, $sep, $text) = split /(\s+)/, $_, 2; - $sep = '' unless defined $sep; - $text = '' unless defined $text; - ## If this is a "cut" directive then we don't need to do anything - ## except return to "cutting" mode. - if ($cmd eq 'cut') { - $myData{_CUTTING} = 1; - return unless $myOpts{'-process_cut_cmd'}; - } - } - ## Save the attributes indicating how the command was specified. - $pod_para = new Pod::Paragraph( - -name => $cmd, - -text => $text, - -prefix => $pfx, - -separator => $sep, - -file => $myData{_INFILE}, - -line => $line_num - ); - # ## Invoke appropriate callbacks - # if (exists $myData{_CALLBACKS}) { - # ## Look through the callback list, invoke callbacks, - # ## then see if we need to do the default actions - # ## (invoke_callbacks will return true if we do). - # return 1 unless $self->invoke_callbacks($cmd, $text, $line_num, $pod_para); - # } - - # If the last paragraph ended in whitespace, and we're not between verbatim blocks, carp - if ($myData{_WHITESPACE} and $myOpts{'-warnings'} - and not ($text =~ /^\s+/ and ($myData{_PREVIOUS}||"") eq "verbatim")) { - my $errorsub = $self->errorsub(); - my $line = $line_num - 1; - my $errmsg = "*** WARNING: line containing nothing but whitespace". - " in paragraph at line $line in file $myData{_INFILE}\n"; - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $self->$errorsub($errmsg) - or carp($errmsg); - } - - if (length $cmd) { - ## A command paragraph - $self->command($cmd, $text, $line_num, $pod_para); - $myData{_PREVIOUS} = $cmd; - } - elsif ($text =~ /^\s+/) { - ## Indented text - must be a verbatim paragraph - $self->verbatim($text, $line_num, $pod_para); - $myData{_PREVIOUS} = "verbatim"; - } - else { - ## Looks like an ordinary block of text - $self->textblock($text, $line_num, $pod_para); - $myData{_PREVIOUS} = "textblock"; - } - - # Update the whitespace for the next time around - #$myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\Z/m ? 1 : 0; - $myData{_WHITESPACE} = $text =~ /^[^\S\r\n]+\r*\Z/m ? 1 : 0; - - return 1; -} - -##--------------------------------------------------------------------------- - -=head1 B<parse_from_filehandle()> - - $parser->parse_from_filehandle($in_fh,$out_fh); - -This method takes an input filehandle (which is assumed to already be -opened for reading) and reads the entire input stream looking for blocks -(paragraphs) of POD documentation to be processed. If no first argument -is given the default input filehandle C<STDIN> is used. - -The C<$in_fh> parameter may be any object that provides a B<getline()> -method to retrieve a single line of input text (hence, an appropriate -wrapper object could be used to parse PODs from a single string or an -array of strings). - -Using C<$in_fh-E<gt>getline()>, input is read line-by-line and assembled -into paragraphs or "blocks" (which are separated by lines containing -nothing but whitespace). For each block of POD documentation -encountered it will invoke a method to parse the given paragraph. - -If a second argument is given then it should correspond to a filehandle where -output should be sent (otherwise the default output filehandle is -C<STDOUT> if no output filehandle is currently in use). - -B<NOTE:> For performance reasons, this method caches the input stream at -the top of the stack in a local variable. Any attempts by clients to -change the stack contents during processing when in the midst executing -of this method I<will not affect> the input stream used by the current -invocation of this method. - -This method does I<not> usually need to be overridden by subclasses. - -=cut - -sub parse_from_filehandle { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); - my ($in_fh, $out_fh) = @_; - $in_fh = \*STDIN unless ($in_fh); - local *myData = $self; ## alias to avoid deref-ing overhead - local *myOpts = ($myData{_PARSEOPTS} ||= {}); ## get parse-options - local $_; - - ## Put this stream at the top of the stack and do beginning-of-input - ## processing. NOTE that $in_fh might be reset during this process. - my $topstream = $self->_push_input_stream($in_fh, $out_fh); - (exists $opts{-cutting}) and $self->cutting( $opts{-cutting} ); - - ## Initialize line/paragraph - my ($textline, $paragraph) = ('', ''); - my ($nlines, $plines) = (0, 0); - - ## Use <$fh> instead of $fh->getline where possible (for speed) - $_ = ref $in_fh; - my $tied_fh = (/^(?:GLOB|FileHandle|IO::\w+)$/ or tied $in_fh); - - ## Read paragraphs line-by-line - while (defined ($textline = $tied_fh ? <$in_fh> : $in_fh->getline)) { - $textline = $self->preprocess_line($textline, ++$nlines); - next unless ((defined $textline) && (length $textline)); - - if ((! length $paragraph) && ($textline =~ /^==/)) { - ## '==' denotes a one-line command paragraph - $paragraph = $textline; - $plines = 1; - $textline = ''; - } else { - ## Append this line to the current paragraph - $paragraph .= $textline; - ++$plines; - } - - ## See if this line is blank and ends the current paragraph. - ## If it isn't, then keep iterating until it is. - next unless (($textline =~ /^[^\S\r\n]*[\r\n]*$/) - && (length $paragraph)); - - ## Now process the paragraph - parse_paragraph($self, $paragraph, ($nlines - $plines) + 1); - $paragraph = ''; - $plines = 0; - } - ## Don't forget about the last paragraph in the file - if (length $paragraph) { - parse_paragraph($self, $paragraph, ($nlines - $plines) + 1) - } - - ## Now pop the input stream off the top of the input stack. - $self->_pop_input_stream(); -} - -##--------------------------------------------------------------------------- - -=head1 B<parse_from_file()> - - $parser->parse_from_file($filename,$outfile); - -This method takes a filename and does the following: - -=over 2 - -=item * - -opens the input and output files for reading -(creating the appropriate filehandles) - -=item * - -invokes the B<parse_from_filehandle()> method passing it the -corresponding input and output filehandles. - -=item * - -closes the input and output files. - -=back - -If the special input filename "", "-" or "<&STDIN" is given then the STDIN -filehandle is used for input (and no open or close is performed). If no -input filename is specified then "-" is implied. Filehandle references, -or objects that support the regular IO operations (like C<E<lt>$fhE<gt>> -or C<$fh-<Egt>getline>) are also accepted; the handles must already be -opened. - -If a second argument is given then it should be the name of the desired -output file. If the special output filename "-" or ">&STDOUT" is given -then the STDOUT filehandle is used for output (and no open or close is -performed). If the special output filename ">&STDERR" is given then the -STDERR filehandle is used for output (and no open or close is -performed). If no output filehandle is currently in use and no output -filename is specified, then "-" is implied. -Alternatively, filehandle references or objects that support the regular -IO operations (like C<print>, e.g. L<IO::String>) are also accepted; -the object must already be opened. - -This method does I<not> usually need to be overridden by subclasses. - -=cut - -sub parse_from_file { - my $self = shift; - my %opts = (ref $_[0] eq 'HASH') ? %{ shift() } : (); - my ($infile, $outfile) = @_; - my ($in_fh, $out_fh); - if ($] < 5.006) { - ($in_fh, $out_fh) = (gensym(), gensym()); - } - my ($close_input, $close_output) = (0, 0); - local *myData = $self; - local *_; - - ## Is $infile a filename or a (possibly implied) filehandle - if (defined $infile && ref $infile) { - if (ref($infile) =~ /^(SCALAR|ARRAY|HASH|CODE|REF)$/) { - croak "Input from $1 reference not supported!\n"; - } - ## Must be a filehandle-ref (or else assume its a ref to an object - ## that supports the common IO read operations). - $myData{_INFILE} = ${$infile}; - $in_fh = $infile; - } - elsif (!defined($infile) || !length($infile) || ($infile eq '-') - || ($infile =~ /^<&(?:STDIN|0)$/i)) - { - ## Not a filename, just a string implying STDIN - $infile ||= '-'; - $myData{_INFILE} = '<standard input>'; - $in_fh = \*STDIN; - } - else { - ## We have a filename, open it for reading - $myData{_INFILE} = $infile; - open($in_fh, "< $infile") or - croak "Can't open $infile for reading: $!\n"; - $close_input = 1; - } - - ## NOTE: we need to be *very* careful when "defaulting" the output - ## file. We only want to use a default if this is the beginning of - ## the entire document (but *not* if this is an included file). We - ## determine this by seeing if the input stream stack has been set-up - ## already - - ## Is $outfile a filename, a (possibly implied) filehandle, maybe a ref? - if (ref $outfile) { - ## we need to check for ref() first, as other checks involve reading - if (ref($outfile) =~ /^(ARRAY|HASH|CODE)$/) { - croak "Output to $1 reference not supported!\n"; - } - elsif (ref($outfile) eq 'SCALAR') { -# # NOTE: IO::String isn't a part of the perl distribution, -# # so probably we shouldn't support this case... -# require IO::String; -# $myData{_OUTFILE} = "$outfile"; -# $out_fh = IO::String->new($outfile); - croak "Output to SCALAR reference not supported!\n"; - } - else { - ## Must be a filehandle-ref (or else assume its a ref to an - ## object that supports the common IO write operations). - $myData{_OUTFILE} = ${$outfile}; - $out_fh = $outfile; - } - } - elsif (!defined($outfile) || !length($outfile) || ($outfile eq '-') - || ($outfile =~ /^>&?(?:STDOUT|1)$/i)) - { - if (defined $myData{_TOP_STREAM}) { - $out_fh = $myData{_OUTPUT}; - } - else { - ## Not a filename, just a string implying STDOUT - $outfile ||= '-'; - $myData{_OUTFILE} = '<standard output>'; - $out_fh = \*STDOUT; - } - } - elsif ($outfile =~ /^>&(STDERR|2)$/i) { - ## Not a filename, just a string implying STDERR - $myData{_OUTFILE} = '<standard error>'; - $out_fh = \*STDERR; - } - else { - ## We have a filename, open it for writing - $myData{_OUTFILE} = $outfile; - (-d $outfile) and croak "$outfile is a directory, not POD input!\n"; - open($out_fh, "> $outfile") or - croak "Can't open $outfile for writing: $!\n"; - $close_output = 1; - } - - ## Whew! That was a lot of work to set up reasonably/robust behavior - ## in the case of a non-filename for reading and writing. Now we just - ## have to parse the input and close the handles when we're finished. - $self->parse_from_filehandle(\%opts, $in_fh, $out_fh); - - $close_input and - close($in_fh) || croak "Can't close $infile after reading: $!\n"; - $close_output and - close($out_fh) || croak "Can't close $outfile after writing: $!\n"; -} - -############################################################################# - -=head1 ACCESSOR METHODS - -Clients of B<Pod::Parser> should use the following methods to access -instance data fields: - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<errorsub()> - - $parser->errorsub("method_name"); - $parser->errorsub(\&warn_user); - $parser->errorsub(sub { print STDERR, @_ }); - -Specifies the method or subroutine to use when printing error messages -about POD syntax. The supplied method/subroutine I<must> return TRUE upon -successful printing of the message. If C<undef> is given, then the B<carp> -builtin is used to issue error messages (this is the default behavior). - - my $errorsub = $parser->errorsub() - my $errmsg = "This is an error message!\n" - (ref $errorsub) and &{$errorsub}($errmsg) - or (defined $errorsub) and $parser->$errorsub($errmsg) - or carp($errmsg); - -Returns a method name, or else a reference to the user-supplied subroutine -used to print error messages. Returns C<undef> if the B<carp> builtin -is used to issue error messages (this is the default behavior). - -=cut - -sub errorsub { - return (@_ > 1) ? ($_[0]->{_ERRORSUB} = $_[1]) : $_[0]->{_ERRORSUB}; -} - -##--------------------------------------------------------------------------- - -=head1 B<cutting()> - - $boolean = $parser->cutting(); - -Returns the current C<cutting> state: a boolean-valued scalar which -evaluates to true if text from the input file is currently being "cut" -(meaning it is I<not> considered part of the POD document). - - $parser->cutting($boolean); - -Sets the current C<cutting> state to the given value and returns the -result. - -=cut - -sub cutting { - return (@_ > 1) ? ($_[0]->{_CUTTING} = $_[1]) : $_[0]->{_CUTTING}; -} - -##--------------------------------------------------------------------------- - -##--------------------------------------------------------------------------- - -=head1 B<parseopts()> - -When invoked with no additional arguments, B<parseopts> returns a hashtable -of all the current parsing options. - - ## See if we are parsing non-POD sections as well as POD ones - my %opts = $parser->parseopts(); - $opts{'-want_nonPODs}' and print "-want_nonPODs\n"; - -When invoked using a single string, B<parseopts> treats the string as the -name of a parse-option and returns its corresponding value if it exists -(returns C<undef> if it doesn't). - - ## Did we ask to see '=cut' paragraphs? - my $want_cut = $parser->parseopts('-process_cut_cmd'); - $want_cut and print "-process_cut_cmd\n"; - -When invoked with multiple arguments, B<parseopts> treats them as -key/value pairs and the specified parse-option names are set to the -given values. Any unspecified parse-options are unaffected. - - ## Set them back to the default - $parser->parseopts(-warnings => 0); - -When passed a single hash-ref, B<parseopts> uses that hash to completely -reset the existing parse-options, all previous parse-option values -are lost. - - ## Reset all options to default - $parser->parseopts( { } ); - -See L<"PARSING OPTIONS"> for more information on the name and meaning of each -parse-option currently recognized. - -=cut - -sub parseopts { - local *myData = shift; - local *myOpts = ($myData{_PARSEOPTS} ||= {}); - return %myOpts if (@_ == 0); - if (@_ == 1) { - local $_ = shift; - return ref($_) ? $myData{_PARSEOPTS} = $_ : $myOpts{$_}; - } - my @newOpts = (%myOpts, @_); - $myData{_PARSEOPTS} = { @newOpts }; -} - -##--------------------------------------------------------------------------- - -=head1 B<output_file()> - - $fname = $parser->output_file(); - -Returns the name of the output file being written. - -=cut - -sub output_file { - return $_[0]->{_OUTFILE}; -} - -##--------------------------------------------------------------------------- - -=head1 B<output_handle()> - - $fhandle = $parser->output_handle(); - -Returns the output filehandle object. - -=cut - -sub output_handle { - return $_[0]->{_OUTPUT}; -} - -##--------------------------------------------------------------------------- - -=head1 B<input_file()> - - $fname = $parser->input_file(); - -Returns the name of the input file being read. - -=cut - -sub input_file { - return $_[0]->{_INFILE}; -} - -##--------------------------------------------------------------------------- - -=head1 B<input_handle()> - - $fhandle = $parser->input_handle(); - -Returns the current input filehandle object. - -=cut - -sub input_handle { - return $_[0]->{_INPUT}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<input_streams()> - - $listref = $parser->input_streams(); - -Returns a reference to an array which corresponds to the stack of all -the input streams that are currently in the middle of being parsed. - -While parsing an input stream, it is possible to invoke -B<parse_from_file()> or B<parse_from_filehandle()> to parse a new input -stream and then return to parsing the previous input stream. Each input -stream to be parsed is pushed onto the end of this input stack -before any of its input is read. The input stream that is currently -being parsed is always at the end (or top) of the input stack. When an -input stream has been exhausted, it is popped off the end of the -input stack. - -Each element on this input stack is a reference to C<Pod::InputSource> -object. Please see L<Pod::InputObjects> for more details. - -This method might be invoked when printing diagnostic messages, for example, -to obtain the name and line number of the all input files that are currently -being processed. - -=end __PRIVATE__ - -=cut - -sub input_streams { - return $_[0]->{_INPUT_STREAMS}; -} - -##--------------------------------------------------------------------------- - -=begin __PRIVATE__ - -=head1 B<top_stream()> - - $hashref = $parser->top_stream(); - -Returns a reference to the hash-table that represents the element -that is currently at the top (end) of the input stream stack -(see L<"input_streams()">). The return value will be the C<undef> -if the input stack is empty. - -This method might be used when printing diagnostic messages, for example, -to obtain the name and line number of the current input file. - -=end __PRIVATE__ - -=cut - -sub top_stream { - return $_[0]->{_TOP_STREAM} || undef; -} - -############################################################################# - -=head1 PRIVATE METHODS AND DATA - -B<Pod::Parser> makes use of several internal methods and data fields -which clients should not need to see or use. For the sake of avoiding -name collisions for client data and methods, these methods and fields -are briefly discussed here. Determined hackers may obtain further -information about them by reading the B<Pod::Parser> source code. - -Private data fields are stored in the hash-object whose reference is -returned by the B<new()> constructor for this class. The names of all -private methods and data-fields used by B<Pod::Parser> begin with a -prefix of "_" and match the regular expression C</^_\w+$/>. - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_push_input_stream()> - - $hashref = $parser->_push_input_stream($in_fh,$out_fh); - -This method will push the given input stream on the input stack and -perform any necessary beginning-of-document or beginning-of-file -processing. The argument C<$in_fh> is the input stream filehandle to -push, and C<$out_fh> is the corresponding output filehandle to use (if -it is not given or is undefined, then the current output stream is used, -which defaults to standard output if it doesnt exist yet). - -The value returned will be reference to the hash-table that represents -the new top of the input stream stack. I<Please Note> that it is -possible for this method to use default values for the input and output -file handles. If this happens, you will need to look at the C<INPUT> -and C<OUTPUT> instance data members to determine their new values. - -=end _PRIVATE_ - -=cut - -sub _push_input_stream { - my ($self, $in_fh, $out_fh) = @_; - local *myData = $self; - - ## Initialize stuff for the entire document if this is *not* - ## an included file. - ## - ## NOTE: we need to be *very* careful when "defaulting" the output - ## filehandle. We only want to use a default value if this is the - ## beginning of the entire document (but *not* if this is an included - ## file). - unless (defined $myData{_TOP_STREAM}) { - $out_fh = \*STDOUT unless (defined $out_fh); - $myData{_CUTTING} = 1; ## current "cutting" state - $myData{_INPUT_STREAMS} = []; ## stack of all input streams - } - - ## Initialize input indicators - $myData{_OUTFILE} = '(unknown)' unless (defined $myData{_OUTFILE}); - $myData{_OUTPUT} = $out_fh if (defined $out_fh); - $in_fh = \*STDIN unless (defined $in_fh); - $myData{_INFILE} = '(unknown)' unless (defined $myData{_INFILE}); - $myData{_INPUT} = $in_fh; - my $input_top = $myData{_TOP_STREAM} - = new Pod::InputSource( - -name => $myData{_INFILE}, - -handle => $in_fh, - -was_cutting => $myData{_CUTTING} - ); - local *input_stack = $myData{_INPUT_STREAMS}; - push(@input_stack, $input_top); - - ## Perform beginning-of-document and/or beginning-of-input processing - $self->begin_pod() if (@input_stack == 1); - $self->begin_input(); - - return $input_top; -} - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_pop_input_stream()> - - $hashref = $parser->_pop_input_stream(); - -This takes no arguments. It will perform any necessary end-of-file or -end-of-document processing and then pop the current input stream from -the top of the input stack. - -The value returned will be reference to the hash-table that represents -the new top of the input stream stack. - -=end _PRIVATE_ - -=cut - -sub _pop_input_stream { - my ($self) = @_; - local *myData = $self; - local *input_stack = $myData{_INPUT_STREAMS}; - - ## Perform end-of-input and/or end-of-document processing - $self->end_input() if (@input_stack > 0); - $self->end_pod() if (@input_stack == 1); - - ## Restore cutting state to whatever it was before we started - ## parsing this file. - my $old_top = pop(@input_stack); - $myData{_CUTTING} = $old_top->was_cutting(); - - ## Don't forget to reset the input indicators - my $input_top = undef; - if (@input_stack > 0) { - $input_top = $myData{_TOP_STREAM} = $input_stack[-1]; - $myData{_INFILE} = $input_top->name(); - $myData{_INPUT} = $input_top->handle(); - } else { - delete $myData{_TOP_STREAM}; - delete $myData{_INPUT_STREAMS}; - } - - return $input_top; -} - -############################################################################# - -=head1 TREE-BASED PARSING - -If straightforward stream-based parsing wont meet your needs (as is -likely the case for tasks such as translating PODs into structured -markup languages like HTML and XML) then you may need to take the -tree-based approach. Rather than doing everything in one pass and -calling the B<interpolate()> method to expand sequences into text, it -may be desirable to instead create a parse-tree using the B<parse_text()> -method to return a tree-like structure which may contain an ordered -list of children (each of which may be a text-string, or a similar -tree-like structure). - -Pay special attention to L<"METHODS FOR PARSING AND PROCESSING"> and -to the objects described in L<Pod::InputObjects>. The former describes -the gory details and parameters for how to customize and extend the -parsing behavior of B<Pod::Parser>. B<Pod::InputObjects> provides -several objects that may all be used interchangeably as parse-trees. The -most obvious one is the B<Pod::ParseTree> object. It defines the basic -interface and functionality that all things trying to be a POD parse-tree -should do. A B<Pod::ParseTree> is defined such that each "node" may be a -text-string, or a reference to another parse-tree. Each B<Pod::Paragraph> -object and each B<Pod::InteriorSequence> object also supports the basic -parse-tree interface. - -The B<parse_text()> method takes a given paragraph of text, and -returns a parse-tree that contains one or more children, each of which -may be a text-string, or an InteriorSequence object. There are also -callback-options that may be passed to B<parse_text()> to customize -the way it expands or transforms interior-sequences, as well as the -returned result. These callbacks can be used to create a parse-tree -with custom-made objects (which may or may not support the parse-tree -interface, depending on how you choose to do it). - -If you wish to turn an entire POD document into a parse-tree, that process -is fairly straightforward. The B<parse_text()> method is the key to doing -this successfully. Every paragraph-callback (i.e. the polymorphic methods -for B<command()>, B<verbatim()>, and B<textblock()> paragraphs) takes -a B<Pod::Paragraph> object as an argument. Each paragraph object has a -B<parse_tree()> method that can be used to get or set a corresponding -parse-tree. So for each of those paragraph-callback methods, simply call -B<parse_text()> with the options you desire, and then use the returned -parse-tree to assign to the given paragraph object. - -That gives you a parse-tree for each paragraph - so now all you need is -an ordered list of paragraphs. You can maintain that yourself as a data -element in the object/hash. The most straightforward way would be simply -to use an array-ref, with the desired set of custom "options" for each -invocation of B<parse_text>. Let's assume the desired option-set is -given by the hash C<%options>. Then we might do something like the -following: - - package MyPodParserTree; - - @ISA = qw( Pod::Parser ); - - ... - - sub begin_pod { - my $self = shift; - $self->{'-paragraphs'} = []; ## initialize paragraph list - } - - sub command { - my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({%options}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - sub verbatim { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - sub textblock { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({%options}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - push @{ $self->{'-paragraphs'} }, $pod_para; - } - - ... - - package main; - ... - my $parser = new MyPodParserTree(...); - $parser->parse_from_file(...); - my $paragraphs_ref = $parser->{'-paragraphs'}; - -Of course, in this module-author's humble opinion, I'd be more inclined to -use the existing B<Pod::ParseTree> object than a simple array. That way -everything in it, paragraphs and sequences, all respond to the same core -interface for all parse-tree nodes. The result would look something like: - - package MyPodParserTree2; - - ... - - sub begin_pod { - my $self = shift; - $self->{'-ptree'} = new Pod::ParseTree; ## initialize parse-tree - } - - sub parse_tree { - ## convenience method to get/set the parse-tree for the entire POD - (@_ > 1) and $_[0]->{'-ptree'} = $_[1]; - return $_[0]->{'-ptree'}; - } - - sub command { - my ($parser, $command, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - $parser->parse_tree()->append( $pod_para ); - } - - sub verbatim { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - $parser->parse_tree()->append( $pod_para ); - } - - sub textblock { - my ($parser, $paragraph, $line_num, $pod_para) = @_; - my $ptree = $parser->parse_text({<<options>>}, $paragraph, ...); - $pod_para->parse_tree( $ptree ); - $parser->parse_tree()->append( $pod_para ); - } - - ... - - package main; - ... - my $parser = new MyPodParserTree2(...); - $parser->parse_from_file(...); - my $ptree = $parser->parse_tree; - ... - -Now you have the entire POD document as one great big parse-tree. You -can even use the B<-expand_seq> option to B<parse_text> to insert -whole different kinds of objects. Just don't expect B<Pod::Parser> -to know what to do with them after that. That will need to be in your -code. Or, alternatively, you can insert any object you like so long as -it conforms to the B<Pod::ParseTree> interface. - -One could use this to create subclasses of B<Pod::Paragraphs> and -B<Pod::InteriorSequences> for specific commands (or to create your own -custom node-types in the parse-tree) and add some kind of B<emit()> -method to each custom node/subclass object in the tree. Then all you'd -need to do is recursively walk the tree in the desired order, processing -the children (most likely from left to right) by formatting them if -they are text-strings, or by calling their B<emit()> method if they -are objects/references. - -=head1 CAVEATS - -Please note that POD has the notion of "paragraphs": this is something -starting I<after> a blank (read: empty) line, with the single exception -of the file start, which is also starting a paragraph. That means that -especially a command (e.g. C<=head1>) I<must> be preceded with a blank -line; C<__END__> is I<not> a blank line. - -=head1 SEE ALSO - -L<Pod::InputObjects>, L<Pod::Select> - -B<Pod::InputObjects> defines POD input objects corresponding to -command paragraphs, parse-trees, and interior-sequences. - -B<Pod::Select> is a subclass of B<Pod::Parser> which provides the ability -to selectively include and/or exclude sections of a POD document from being -translated based upon the current heading, subheading, subsubheading, etc. - -=for __PRIVATE__ -B<Pod::Callbacks> is a subclass of B<Pod::Parser> which gives its users -the ability the employ I<callback functions> instead of, or in addition -to, overriding methods of the base class. - -=for __PRIVATE__ -B<Pod::Select> and B<Pod::Callbacks> do not override any -methods nor do they define any new methods with the same name. Because -of this, they may I<both> be used (in combination) as a base class of -the same subclass in order to combine their functionality without -causing any namespace clashes due to multiple inheritance. - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Brad Appleton E<lt>bradapp@enteract.comE<gt> - -Based on code for B<Pod::Text> written by -Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> - -=head1 LICENSE - -Pod-Parser is free software; you can redistribute it and/or modify it -under the terms of the Artistic License distributed with Perl version -5.000 or (at your option) any later version. Please refer to the -Artistic License that came with your Perl distribution for more -details. If your version of Perl was not distributed under the -terms of the Artistic License, than you may distribute PodParser -under the same terms as Perl itself. - -=cut - -1; -# vim: ts=4 sw=4 et diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm deleted file mode 100644 index 03252e93c71..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/PlainText.pm +++ /dev/null @@ -1,761 +0,0 @@ -# Pod::PlainText -- Convert POD data to formatted ASCII text. -# $Id: Text.pm,v 2.1 1999/09/20 11:53:33 eagle Exp $ -# -# Copyright 1999-2000 by Russ Allbery <rra@stanford.edu> -# -# This program is free software; you can redistribute it and/or modify it -# under the same terms as Perl itself. -# -# This module is intended to be a replacement for Pod::Text, and attempts to -# match its output except for some specific circumstances where other -# decisions seemed to produce better output. It uses Pod::Parser and is -# designed to be very easy to subclass. - -############################################################################ -# Modules and declarations -############################################################################ - -package Pod::PlainText; -use strict; - -require 5.005; - -use Carp qw(carp croak); -use Pod::Select (); - -use vars qw(@ISA %ESCAPES $VERSION); - -# We inherit from Pod::Select instead of Pod::Parser so that we can be used -# by Pod::Usage. -@ISA = qw(Pod::Select); - -$VERSION = '2.07'; - -BEGIN { - if ($] < 5.006) { - require Symbol; - import Symbol; - } -} - -############################################################################ -# Table of supported E<> escapes -############################################################################ - -# This table is taken near verbatim from Pod::PlainText in Pod::Parser, -# which got it near verbatim from the original Pod::Text. It is therefore -# credited to Tom Christiansen, and I'm glad I didn't have to write it. :) -%ESCAPES = ( - 'amp' => '&', # ampersand - 'lt' => '<', # left chevron, less-than - 'gt' => '>', # right chevron, greater-than - 'quot' => '"', # double quote - - "Aacute" => "\xC1", # capital A, acute accent - "aacute" => "\xE1", # small a, acute accent - "Acirc" => "\xC2", # capital A, circumflex accent - "acirc" => "\xE2", # small a, circumflex accent - "AElig" => "\xC6", # capital AE diphthong (ligature) - "aelig" => "\xE6", # small ae diphthong (ligature) - "Agrave" => "\xC0", # capital A, grave accent - "agrave" => "\xE0", # small a, grave accent - "Aring" => "\xC5", # capital A, ring - "aring" => "\xE5", # small a, ring - "Atilde" => "\xC3", # capital A, tilde - "atilde" => "\xE3", # small a, tilde - "Auml" => "\xC4", # capital A, dieresis or umlaut mark - "auml" => "\xE4", # small a, dieresis or umlaut mark - "Ccedil" => "\xC7", # capital C, cedilla - "ccedil" => "\xE7", # small c, cedilla - "Eacute" => "\xC9", # capital E, acute accent - "eacute" => "\xE9", # small e, acute accent - "Ecirc" => "\xCA", # capital E, circumflex accent - "ecirc" => "\xEA", # small e, circumflex accent - "Egrave" => "\xC8", # capital E, grave accent - "egrave" => "\xE8", # small e, grave accent - "ETH" => "\xD0", # capital Eth, Icelandic - "eth" => "\xF0", # small eth, Icelandic - "Euml" => "\xCB", # capital E, dieresis or umlaut mark - "euml" => "\xEB", # small e, dieresis or umlaut mark - "Iacute" => "\xCD", # capital I, acute accent - "iacute" => "\xED", # small i, acute accent - "Icirc" => "\xCE", # capital I, circumflex accent - "icirc" => "\xEE", # small i, circumflex accent - "Igrave" => "\xCD", # capital I, grave accent - "igrave" => "\xED", # small i, grave accent - "Iuml" => "\xCF", # capital I, dieresis or umlaut mark - "iuml" => "\xEF", # small i, dieresis or umlaut mark - "Ntilde" => "\xD1", # capital N, tilde - "ntilde" => "\xF1", # small n, tilde - "Oacute" => "\xD3", # capital O, acute accent - "oacute" => "\xF3", # small o, acute accent - "Ocirc" => "\xD4", # capital O, circumflex accent - "ocirc" => "\xF4", # small o, circumflex accent - "Ograve" => "\xD2", # capital O, grave accent - "ograve" => "\xF2", # small o, grave accent - "Oslash" => "\xD8", # capital O, slash - "oslash" => "\xF8", # small o, slash - "Otilde" => "\xD5", # capital O, tilde - "otilde" => "\xF5", # small o, tilde - "Ouml" => "\xD6", # capital O, dieresis or umlaut mark - "ouml" => "\xF6", # small o, dieresis or umlaut mark - "szlig" => "\xDF", # small sharp s, German (sz ligature) - "THORN" => "\xDE", # capital THORN, Icelandic - "thorn" => "\xFE", # small thorn, Icelandic - "Uacute" => "\xDA", # capital U, acute accent - "uacute" => "\xFA", # small u, acute accent - "Ucirc" => "\xDB", # capital U, circumflex accent - "ucirc" => "\xFB", # small u, circumflex accent - "Ugrave" => "\xD9", # capital U, grave accent - "ugrave" => "\xF9", # small u, grave accent - "Uuml" => "\xDC", # capital U, dieresis or umlaut mark - "uuml" => "\xFC", # small u, dieresis or umlaut mark - "Yacute" => "\xDD", # capital Y, acute accent - "yacute" => "\xFD", # small y, acute accent - "yuml" => "\xFF", # small y, dieresis or umlaut mark - - "lchevron" => "\xAB", # left chevron (double less than) - "rchevron" => "\xBB", # right chevron (double greater than) -); - - -############################################################################ -# Initialization -############################################################################ - -# Initialize the object. Must be sure to call our parent initializer. -sub initialize { - my $self = shift; - - $$self{alt} = 0 unless defined $$self{alt}; - $$self{indent} = 4 unless defined $$self{indent}; - $$self{loose} = 0 unless defined $$self{loose}; - $$self{sentence} = 0 unless defined $$self{sentence}; - $$self{width} = 76 unless defined $$self{width}; - - $$self{INDENTS} = []; # Stack of indentations. - $$self{MARGIN} = $$self{indent}; # Current left margin in spaces. - - return $self->SUPER::initialize; -} - -# pod2text and pod2man re-use the same parser on a list of files, -# and will lose some information if some intermediate documents produce -# unbalanced calls to begin_cmd/end_cmd. -# via r1.4 of OpenBSD src/gnu/usr.bin/perl/lib/Pod/PlainText.pm -sub begin_pod { - my $self = shift; - - $$self{VERBATIM} = 0; - $$self{EXCLUDE} = 0; - - return $self->SUPER::begin_pod(@_); -} - - -############################################################################ -# Core overrides -############################################################################ - -# Called for each command paragraph. Gets the command, the associated -# paragraph, the line number, and a Pod::Paragraph object. Just dispatches -# the command to a method named the same as the command. =cut is handled -# internally by Pod::Parser. -sub command { - my $self = shift; - my $command = shift; - return if $command eq 'pod'; - return if ($$self{EXCLUDE} && $command ne 'end'); - if (defined $$self{ITEM}) { - $self->item ("\n"); - local $_ = "\n"; - $self->output($_) if($command eq 'back'); - } - $command = 'cmd_' . $command; - return $self->$command (@_); -} - -# Called for a verbatim paragraph. Gets the paragraph, the line number, and -# a Pod::Paragraph object. Just output it verbatim, but with tabs converted -# to spaces. -sub verbatim { - my $self = shift; - return if $$self{EXCLUDE}; - $self->item if defined $$self{ITEM}; - local $_ = shift; - return if /^\s*$/; - s/^(\s*\S+)/(' ' x $$self{MARGIN}) . $1/gme; - return $self->output($_); -} - -# Called for a regular text block. Gets the paragraph, the line number, and -# a Pod::Paragraph object. Perform interpolation and output the results. -sub textblock { - my $self = shift; - return if $$self{EXCLUDE}; - if($$self{VERBATIM}) { - $self->output($_[0]); - return; - } - local $_ = shift; - my $line = shift; - - # Perform a little magic to collapse multiple L<> references. This is - # here mostly for backwards-compatibility. We'll just rewrite the whole - # thing into actual text at this part, bypassing the whole internal - # sequence parsing thing. - s{ - ( - L< # A link of the form L</something>. - / - ( - [:\w]+ # The item has to be a simple word... - (\(\))? # ...or simple function. - ) - > - ( - ,?\s+(and\s+)? # Allow lots of them, conjuncted. - L< - / - ( - [:\w]+ - (\(\))? - ) - > - )+ - ) - } { - local $_ = $1; - s%L</([^>]+)>%$1%g; - my @items = split /(?:,?\s+(?:and\s+)?)/; - my $string = "the "; - my $i; - for ($i = 0; $i < @items; $i++) { - $string .= $items[$i]; - $string .= ", " if @items > 2 && $i != $#items; - $string .= " and " if ($i == $#items - 1); - } - $string .= " entries elsewhere in this document"; - $string; - }gex; - - # Now actually interpolate and output the paragraph. - $_ = $self->interpolate ($_, $line); - s/\s*$/\n/s; - if (defined $$self{ITEM}) { - $self->item ($_ . "\n"); - } else { - $self->output ($self->reformat ($_ . "\n")); - } -} - -# Called for an interior sequence. Gets the command, argument, and a -# Pod::InteriorSequence object and is expected to return the resulting text. -# Calls code, bold, italic, file, and link to handle those types of -# sequences, and handles S<>, E<>, X<>, and Z<> directly. -sub interior_sequence { - my $self = shift; - my $command = shift; - local $_ = shift; - return '' if ($command eq 'X' || $command eq 'Z'); - - # Expand escapes into the actual character now, carping if invalid. - if ($command eq 'E') { - return $ESCAPES{$_} if defined $ESCAPES{$_}; - carp "Unknown escape: E<$_>"; - return "E<$_>"; - } - - # For all the other sequences, empty content produces no output. - return if $_ eq ''; - - # For S<>, compress all internal whitespace and then map spaces to \01. - # When we output the text, we'll map this back. - if ($command eq 'S') { - s/\s{2,}/ /g; - tr/ /\01/; - return $_; - } - - # Anything else needs to get dispatched to another method. - if ($command eq 'B') { return $self->seq_b ($_) } - elsif ($command eq 'C') { return $self->seq_c ($_) } - elsif ($command eq 'F') { return $self->seq_f ($_) } - elsif ($command eq 'I') { return $self->seq_i ($_) } - elsif ($command eq 'L') { return $self->seq_l ($_) } - else { carp "Unknown sequence $command<$_>" } -} - -# Called for each paragraph that's actually part of the POD. We take -# advantage of this opportunity to untabify the input. -sub preprocess_paragraph { - my $self = shift; - local $_ = shift; - 1 while s/^(.*?)(\t+)/$1 . ' ' x (length ($2) * 8 - length ($1) % 8)/me; - return $_; -} - - -############################################################################ -# Command paragraphs -############################################################################ - -# All command paragraphs take the paragraph and the line number. - -# First level heading. -sub cmd_head1 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n==== $_ ====\n\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output ($_ . "\n"); - } -} - -# Second level heading. -sub cmd_head2 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n== $_ ==\n\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output (' ' x ($$self{indent} / 2) . $_ . "\n"); - } -} - -# third level heading - not strictly perlpodspec compliant -sub cmd_head3 { - my $self = shift; - local $_ = shift; - s/\s+$//s; - $_ = $self->interpolate ($_, shift); - if ($$self{alt}) { - $self->output ("\n= $_ =\n"); - } else { - $_ .= "\n" if $$self{loose}; - $self->output (' ' x ($$self{indent}) . $_ . "\n"); - } -} - -# fourth level heading - not strictly perlpodspec compliant -# just like head3 -*cmd_head4 = \&cmd_head3; - -# Start a list. -sub cmd_over { - my $self = shift; - local $_ = shift; - unless (/^[-+]?\d+\s+$/) { $_ = $$self{indent} } - push (@{ $$self{INDENTS} }, $$self{MARGIN}); - $$self{MARGIN} += ($_ + 0); -} - -# End a list. -sub cmd_back { - my $self = shift; - $$self{MARGIN} = pop @{ $$self{INDENTS} }; - unless (defined $$self{MARGIN}) { - carp 'Unmatched =back'; - $$self{MARGIN} = $$self{indent}; - } -} - -# An individual list item. -sub cmd_item { - my $self = shift; - if (defined $$self{ITEM}) { $self->item } - local $_ = shift; - s/\s+$//s; - $$self{ITEM} = $self->interpolate ($_); -} - -# Begin a block for a particular translator. Setting VERBATIM triggers -# special handling in textblock(). -sub cmd_begin { - my $self = shift; - local $_ = shift; - my ($kind) = /^(\S+)/ or return; - if ($kind eq 'text') { - $$self{VERBATIM} = 1; - } else { - $$self{EXCLUDE} = 1; - } -} - -# End a block for a particular translator. We assume that all =begin/=end -# pairs are properly closed. -sub cmd_end { - my $self = shift; - $$self{EXCLUDE} = 0; - $$self{VERBATIM} = 0; -} - -# One paragraph for a particular translator. Ignore it unless it's intended -# for text, in which case we treat it as a verbatim text block. -sub cmd_for { - my $self = shift; - local $_ = shift; - my $line = shift; - return unless s/^text\b[ \t]*\r?\n?//; - $self->verbatim ($_, $line); -} - -# just a dummy method for the time being -sub cmd_encoding { - return; -} - -############################################################################ -# Interior sequences -############################################################################ - -# The simple formatting ones. These are here mostly so that subclasses can -# override them and do more complicated things. -sub seq_b { return $_[0]{alt} ? "``$_[1]''" : $_[1] } -sub seq_c { return $_[0]{alt} ? "``$_[1]''" : "`$_[1]'" } -sub seq_f { return $_[0]{alt} ? "\"$_[1]\"" : $_[1] } -sub seq_i { return '*' . $_[1] . '*' } - -# The complicated one. Handle links. Since this is plain text, we can't -# actually make any real links, so this is all to figure out what text we -# print out. -sub seq_l { - my $self = shift; - local $_ = shift; - - # Smash whitespace in case we were split across multiple lines. - s/\s+/ /g; - - # If we were given any explicit text, just output it. - if (/^([^|]+)\|/) { return $1 } - - # Okay, leading and trailing whitespace isn't important; get rid of it. - s/^\s+//; - s/\s+$//; - - # Default to using the whole content of the link entry as a section - # name. Note that L<manpage/> forces a manpage interpretation, as does - # something looking like L<manpage(section)>. The latter is an - # enhancement over the original Pod::Text. - my ($manpage, $section) = ('', $_); - if (/^(?:https?|ftp|news):/) { - # a URL - return $_; - } elsif (/^"\s*(.*?)\s*"$/) { - $section = '"' . $1 . '"'; - } elsif (m/^[-:.\w]+(?:\(\S+\))?$/) { - ($manpage, $section) = ($_, ''); - } elsif (m{/}) { - ($manpage, $section) = split (/\s*\/\s*/, $_, 2); - } - - my $text = ''; - # Now build the actual output text. - if (!length $section) { - $text = "the $manpage manpage" if length $manpage; - } elsif ($section =~ /^[:\w]+(?:\(\))?/) { - $text .= 'the ' . $section . ' entry'; - $text .= (length $manpage) ? " in the $manpage manpage" - : ' elsewhere in this document'; - } else { - $section =~ s/^\"\s*//; - $section =~ s/\s*\"$//; - $text .= 'the section on "' . $section . '"'; - $text .= " in the $manpage manpage" if length $manpage; - } - return $text; -} - - -############################################################################ -# List handling -############################################################################ - -# This method is called whenever an =item command is complete (in other -# words, we've seen its associated paragraph or know for certain that it -# doesn't have one). It gets the paragraph associated with the item as an -# argument. If that argument is empty, just output the item tag; if it -# contains a newline, output the item tag followed by the newline. -# Otherwise, see if there's enough room for us to output the item tag in the -# margin of the text or if we have to put it on a separate line. -sub item { - my $self = shift; - local $_ = shift; - my $tag = $$self{ITEM}; - unless (defined $tag) { - carp 'item called without tag'; - return; - } - undef $$self{ITEM}; - my $indent = $$self{INDENTS}[-1]; - unless (defined $indent) { $indent = $$self{indent} } - my $space = ' ' x $indent; - $space =~ s/^ /:/ if $$self{alt}; - if (!$_ || /^\s+$/ || ($$self{MARGIN} - $indent < length ($tag) + 1)) { - my $margin = $$self{MARGIN}; - $$self{MARGIN} = $indent; - my $output = $self->reformat ($tag); - $output =~ s/[\r\n]*$/\n/; - $self->output ($output); - $$self{MARGIN} = $margin; - $self->output ($self->reformat ($_)) if /\S/; - } else { - $_ = $self->reformat ($_); - s/^ /:/ if ($$self{alt} && $indent > 0); - my $tagspace = ' ' x length $tag; - s/^($space)$tagspace/$1$tag/ or carp 'Bizarre space in item'; - $self->output ($_); - } -} - - -############################################################################ -# Output formatting -############################################################################ - -# Wrap a line, indenting by the current left margin. We can't use -# Text::Wrap because it plays games with tabs. We can't use formline, even -# though we'd really like to, because it screws up non-printing characters. -# So we have to do the wrapping ourselves. -sub wrap { - my $self = shift; - local $_ = shift; - my $output = ''; - my $spaces = ' ' x $$self{MARGIN}; - my $width = $$self{width} - $$self{MARGIN}; - while (length > $width) { - if (s/^([^\r\n]{0,$width})\s+// || s/^([^\r\n]{$width})//) { - $output .= $spaces . $1 . "\n"; - } else { - last; - } - } - $output .= $spaces . $_; - $output =~ s/\s+$/\n\n/; - return $output; -} - -# Reformat a paragraph of text for the current margin. Takes the text to -# reformat and returns the formatted text. -sub reformat { - my $self = shift; - local $_ = shift; - - # If we're trying to preserve two spaces after sentences, do some - # munging to support that. Otherwise, smash all repeated whitespace. - if ($$self{sentence}) { - s/ +$//mg; - s/\.\r?\n/. \n/g; - s/[\r\n]+/ /g; - s/ +/ /g; - } else { - s/\s+/ /g; - } - return $self->wrap($_); -} - -# Output text to the output device. -sub output { $_[1] =~ tr/\01/ /; print { $_[0]->output_handle } $_[1] } - - -############################################################################ -# Backwards compatibility -############################################################################ - -# The old Pod::Text module did everything in a pod2text() function. This -# tries to provide the same interface for legacy applications. -sub pod2text { - my @args; - - # This is really ugly; I hate doing option parsing in the middle of a - # module. But the old Pod::Text module supported passing flags to its - # entry function, so handle -a and -<number>. - while ($_[0] =~ /^-/) { - my $flag = shift; - if ($flag eq '-a') { push (@args, alt => 1) } - elsif ($flag =~ /^-(\d+)$/) { push (@args, width => $1) } - else { - unshift (@_, $flag); - last; - } - } - - # Now that we know what arguments we're using, create the parser. - my $parser = Pod::PlainText->new (@args); - - # If two arguments were given, the second argument is going to be a file - # handle. That means we want to call parse_from_filehandle(), which - # means we need to turn the first argument into a file handle. Magic - # open will handle the <&STDIN case automagically. - if (defined $_[1]) { - my $infh; - if ($] < 5.006) { - $infh = gensym(); - } - unless (open ($infh, $_[0])) { - croak ("Can't open $_[0] for reading: $!\n"); - } - $_[0] = $infh; - return $parser->parse_from_filehandle (@_); - } else { - return $parser->parse_from_file (@_); - } -} - - -############################################################################ -# Module return value and documentation -############################################################################ - -1; -__END__ - -=head1 NAME - -Pod::PlainText - Convert POD data to formatted ASCII text - -=head1 SYNOPSIS - - use Pod::PlainText; - my $parser = Pod::PlainText->new (sentence => 0, width => 78); - - # Read POD from STDIN and write to STDOUT. - $parser->parse_from_filehandle; - - # Read POD from file.pod and write to file.txt. - $parser->parse_from_file ('file.pod', 'file.txt'); - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -Pod::PlainText is a module that can convert documentation in the POD format (the -preferred language for documenting Perl) into formatted ASCII. It uses no -special formatting controls or codes whatsoever, and its output is therefore -suitable for nearly any device. - -As a derived class from Pod::Parser, Pod::PlainText supports the same methods and -interfaces. See L<Pod::Parser> for all the details; briefly, one creates a -new parser with C<Pod::PlainText-E<gt>new()> and then calls either -parse_from_filehandle() or parse_from_file(). - -new() can take options, in the form of key/value pairs, that control the -behavior of the parser. The currently recognized options are: - -=over 4 - -=item alt - -If set to a true value, selects an alternate output format that, among other -things, uses a different heading style and marks C<=item> entries with a -colon in the left margin. Defaults to false. - -=item indent - -The number of spaces to indent regular text, and the default indentation for -C<=over> blocks. Defaults to 4. - -=item loose - -If set to a true value, a blank line is printed after a C<=headN> headings. -If set to false (the default), no blank line is printed after C<=headN>. -This is the default because it's the expected formatting for manual pages; -if you're formatting arbitrary text documents, setting this to true may -result in more pleasing output. - -=item sentence - -If set to a true value, Pod::PlainText will assume that each sentence ends in two -spaces, and will try to preserve that spacing. If set to false, all -consecutive whitespace in non-verbatim paragraphs is compressed into a -single space. Defaults to true. - -=item width - -The column at which to wrap text on the right-hand side. Defaults to 76. - -=back - -The standard Pod::Parser method parse_from_filehandle() takes up to two -arguments, the first being the file handle to read POD from and the second -being the file handle to write the formatted output to. The first defaults -to STDIN if not given, and the second defaults to STDOUT. The method -parse_from_file() is almost identical, except that its two arguments are the -input and output disk files instead. See L<Pod::Parser> for the specific -details. - -=head1 DIAGNOSTICS - -=over 4 - -=item Bizarre space in item - -(W) Something has gone wrong in internal C<=item> processing. This message -indicates a bug in Pod::PlainText; you should never see it. - -=item Can't open %s for reading: %s - -(F) Pod::PlainText was invoked via the compatibility mode pod2text() interface -and the input file it was given could not be opened. - -=item Unknown escape: %s - -(W) The POD source contained an C<EE<lt>E<gt>> escape that Pod::PlainText didn't -know about. - -=item Unknown sequence: %s - -(W) The POD source contained a non-standard internal sequence (something of -the form C<XE<lt>E<gt>>) that Pod::PlainText didn't know about. - -=item Unmatched =back - -(W) Pod::PlainText encountered a C<=back> command that didn't correspond to an -C<=over> command. - -=back - -=head1 RESTRICTIONS - -Embedded Ctrl-As (octal 001) in the input will be mapped to spaces on -output, due to an internal implementation detail. - -=head1 NOTES - -This is a replacement for an earlier Pod::Text module written by Tom -Christiansen. It has a revamped interface, since it now uses Pod::Parser, -but an interface roughly compatible with the old Pod::Text::pod2text() -function is still available. Please change to the new calling convention, -though. - -The original Pod::Text contained code to do formatting via termcap -sequences, although it wasn't turned on by default and it was problematic to -get it to work at all. This rewrite doesn't even try to do that, but a -subclass of it does. Look for L<Pod::Text::Termcap|Pod::Text::Termcap>. - -=head1 SEE ALSO - -B<Pod::PlainText> is part of the L<Pod::Parser> distribution. - -L<Pod::Parser|Pod::Parser>, L<Pod::Text::Termcap|Pod::Text::Termcap>, -pod2text(1) - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Russ Allbery E<lt>rra@stanford.eduE<gt>, based I<very> heavily on the -original Pod::Text by Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> and -its conversion to Pod::Parser by Brad Appleton -E<lt>bradapp@enteract.comE<gt>. - -=cut diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Select.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Select.pm deleted file mode 100644 index 70267e94ec0..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/lib/Pod/Select.pm +++ /dev/null @@ -1,756 +0,0 @@ -############################################################################# -# Pod/Select.pm -- function to select portions of POD docs -# -# Copyright (C) 1996-2000 by Bradford Appleton. All rights reserved. -# This file is part of "PodParser". PodParser is free software; -# you can redistribute it and/or modify it under the same terms -# as Perl itself. -############################################################################# - -package Pod::Select; -use strict; - -use vars qw($VERSION @ISA @EXPORT $MAX_HEADING_LEVEL %myData @section_headings @selected_sections); -$VERSION = '1.63'; ## Current version of this package -require 5.005; ## requires this Perl version or later - -############################################################################# - -=head1 NAME - -Pod::Select, podselect() - extract selected sections of POD from input - -=head1 SYNOPSIS - - use Pod::Select; - - ## Select all the POD sections for each file in @filelist - ## and print the result on standard output. - podselect(@filelist); - - ## Same as above, but write to tmp.out - podselect({-output => "tmp.out"}, @filelist): - - ## Select from the given filelist, only those POD sections that are - ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. - podselect({-sections => ["NAME|SYNOPSIS", "OPTIONS"]}, @filelist): - - ## Select the "DESCRIPTION" section of the PODs from STDIN and write - ## the result to STDERR. - podselect({-output => ">&STDERR", -sections => ["DESCRIPTION"]}, \*STDIN); - -or - - use Pod::Select; - - ## Create a parser object for selecting POD sections from the input - $parser = new Pod::Select(); - - ## Select all the POD sections for each file in @filelist - ## and print the result to tmp.out. - $parser->parse_from_file("<&STDIN", "tmp.out"); - - ## Select from the given filelist, only those POD sections that are - ## within a 1st level section named any of: NAME, SYNOPSIS, OPTIONS. - $parser->select("NAME|SYNOPSIS", "OPTIONS"); - for (@filelist) { $parser->parse_from_file($_); } - - ## Select the "DESCRIPTION" and "SEE ALSO" sections of the PODs from - ## STDIN and write the result to STDERR. - $parser->select("DESCRIPTION"); - $parser->add_selection("SEE ALSO"); - $parser->parse_from_filehandle(\*STDIN, \*STDERR); - -=head1 REQUIRES - -perl5.005, Pod::Parser, Exporter, Carp - -=head1 EXPORTS - -podselect() - -=head1 DESCRIPTION - -B<NOTE: This module is considered legacy; modern Perl releases (5.18 and -higher) are going to remove Pod-Parser from core and use L<Pod-Simple> -for all things POD.> - -B<podselect()> is a function which will extract specified sections of -pod documentation from an input stream. This ability is provided by the -B<Pod::Select> module which is a subclass of B<Pod::Parser>. -B<Pod::Select> provides a method named B<select()> to specify the set of -POD sections to select for processing/printing. B<podselect()> merely -creates a B<Pod::Select> object and then invokes the B<podselect()> -followed by B<parse_from_file()>. - -=head1 SECTION SPECIFICATIONS - -B<podselect()> and B<Pod::Select::select()> may be given one or more -"section specifications" to restrict the text processed to only the -desired set of sections and their corresponding subsections. A section -specification is a string containing one or more Perl-style regular -expressions separated by forward slashes ("/"). If you need to use a -forward slash literally within a section title you can escape it with a -backslash ("\/"). - -The formal syntax of a section specification is: - -=over 4 - -=item * - -I<head1-title-regex>/I<head2-title-regex>/... - -=back - -Any omitted or empty regular expressions will default to ".*". -Please note that each regular expression given is implicitly -anchored by adding "^" and "$" to the beginning and end. Also, if a -given regular expression starts with a "!" character, then the -expression is I<negated> (so C<!foo> would match anything I<except> -C<foo>). - -Some example section specifications follow. - -=over 4 - -=item * - -Match the C<NAME> and C<SYNOPSIS> sections and all of their subsections: - -C<NAME|SYNOPSIS> - -=item * - -Match only the C<Question> and C<Answer> subsections of the C<DESCRIPTION> -section: - -C<DESCRIPTION/Question|Answer> - -=item * - -Match the C<Comments> subsection of I<all> sections: - -C</Comments> - -=item * - -Match all subsections of C<DESCRIPTION> I<except> for C<Comments>: - -C<DESCRIPTION/!Comments> - -=item * - -Match the C<DESCRIPTION> section but do I<not> match any of its subsections: - -C<DESCRIPTION/!.+> - -=item * - -Match all top level sections but none of their subsections: - -C</!.+> - -=back - -=begin _NOT_IMPLEMENTED_ - -=head1 RANGE SPECIFICATIONS - -B<podselect()> and B<Pod::Select::select()> may be given one or more -"range specifications" to restrict the text processed to only the -desired ranges of paragraphs in the desired set of sections. A range -specification is a string containing a single Perl-style regular -expression (a regex), or else two Perl-style regular expressions -(regexs) separated by a ".." (Perl's "range" operator is ".."). -The regexs in a range specification are delimited by forward slashes -("/"). If you need to use a forward slash literally within a regex you -can escape it with a backslash ("\/"). - -The formal syntax of a range specification is: - -=over 4 - -=item * - -/I<start-range-regex>/[../I<end-range-regex>/] - -=back - -Where each the item inside square brackets (the ".." followed by the -end-range-regex) is optional. Each "range-regex" is of the form: - - =cmd-expr text-expr - -Where I<cmd-expr> is intended to match the name of one or more POD -commands, and I<text-expr> is intended to match the paragraph text for -the command. If a range-regex is supposed to match a POD command, then -the first character of the regex (the one after the initial '/') -absolutely I<must> be a single '=' character; it may not be anything -else (not even a regex meta-character) if it is supposed to match -against the name of a POD command. - -If no I<=cmd-expr> is given then the text-expr will be matched against -plain textblocks unless it is preceded by a space, in which case it is -matched against verbatim text-blocks. If no I<text-expr> is given then -only the command-portion of the paragraph is matched against. - -Note that these two expressions are each implicitly anchored. This -means that when matching against the command-name, there will be an -implicit '^' and '$' around the given I<=cmd-expr>; and when matching -against the paragraph text there will be an implicit '\A' and '\Z' -around the given I<text-expr>. - -Unlike with section-specs, the '!' character does I<not> have any special -meaning (negation or otherwise) at the beginning of a range-spec! - -Some example range specifications follow. - -=over 4 - -=item -Match all C<=for html> paragraphs: - -C</=for html/> - -=item -Match all paragraphs between C<=begin html> and C<=end html> -(note that this will I<not> work correctly if such sections -are nested): - -C</=begin html/../=end html/> - -=item -Match all paragraphs between the given C<=item> name until the end of the -current section: - -C</=item mine/../=head\d/> - -=item -Match all paragraphs between the given C<=item> until the next item, or -until the end of the itemized list (note that this will I<not> work as -desired if the item contains an itemized list nested within it): - -C</=item mine/../=(item|back)/> - -=back - -=end _NOT_IMPLEMENTED_ - -=cut - -############################################################################# - -#use diagnostics; -use Carp; -use Pod::Parser 1.04; - -@ISA = qw(Pod::Parser); -@EXPORT = qw(&podselect); - -## Maximum number of heading levels supported for '=headN' directives -*MAX_HEADING_LEVEL = \3; - -############################################################################# - -=head1 OBJECT METHODS - -The following methods are provided in this module. Each one takes a -reference to the object itself as an implicit first parameter. - -=cut - -##--------------------------------------------------------------------------- - -## =begin _PRIVATE_ -## -## =head1 B<_init_headings()> -## -## Initialize the current set of active section headings. -## -## =cut -## -## =end _PRIVATE_ - -sub _init_headings { - my $self = shift; - local *myData = $self; - - ## Initialize current section heading titles if necessary - unless (defined $myData{_SECTION_HEADINGS}) { - local *section_headings = $myData{_SECTION_HEADINGS} = []; - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $section_headings[$i] = ''; - } - } -} - -##--------------------------------------------------------------------------- - -=head1 B<curr_headings()> - - ($head1, $head2, $head3, ...) = $parser->curr_headings(); - $head1 = $parser->curr_headings(1); - -This method returns a list of the currently active section headings and -subheadings in the document being parsed. The list of headings returned -corresponds to the most recently parsed paragraph of the input. - -If an argument is given, it must correspond to the desired section -heading number, in which case only the specified section heading is -returned. If there is no current section heading at the specified -level, then C<undef> is returned. - -=cut - -sub curr_headings { - my $self = shift; - $self->_init_headings() unless (defined $self->{_SECTION_HEADINGS}); - my @headings = @{ $self->{_SECTION_HEADINGS} }; - return (@_ > 0 and $_[0] =~ /^\d+$/) ? $headings[$_[0] - 1] : @headings; -} - -##--------------------------------------------------------------------------- - -=head1 B<select()> - - $parser->select($section_spec1,$section_spec2,...); - -This method is used to select the particular sections and subsections of -POD documentation that are to be printed and/or processed. The existing -set of selected sections is I<replaced> with the given set of sections. -See B<add_selection()> for adding to the current set of selected -sections. - -Each of the C<$section_spec> arguments should be a section specification -as described in L<"SECTION SPECIFICATIONS">. The section specifications -are parsed by this method and the resulting regular expressions are -stored in the invoking object. - -If no C<$section_spec> arguments are given, then the existing set of -selected sections is cleared out (which means C<all> sections will be -processed). - -This method should I<not> normally be overridden by subclasses. - -=cut - -sub select { - my ($self, @sections) = @_; - local *myData = $self; - local $_; - -### NEED TO DISCERN A SECTION-SPEC FROM A RANGE-SPEC (look for m{^/.+/$}?) - - ##--------------------------------------------------------------------- - ## The following is a blatant hack for backward compatibility, and for - ## implementing add_selection(). If the *first* *argument* is the - ## string "+", then the remaining section specifications are *added* - ## to the current set of selections; otherwise the given section - ## specifications will *replace* the current set of selections. - ## - ## This should probably be fixed someday, but for the present time, - ## it seems incredibly unlikely that "+" would ever correspond to - ## a legitimate section heading - ##--------------------------------------------------------------------- - my $add = ($sections[0] eq '+') ? shift(@sections) : ''; - - ## Reset the set of sections to use - unless (@sections) { - delete $myData{_SELECTED_SECTIONS} unless ($add); - return; - } - $myData{_SELECTED_SECTIONS} = [] - unless ($add && exists $myData{_SELECTED_SECTIONS}); - local *selected_sections = $myData{_SELECTED_SECTIONS}; - - ## Compile each spec - for my $spec (@sections) { - if ( defined($_ = _compile_section_spec($spec)) ) { - ## Store them in our sections array - push(@selected_sections, $_); - } - else { - carp qq{Ignoring section spec "$spec"!\n}; - } - } -} - -##--------------------------------------------------------------------------- - -=head1 B<add_selection()> - - $parser->add_selection($section_spec1,$section_spec2,...); - -This method is used to add to the currently selected sections and -subsections of POD documentation that are to be printed and/or -processed. See <select()> for replacing the currently selected sections. - -Each of the C<$section_spec> arguments should be a section specification -as described in L<"SECTION SPECIFICATIONS">. The section specifications -are parsed by this method and the resulting regular expressions are -stored in the invoking object. - -This method should I<not> normally be overridden by subclasses. - -=cut - -sub add_selection { - my $self = shift; - return $self->select('+', @_); -} - -##--------------------------------------------------------------------------- - -=head1 B<clear_selections()> - - $parser->clear_selections(); - -This method takes no arguments, it has the exact same effect as invoking -<select()> with no arguments. - -=cut - -sub clear_selections { - my $self = shift; - return $self->select(); -} - -##--------------------------------------------------------------------------- - -=head1 B<match_section()> - - $boolean = $parser->match_section($heading1,$heading2,...); - -Returns a value of true if the given section and subsection heading -titles match any of the currently selected section specifications in -effect from prior calls to B<select()> and B<add_selection()> (or if -there are no explicitly selected/deselected sections). - -The arguments C<$heading1>, C<$heading2>, etc. are the heading titles of -the corresponding sections, subsections, etc. to try and match. If -C<$headingN> is omitted then it defaults to the current corresponding -section heading title in the input. - -This method should I<not> normally be overridden by subclasses. - -=cut - -sub match_section { - my $self = shift; - my (@headings) = @_; - local *myData = $self; - - ## Return true if no restrictions were explicitly specified - my $selections = (exists $myData{_SELECTED_SECTIONS}) - ? $myData{_SELECTED_SECTIONS} : undef; - return 1 unless ((defined $selections) && @{$selections}); - - ## Default any unspecified sections to the current one - my @current_headings = $self->curr_headings(); - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - (defined $headings[$i]) or $headings[$i] = $current_headings[$i]; - } - - ## Look for a match against the specified section expressions - for my $section_spec ( @{$selections} ) { - ##------------------------------------------------------ - ## Each portion of this spec must match in order for - ## the spec to be matched. So we will start with a - ## match-value of 'true' and logically 'and' it with - ## the results of matching a given element of the spec. - ##------------------------------------------------------ - my $match = 1; - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - my $regex = $section_spec->[$i]; - my $negated = ($regex =~ s/^\!//); - $match &= ($negated ? ($headings[$i] !~ /${regex}/) - : ($headings[$i] =~ /${regex}/)); - last unless ($match); - } - return 1 if ($match); - } - return 0; ## no match -} - -##--------------------------------------------------------------------------- - -=head1 B<is_selected()> - - $boolean = $parser->is_selected($paragraph); - -This method is used to determine if the block of text given in -C<$paragraph> falls within the currently selected set of POD sections -and subsections to be printed or processed. This method is also -responsible for keeping track of the current input section and -subsections. It is assumed that C<$paragraph> is the most recently read -(but not yet processed) input paragraph. - -The value returned will be true if the C<$paragraph> and the rest of the -text in the same section as C<$paragraph> should be selected (included) -for processing; otherwise a false value is returned. - -=cut - -sub is_selected { - my ($self, $paragraph) = @_; - local $_; - local *myData = $self; - - $self->_init_headings() unless (defined $myData{_SECTION_HEADINGS}); - - ## Keep track of current sections levels and headings - $_ = $paragraph; - if (/^=((?:sub)*)(?:head(?:ing)?|sec(?:tion)?)(\d*)\s+(.*?)\s*$/) - { - ## This is a section heading command - my ($level, $heading) = ($2, $3); - $level = 1 + (length($1) / 3) if ((! length $level) || (length $1)); - ## Reset the current section heading at this level - $myData{_SECTION_HEADINGS}->[$level - 1] = $heading; - ## Reset subsection headings of this one to empty - for (my $i = $level; $i < $MAX_HEADING_LEVEL; ++$i) { - $myData{_SECTION_HEADINGS}->[$i] = ''; - } - } - - return $self->match_section(); -} - -############################################################################# - -=head1 EXPORTED FUNCTIONS - -The following functions are exported by this module. Please note that -these are functions (not methods) and therefore C<do not> take an -implicit first argument. - -=cut - -##--------------------------------------------------------------------------- - -=head1 B<podselect()> - - podselect(\%options,@filelist); - -B<podselect> will print the raw (untranslated) POD paragraphs of all -POD sections in the given input files specified by C<@filelist> -according to the options given in C<\%options>. - -If any argument to B<podselect> is a reference to a hash -(associative array) then the values with the following keys are -processed as follows: - -=over 4 - -=item B<-output> - -A string corresponding to the desired output file (or ">&STDOUT" -or ">&STDERR"), or a filehandle to write on. The default is to use -standard output. - -=item B<-sections> - -A reference to an array of sections specifications (as described in -L<"SECTION SPECIFICATIONS">) which indicate the desired set of POD -sections and subsections to be selected from input. If no section -specifications are given, then all sections of the PODs are used. - -=begin _NOT_IMPLEMENTED_ - -=item B<-ranges> - -A reference to an array of range specifications (as described in -L<"RANGE SPECIFICATIONS">) which indicate the desired range of POD -paragraphs to be selected from the desired input sections. If no range -specifications are given, then all paragraphs of the desired sections -are used. - -=end _NOT_IMPLEMENTED_ - -=back - -All other arguments are optional and should correspond to filehandles to -read from or the names of input files containing POD sections. A file name -of "", "-" or "<&STDIN" will be interpreted to mean standard input (which -is the default if no arguments are given). - -=cut - -sub podselect { - my(@argv) = @_; - my %defaults = (); - my $pod_parser = new Pod::Select(%defaults); - my $num_inputs = 0; - my $output = '>&STDOUT'; - my %opts; - local $_; - for (@argv) { - my $ref = ref($_); - if ($ref && $ref eq 'HASH') { - %opts = (%defaults, %{$_}); - - ##------------------------------------------------------------- - ## Need this for backward compatibility since we formerly used - ## options that were all uppercase words rather than ones that - ## looked like Unix command-line options. - ## to be uppercase keywords) - ##------------------------------------------------------------- - %opts = map { - my ($key, $val) = (lc $_, $opts{$_}); - $key =~ s/^(?=\w)/-/; - $key =~ /^-se[cl]/ and $key = '-sections'; - #! $key eq '-range' and $key .= 's'; - ($key => $val); - } (keys %opts); - - ## Process the options - (exists $opts{'-output'}) and $output = $opts{'-output'}; - - ## Select the desired sections - $pod_parser->select(@{ $opts{'-sections'} }) - if ( (defined $opts{'-sections'}) - && ((ref $opts{'-sections'}) eq 'ARRAY') ); - - #! ## Select the desired paragraph ranges - #! $pod_parser->select(@{ $opts{'-ranges'} }) - #! if ( (defined $opts{'-ranges'}) - #! && ((ref $opts{'-ranges'}) eq 'ARRAY') ); - } - elsif(!$ref || $ref eq 'GLOB') { - $pod_parser->parse_from_file($_, $output); - ++$num_inputs; - } - else { - croak "Input from $ref reference not supported!\n"; - } - } - $pod_parser->parse_from_file('-') unless ($num_inputs > 0); -} - -############################################################################# - -=head1 PRIVATE METHODS AND DATA - -B<Pod::Select> makes uses a number of internal methods and data fields -which clients should not need to see or use. For the sake of avoiding -name collisions with client data and methods, these methods and fields -are briefly discussed here. Determined hackers may obtain further -information about them by reading the B<Pod::Select> source code. - -Private data fields are stored in the hash-object whose reference is -returned by the B<new()> constructor for this class. The names of all -private methods and data-fields used by B<Pod::Select> begin with a -prefix of "_" and match the regular expression C</^_\w+$/>. - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head1 B<_compile_section_spec()> - - $listref = $parser->_compile_section_spec($section_spec); - -This function (note it is a function and I<not> a method) takes a -section specification (as described in L<"SECTION SPECIFICATIONS">) -given in C<$section_sepc>, and compiles it into a list of regular -expressions. If C<$section_spec> has no syntax errors, then a reference -to the list (array) of corresponding regular expressions is returned; -otherwise C<undef> is returned and an error message is printed (using -B<carp>) for each invalid regex. - -=end _PRIVATE_ - -=cut - -sub _compile_section_spec { - my ($section_spec) = @_; - my (@regexs, $negated); - - ## Compile the spec into a list of regexs - local $_ = $section_spec; - s{\\\\}{\001}g; ## handle escaped backward slashes - s{\\/}{\002}g; ## handle escaped forward slashes - - ## Parse the regexs for the heading titles - @regexs = split(/\//, $_, $MAX_HEADING_LEVEL); - - ## Set default regex for omitted levels - for (my $i = 0; $i < $MAX_HEADING_LEVEL; ++$i) { - $regexs[$i] = '.*' unless ((defined $regexs[$i]) - && (length $regexs[$i])); - } - ## Modify the regexs as needed and validate their syntax - my $bad_regexs = 0; - for (@regexs) { - $_ .= '.+' if ($_ eq '!'); - s{\001}{\\\\}g; ## restore escaped backward slashes - s{\002}{\\/}g; ## restore escaped forward slashes - $negated = s/^\!//; ## check for negation - eval "m{$_}"; ## check regex syntax - if ($@) { - ++$bad_regexs; - carp qq{Bad regular expression /$_/ in "$section_spec": $@\n}; - } - else { - ## Add the forward and rear anchors (and put the negator back) - $_ = '^' . $_ unless (/^\^/); - $_ = $_ . '$' unless (/\$$/); - $_ = '!' . $_ if ($negated); - } - } - return (! $bad_regexs) ? [ @regexs ] : undef; -} - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head2 $self->{_SECTION_HEADINGS} - -A reference to an array of the current section heading titles for each -heading level (note that the first heading level title is at index 0). - -=end _PRIVATE_ - -=cut - -##--------------------------------------------------------------------------- - -=begin _PRIVATE_ - -=head2 $self->{_SELECTED_SECTIONS} - -A reference to an array of references to arrays. Each subarray is a list -of anchored regular expressions (preceded by a "!" if the expression is to -be negated). The index of the expression in the subarray should correspond -to the index of the heading title in C<$self-E<gt>{_SECTION_HEADINGS}> -that it is to be matched against. - -=end _PRIVATE_ - -=cut - -############################################################################# - -=head1 SEE ALSO - -L<Pod::Parser> - -=head1 AUTHOR - -Please report bugs using L<http://rt.cpan.org>. - -Brad Appleton E<lt>bradapp@enteract.comE<gt> - -Based on code for B<pod2text> written by -Tom Christiansen E<lt>tchrist@mox.perl.comE<gt> - -B<Pod::Select> is part of the L<Pod::Parser> distribution. - -=cut - -1; -# vim: ts=4 sw=4 et diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/scripts/podselect.PL b/gnu/usr.bin/perl/cpan/Pod-Parser/scripts/podselect.PL deleted file mode 100644 index 16e2d985be6..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/scripts/podselect.PL +++ /dev/null @@ -1,143 +0,0 @@ -#!/usr/local/bin/perl
-
-use Config;
-use File::Basename qw(&basename &dirname);
-use Cwd;
-
-# List explicitly here the variables you want Configure to
-# generate. Metaconfig only looks for shell variables, so you
-# have to mention them as if they were shell variables, not
-# %Config entries. Thus you write
-# $startperl
-# to ensure Configure will look for $Config{startperl}.
-
-# This forces PL files to create target in same directory as PL file.
-# This is so that make depend always knows where to find PL derivatives.
-$origdir = cwd;
-chdir(dirname($0));
-$file = basename($0, '.PL');
-$file .= '.com' if $^O eq 'VMS';
-
-open OUT,">$file" or die "Can't create $file: $!";
-
-print "Extracting $file (with variable substitutions)\n";
-
-# In this section, perl variables will be expanded during extraction.
-# You can use $Config{...} to use Configure variables.
-
-print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
-!GROK!THIS!
-
-# In the following, perl variables are not expanded during extraction.
-
-print OUT <<'!NO!SUBS!';
-
-#############################################################################
-# podselect -- command to invoke the podselect function in Pod::Select
-#
-# Copyright (c) 1996-2000 by Bradford Appleton. All rights reserved.
-# This file is part of "PodParser". PodParser is free software;
-# you can redistribute it and/or modify it under the same terms
-# as Perl itself.
-#############################################################################
-
-use strict;
-#use diagnostics;
-
-=head1 NAME
-
-podselect - print selected sections of pod documentation on standard output
-
-=head1 SYNOPSIS
-
-B<podselect> [B<-help>] [B<-man>] [B<-section>S< >I<section-spec>]
-[I<file>S< >...]
-
-=head1 OPTIONS AND ARGUMENTS
-
-=over 8
-
-=item B<-help>
-
-Print a brief help message and exit.
-
-=item B<-man>
-
-Print the manual page and exit.
-
-=item B<-section>S< >I<section-spec>
-
-Specify a section to include in the output.
-See L<Pod::Parser/"SECTION SPECIFICATIONS">
-for the format to use for I<section-spec>.
-This option may be given multiple times on the command line.
-
-=item I<file>
-
-The pathname of a file from which to select sections of pod
-documentation (defaults to standard input).
-
-=back
-
-=head1 DESCRIPTION
-
-B<podselect> will read the given input files looking for pod
-documentation and will print out (in raw pod format) all sections that
-match one ore more of the given section specifications. If no section
-specifications are given than all pod sections encountered are output.
-
-B<podselect> invokes the B<podselect()> function exported by B<Pod::Select>
-Please see L<Pod::Select/podselect()> for more details.
-
-=head1 SEE ALSO
-
-L<Pod::Parser> and L<Pod::Select>
-
-=head1 AUTHOR
-
-Please report bugs using L<http://rt.cpan.org>.
-
-Brad Appleton E<lt>bradapp@enteract.comE<gt>
-
-Based on code for B<Pod::Text::pod2text(1)> written by
-Tom Christiansen E<lt>tchrist@mox.perl.comE<gt>
-
-=cut
-
-use Pod::Select;
-use Pod::Usage;
-use Getopt::Long;
-
-## Define options
-my %options = (
- 'help' => 0,
- 'man' => 0,
- 'sections' => [],
-);
-
-## Parse options
-GetOptions(\%options, 'help', 'man', 'sections|select=s@') || pod2usage(2);
-pod2usage(1) if ($options{help});
-pod2usage(-verbose => 2) if ($options{man});
-
-## Dont default to STDIN if connected to a terminal
-pod2usage(2) if ((@ARGV == 0) && (-t STDIN));
-
-## Invoke podselect().
-if (@{ $options{'sections'} } > 0) {
- podselect({ -sections => $options{'sections'} }, @ARGV);
-}
-else {
- podselect(@ARGV);
-}
-
-
-!NO!SUBS!
-
-close OUT or die "Can't close $file: $!";
-chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
-exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
-chdir $origdir;
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_bad_pod.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_bad_pod.xr deleted file mode 100644 index c7907963d95..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_bad_pod.xr +++ /dev/null @@ -1,5 +0,0 @@ -=head foo
-
-bar baz.
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_pod.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_pod.t deleted file mode 100755 index 96cdb95bb17..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_pod.t +++ /dev/null @@ -1,19 +0,0 @@ -#!/usr/bin/env perl
-
-# Copyright (C) 2005 Joshua Hoblitt
-#
-# $Id$
-
-use strict;
-
-use Test::More tests => 2;
-
-use Pod::Find qw( contains_pod );
-
-{
- ok(contains_pod('t/pod/contains_pod.xr'), "contains pod");
-}
-
-{
- ok(contains_pod('t/pod/contains_bad_pod.xr'), "contains bad pod");
-}
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_pod.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_pod.xr deleted file mode 100644 index b79591a95c4..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/contains_pod.xr +++ /dev/null @@ -1,5 +0,0 @@ -=head1 foo
-
-bar baz.
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/empty.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/empty.xr deleted file mode 100644 index e69de29bb2d..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/empty.xr +++ /dev/null diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/emptycmd.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/emptycmd.t deleted file mode 100755 index 53d1046345b..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/emptycmd.t +++ /dev/null @@ -1,21 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-__END__
-
-=pod
-
-= this is a test
-of the emergency
-broadcast system
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/emptycmd.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/emptycmd.xr deleted file mode 100644 index dd474a1a447..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/emptycmd.xr +++ /dev/null @@ -1,2 +0,0 @@ - = this is a test of the emergency broadcast system
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/find.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/find.t deleted file mode 100755 index 90a57adaaca..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/find.t +++ /dev/null @@ -1,107 +0,0 @@ -# Testing of Pod::Find
-# Author: Marek Rouchal <marek@saftsack.fs.uni-bayreuth.de>
-
-$| = 1;
-
-BEGIN {
- if ($^O eq 'VMS') {
- print "1..0 # needs upstream patch from https://rt.cpan.org/Ticket/Display.html?id=55121";
- exit 0;
- }
-}
-
-use strict;
-use Test::More tests => 4;
-
-BEGIN {
- # 1. load successful
- use_ok('Pod::Find', qw(pod_find pod_where));
-}
-
-use File::Spec;
-
-require Cwd;
-my $THISDIR = Cwd::cwd();
-my $VERBOSE = $ENV{PERL_CORE} ? 0 : ($ENV{TEST_VERBOSE} || 0);
-my $lib_dir = File::Spec->catdir($THISDIR,'lib');
-
-if ($^O eq 'VMS') {
- $lib_dir = VMS::Filespec::unixify($lib_dir);
-}
-
-print "### 2. searching $lib_dir\n";
-my %pods = pod_find($lib_dir);
-my @results = values %pods;
-print "### found @results\n";
-my @compare = qw(
- Pod::Find
- Pod::InputObjects
- Pod::ParseUtils
- Pod::Parser
- Pod::PlainText
- Pod::Select
-);
-if (File::Spec->case_tolerant || $^O eq 'dos') {
- # must downcase before sorting
- map {$_ = lc $_} @compare;
- map {$_ = lc $_} @results;
-}
-my $compare = join(',', sort @compare);
-my $result = join(',', sort @results);
-is($result, $compare);
-
-print "### 3. searching for File::Find\n";
-$result = pod_where({ -inc => 1, -verbose => $VERBOSE }, 'File::Find')
- || 'undef - pod not found!';
-print "### found $result\n";
-
-require Config;
-$compare = $ENV{PERL_CORE} ?
- File::Spec->catfile(File::Spec->updir, File::Spec->updir, 'lib','File','Find.pm')
- : File::Spec->catfile($Config::Config{privlibexp},"File","Find.pm");
-my $resfile = _canon($result);
-my $cmpfile = _canon($compare);
-if($^O =~ /dos|win32/i && $resfile =~ /~\d(?=\\|$)/) {
- # we have ~1 short filenames
- $resfile = quotemeta($resfile);
- $resfile =~ s/\\~\d(?=\\|$)/[^\\\\]+/g;
- ok($cmpfile =~ /^$resfile$/, "pod_where found File::Find (with long filename matching)") ||
- diag("'$cmpfile' does not match /^$resfile\$/");
-} elsif($^O =~ /dos|win32/i && $cmpfile =~ /~\d(?=\\|$)/) {
- # we have ~1 short filenames
- $cmpfile = quotemeta($cmpfile);
- $cmpfile =~ s/\\~\d(?=\\|$)/[^\\\\]+/g;
- ok($resfile =~ /^$cmpfile$/, "pod_where found File::Find (with long filename matching)") ||
- diag("'$resfile' does not match /^$cmpfile\$/");
-} else {
- is($resfile,$cmpfile,"pod_where found File::Find");
-}
-
-# Search for a documentation pod rather than a module
-my $searchpod = 'Stuff';
-print "### 4. searching for $searchpod.pod\n";
-$result = pod_where(
- { -dirs => [ File::Spec->catdir( qw(t), 'pod', 'testpods', 'lib', 'Pod') ],
- -verbose => $VERBOSE }, $searchpod)
- || "undef - $searchpod.pod not found!";
-print "### found $result\n";
-
-$compare = File::Spec->catfile(
- qw(t), 'pod', 'testpods', 'lib', 'Pod' ,'Stuff.pm');
-is(_canon($result),_canon($compare));
-
-
-# make the path as generic as possible
-sub _canon
-{
- my ($path) = @_;
- $path = File::Spec->canonpath($path);
- my @comp = File::Spec->splitpath($path);
- my @dir = File::Spec->splitdir($comp[1]);
- $comp[1] = File::Spec->catdir(@dir);
- $path = File::Spec->catpath(@comp);
- $path = uc($path) if File::Spec->case_tolerant;
- print "### general path: $path\n" if $VERBOSE;
- $path;
-}
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/for.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/for.t deleted file mode 100755 index 12ba3392c08..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/for.t +++ /dev/null @@ -1,59 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=pod
-
-This is a test
-
-=for theloveofpete
-You shouldn't see this
-or this
-or this
-
-=for text
-pod2text should see this
-and this
-and this
-
-and everything should see this!
-
-=begin text
-
-Similarly, this line ...
-
-and this one ...
-
-as well this one,
-
-should all be in pod2text output
-
-=end text
-
-Tweedley-deedley-dee, Im as happy as can be!
-Tweedley-deedley-dum, cuz youre my honey sugar plum!
-
-=begin atthebeginning
-
-But I expect to see neither hide ...
-
-nor tail ...
-
-of this text
-
-=end atthebeginning
-
-The rest of this should show up in everything.
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/for.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/for.xr deleted file mode 100644 index b616bf2cb2b..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/for.xr +++ /dev/null @@ -1,21 +0,0 @@ - This is a test
-
- pod2text should see this
- and this
- and this
-
- and everything should see this!
-
-Similarly, this line ...
-
-and this one ...
-
-as well this one,
-
-should all be in pod2text output
-
- Tweedley-deedley-dee, Im as happy as can be! Tweedley-deedley-dum, cuz
- youre my honey sugar plum!
-
- The rest of this should show up in everything.
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/headings.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/headings.t deleted file mode 100755 index 4688272231a..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/headings.t +++ /dev/null @@ -1,140 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-#################################################################
- use Pod::Usage;
- pod2usage( VERBOSE => 2, EXIT => 1 );
-
-=pod
-
-=head1 NAME
-
-B<rdb2pg> - insert an rdb table into a PostgreSQL database
-
-=head1 SYNOPSIS
-
-B<rdb2pg> [I<param>=I<value> ...]
-
-=head1 PARAMETERS
-
-B<rdb2pg> uses an IRAF-compatible parameter interface.
-A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>.
-
-=over 4
-
-=item B<input> I<file>
-
-The B<RDB> file to insert into the database. If the given name
-is the string C<stdin>, it reads from the UNIX standard input stream.
-
-
-=back
-
-=head1 DESCRIPTION
-
-B<rdb2pg> will enter the data from an B<RDB> database into a
-PostgreSQL database table, optionally creating the database and the
-table if they do not exist. It automatically determines the
-PostgreSQL data type from the column definition in the B<RDB> file,
-but may be overriden via a series of definition files or directly
-via one of its parameters.
-
-The target database and table are specified by the C<db> and C<table>
-parameters. If they do not exist, and the C<createdb> parameter is
-set, they will be created. Table field definitions are determined
-in the following order:
-
-=cut
-
-#################################################################
-
-results in:
-
-
-#################################################################
-
- rdb2pg - insert an rdb table into a PostgreSQL database
-
- rdb2pg [*param*=*value* ...]
-
- rdb2pg uses an IRAF-compatible parameter interface. A template
- parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par.
-
- The RDB file to insert into the database. If the given name is
- the string `stdin', it reads from the UNIX standard input
- stream.
-
- rdb2pg will enter the data from an RDB database into a
- PostgreSQL database table, optionally creating the database and
- the table if they do not exist. It automatically determines the
- PostgreSQL data type from the column definition in the RDB file,
- but may be overriden via a series of definition files or
- directly via one of its parameters.
-
- The target database and table are specified by the `db' and
- `table' parameters. If they do not exist, and the `createdb'
- parameter is set, they will be created. Table field definitions
- are determined in the following order:
-
-
-#################################################################
-
-while the original version of Text (using pod2text) gives
-
-#################################################################
-
-NAME
- rdb2pg - insert an rdb table into a PostgreSQL database
-
-SYNOPSIS
- rdb2pg [*param*=*value* ...]
-
-PARAMETERS
- rdb2pg uses an IRAF-compatible parameter interface. A template
- parameter file is in /proj/axaf/simul/lib/uparm/rdb2pg.par.
-
- input *file*
- The RDB file to insert into the database. If the given name
- is the string `stdin', it reads from the UNIX standard input
- stream.
-
-DESCRIPTION
- rdb2pg will enter the data from an RDB database into a
- PostgreSQL database table, optionally creating the database and
- the table if they do not exist. It automatically determines the
- PostgreSQL data type from the column definition in the RDB file,
- but may be overriden via a series of definition files or
- directly via one of its parameters.
-
- The target database and table are specified by the `db' and
- `table' parameters. If they do not exist, and the `createdb'
- parameter is set, they will be created. Table field definitions
- are determined in the following order:
-
-
-#################################################################
-
-
-Thanks for any help. If, as your email indicates, you've not much
-time to look at this, I can work around things by calling pod2text()
-directly using the official Text.pm.
-
-Diab
-
--------------
-Diab Jerius
-djerius@cfa.harvard.edu
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/headings.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/headings.xr deleted file mode 100644 index f92efb5ecf5..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/headings.xr +++ /dev/null @@ -1,26 +0,0 @@ -NAME
- rdb2pg - insert an rdb table into a PostgreSQL database
-
-SYNOPSIS
- rdb2pg [*param*=*value* ...]
-
-PARAMETERS
- rdb2pg uses an IRAF-compatible parameter interface. A template parameter
- file is in /proj/axaf/simul/lib/uparm/rdb2pg.par.
-
- input *file*
- The RDB file to insert into the database. If the given name is the
- string `stdin', it reads from the UNIX standard input stream.
-
-DESCRIPTION
- rdb2pg will enter the data from an RDB database into a PostgreSQL
- database table, optionally creating the database and the table if they
- do not exist. It automatically determines the PostgreSQL data type from
- the column definition in the RDB file, but may be overriden via a series
- of definition files or directly via one of its parameters.
-
- The target database and table are specified by the `db' and `table'
- parameters. If they do not exist, and the `createdb' parameter is set,
- they will be created. Table field definitions are determined in the
- following order:
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/include.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/include.t deleted file mode 100755 index 9edb47864ce..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/include.t +++ /dev/null @@ -1,36 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=pod
-
-This file tries to demonstrate a simple =include directive
-for pods. It is used as follows:
-
- =include filename
-
-where "filename" is expected to be an absolute pathname, or else
-reside be relative to the directory in which the current processed
-podfile resides, or be relative to the current directory.
-
-Lets try it out with the file "included.t" shall we.
-
-***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE***
-
-=include included.t
-
-***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE***
-
-So how did we do???
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/include.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/include.xr deleted file mode 100644 index 187653b741a..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/include.xr +++ /dev/null @@ -1,22 +0,0 @@ - This file tries to demonstrate a simple =include directive for pods. It
- is used as follows:
-
- =include filename
-
- where "filename" is expected to be an absolute pathname, or else reside
- be relative to the directory in which the current processed podfile
- resides, or be relative to the current directory.
-
- Lets try it out with the file "included.t" shall we.
-
- ***THIS TEXT IS IMMEDIATELY BEFORE THE INCLUDE***
-
-###### begin =include included.t #####
- This is the text of the included file named "included.t". It should
- appear in the final pod document from pod2xxx
-
-###### end =include included.t #####
- ***THIS TEXT IS IMMEDIATELY AFTER THE INCLUDE***
-
- So how did we do???
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/included.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/included.t deleted file mode 100755 index d6e4a504311..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/included.t +++ /dev/null @@ -1,35 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-##------------------------------------------------------------
-# This file is =included by "include.t"
-#
-# This text should NOT be in the resultant pod document
-# because we havent seen an =xxx pod directive in this file!
-##------------------------------------------------------------
-
-=pod
-
-This is the text of the included file named "included.t".
-It should appear in the final pod document from pod2xxx
-
-=cut
-
-##------------------------------------------------------------
-# This text should NOT be in the resultant pod document
-# because it is *after* an =cut an no other pod directives
-# proceed it!
-##------------------------------------------------------------
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/included.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/included.xr deleted file mode 100644 index 16a65cd3586..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/included.xr +++ /dev/null @@ -1,3 +0,0 @@ - This is the text of the included file named "included.t". It should
- appear in the final pod document from pod2xxx
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/lref.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/lref.t deleted file mode 100755 index 33a0a7ca9f3..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/lref.t +++ /dev/null @@ -1,66 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=pod
-
-Try out I<LOTS> of different ways of specifying references:
-
-Reference the L<manpage/section>
-
-Reference the L<manpage / section>
-
-Reference the L<manpage/ section>
-
-Reference the L<manpage /section>
-
-Reference the L<"manpage/section">
-
-Reference the L<"manpage"/section>
-
-Reference the L<manpage/"section">
-
-Reference the L<manpage/
-section>
-
-Reference the L<manpage
-/section>
-
-Now try it using the new "|" stuff ...
-
-Reference the L<thistext|manpage/section>
-
-Reference the L<thistext | manpage / section>
-
-Reference the L<thistext| manpage/ section>
-
-Reference the L<thistext |manpage /section>
-
-Reference the L<thistext|
-"manpage/section">
-
-Reference the L<thistext
-|"manpage"/section>
-
-Reference the L<thistext|manpage/"section">
-
-Reference the L<thistext|
-manpage/
-section>
-
-Reference the L<thistext
-|manpage
-/section>
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/lref.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/lref.xr deleted file mode 100644 index c287cf5a6d9..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/lref.xr +++ /dev/null @@ -1,40 +0,0 @@ - Try out *LOTS* of different ways of specifying references:
-
- Reference the the section entry in the manpage manpage
-
- Reference the the section entry in the manpage manpage
-
- Reference the the section entry in the manpage manpage
-
- Reference the the section entry in the manpage manpage
-
- Reference the the section on "manpage/section"
-
- Reference the the section entry in the "manpage" manpage
-
- Reference the the section on "section" in the manpage manpage
-
- Reference the the section entry in the manpage manpage
-
- Reference the the section entry in the manpage manpage
-
- Now try it using the new "|" stuff ...
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
- Reference the thistext
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/multiline_items.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/multiline_items.t deleted file mode 100755 index 98ad34222eb..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/multiline_items.t +++ /dev/null @@ -1,31 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=head1 Test multiline item lists
-
-This is a test to ensure that multiline =item paragraphs
-get indented appropriately.
-
-=over 4
-
-=item This
-is
-a
-test.
-
-=back
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/multiline_items.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/multiline_items.xr deleted file mode 100644 index cda163b7f5b..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/multiline_items.xr +++ /dev/null @@ -1,6 +0,0 @@ -Test multiline item lists
- This is a test to ensure that multiline =item paragraphs get indented
- appropriately.
-
- This is a test.
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_items.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_items.t deleted file mode 100755 index f60a67f1abb..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_items.t +++ /dev/null @@ -1,64 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=head1 Test nested item lists
-
-This is a test to ensure the nested =item paragraphs
-get indented appropriately.
-
-=over 2
-
-=item 1
-
-First section.
-
-=over 2
-
-=item a
-
-this is item a
-
-=item b
-
-this is item b
-
-=back
-
-=item 2
-
-Second section.
-
-=over 2
-
-=item a
-
-this is item a
-
-=item b
-
-this is item b
-
-=item c
-
-=item d
-
-This is item c & d.
-
-=back
-
-=back
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_items.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_items.xr deleted file mode 100644 index 30834e9ca62..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_items.xr +++ /dev/null @@ -1,19 +0,0 @@ -Test nested item lists
- This is a test to ensure the nested =item paragraphs get indented
- appropriately.
-
- 1 First section.
-
- a this is item a
-
- b this is item b
-
- 2 Second section.
-
- a this is item a
-
- b this is item b
-
- c
- d This is item c & d.
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_seqs.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_seqs.t deleted file mode 100755 index 6f7ae67e997..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_seqs.t +++ /dev/null @@ -1,23 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=pod
-
-The statement: C<This is dog kind's I<finest> hour!> is a parody of a
-quotation from Winston Churchill.
-
-=cut
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_seqs.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_seqs.xr deleted file mode 100644 index 4d2e09e499c..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/nested_seqs.xr +++ /dev/null @@ -1,3 +0,0 @@ - The statement: `This is dog kind's *finest* hour!' is a parody of a
- quotation from Winston Churchill.
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/oneline_cmds.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/oneline_cmds.t deleted file mode 100755 index 65df35271be..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/oneline_cmds.t +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-==head1 NAME
-B<rdb2pg> - insert an rdb table into a PostgreSQL database
-
-==head1 SYNOPSIS
-B<rdb2pg> [I<param>=I<value> ...]
-
-==head1 PARAMETERS
-B<rdb2pg> uses an IRAF-compatible parameter interface.
-A template parameter file is in F</proj/axaf/simul/lib/uparm/rdb2pg.par>.
-
-==over 4
-==item B<input> I<file>
-The B<RDB> file to insert into the database. If the given name
-is the string C<stdin>, it reads from the UNIX standard input stream.
-
-==back
-
-==head1 DESCRIPTION
-B<rdb2pg> will enter the data from an B<RDB> database into a
-PostgreSQL database table, optionally creating the database and the
-table if they do not exist. It automatically determines the
-PostgreSQL data type from the column definition in the B<RDB> file,
-but may be overriden via a series of definition files or directly
-via one of its parameters.
-
-The target database and table are specified by the C<db> and C<table>
-parameters. If they do not exist, and the C<createdb> parameter is
-set, they will be created. Table field definitions are determined
-in the following order:
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/oneline_cmds.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/oneline_cmds.xr deleted file mode 100644 index f92efb5ecf5..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/oneline_cmds.xr +++ /dev/null @@ -1,26 +0,0 @@ -NAME
- rdb2pg - insert an rdb table into a PostgreSQL database
-
-SYNOPSIS
- rdb2pg [*param*=*value* ...]
-
-PARAMETERS
- rdb2pg uses an IRAF-compatible parameter interface. A template parameter
- file is in /proj/axaf/simul/lib/uparm/rdb2pg.par.
-
- input *file*
- The RDB file to insert into the database. If the given name is the
- string `stdin', it reads from the UNIX standard input stream.
-
-DESCRIPTION
- rdb2pg will enter the data from an RDB database into a PostgreSQL
- database table, optionally creating the database and the table if they
- do not exist. It automatically determines the PostgreSQL data type from
- the column definition in the RDB file, but may be overriden via a series
- of definition files or directly via one of its parameters.
-
- The target database and table are specified by the `db' and `table'
- parameters. If they do not exist, and the `createdb' parameter is set,
- they will be created. Table field definitions are determined in the
- following order:
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/podselect.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/podselect.t deleted file mode 100755 index 2d8e6b4f585..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/podselect.t +++ /dev/null @@ -1,18 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-=include podselect.PL
-
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/podselect.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/podselect.xr deleted file mode 100644 index 00b977491cd..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/podselect.xr +++ /dev/null @@ -1,44 +0,0 @@ -###### begin =include podselect.PL #####
-NAME
- podselect - print selected sections of pod documentation on standard
- output
-
-SYNOPSIS
- podselect [-help] [-man] [-section *section-spec*] [*file* ...]
-
-OPTIONS AND ARGUMENTS
- -help Print a brief help message and exit.
-
- -man Print the manual page and exit.
-
- -section *section-spec*
- Specify a section to include in the output. See the section on
- "SECTION SPECIFICATIONS" in the Pod::Parser manpage for the
- format to use for *section-spec*. This option may be given
- multiple times on the command line.
-
- *file* The pathname of a file from which to select sections of pod
- documentation (defaults to standard input).
-
-DESCRIPTION
- podselect will read the given input files looking for pod documentation
- and will print out (in raw pod format) all sections that match one ore
- more of the given section specifications. If no section specifications
- are given than all pod sections encountered are output.
-
- podselect invokes the podselect() function exported by Pod::Select
- Please see the podselect() entry in the Pod::Select manpage for more
- details.
-
-SEE ALSO
- the Pod::Parser manpage and the Pod::Select manpage
-
-AUTHOR
- Please report bugs using http://rt.cpan.org.
-
- Brad Appleton <bradapp@enteract.com>
-
- Based on code for Pod::Text::pod2text(1) written by Tom Christiansen
- <tchrist@mox.perl.com>
-
-###### end =include podselect.PL #####
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/selfcheck.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/selfcheck.t deleted file mode 100644 index 17df68e301a..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/selfcheck.t +++ /dev/null @@ -1,53 +0,0 @@ -#!/usr/bin/perl
-use Test::More;
-use File::Basename;
-use File::Spec;
-use strict;
-my $THISDIR;
-BEGIN {
- $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- eval {
- require "testpchk.pl";
- import TestPodChecker qw(testpodcheck);
- };
- warn $@ if $@;
-};
-
-my @pods;
-unless($Pod::Checker::VERSION && $Pod::Checker::VERSION > 1.40) {
- plan skip_all => "we do not have a good Pod::Checker around";
-} else {
- my $path = File::Spec->catfile($THISDIR,(File::Spec->updir()) x 2, 'lib', 'Pod', '*.pm');
- print "THISDIR=$THISDIR PATH=$path\n";
- @pods = glob($path);
- print "PODS=@pods\n";
- plan tests => scalar(@pods);
-}
-
-# test that our POD is correct!
-my $errs = 0;
-
-foreach my $pod (@pods) {
- my $out = File::Spec->catfile($THISDIR, basename($pod));
- $out =~ s{\.pm}{.OUT};
- my %options = ( -Out => $out );
- my $failmsg = testpodcheck(-In => $pod, -Out => $out, -Cmp => "$THISDIR/empty.xr");
- if($failmsg) {
- if(open(IN, "<$out")) {
- while(<IN>) {
- warn "podchecker: $_";
- }
- close(IN);
- } else {
- warn "Error: Cannot read output file $out: $!\n";
- }
- ok(0, $pod);
- $errs++;
- } else {
- ok(1, $pod);
- }
-}
-
-exit( ($errs == 0) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/special_seqs.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/special_seqs.t deleted file mode 100755 index f1399ccf771..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/special_seqs.t +++ /dev/null @@ -1,46 +0,0 @@ -BEGIN {
- use File::Basename;
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testp2pt.pl";
- import TestPodIncPlainText;
-}
-
-my %options = map { $_ => 1 } @ARGV; ## convert cmdline to options-hash
-my $passed = testpodplaintext \%options, $0;
-exit( ($passed == 1) ? 0 : -1 ) unless $ENV{HARNESS_ACTIVE};
-
-
-__END__
-
-
-=pod
-
-This is a test to see if I can do not only C<$self> and C<method()>, but
-also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and
-C<< $Foo <=> $Bar >> without resorting to escape sequences. If
-I want to refer to the right-shift operator I can do something
-like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>.
-
-Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>.
-And I also want to make sure that newlines work like this
-C<<<
-$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]
->>>
-
-Of course I should still be able to do all this I<with> escape sequences
-too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and C<{FOO=E<gt>BAR}>.
-
-Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>.
-
-And make sure that C<0> works too!
-
-Now, if I use << or >> as my delimiters, then I have to use whitespace.
-So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end
-up doing what you might expect since the first > will still terminate
-the first < seen.
-
-Lets make sure these work for empty ones too, like C<< >> and C<< >> >>
-(just to be obnoxious)
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/special_seqs.xr b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/special_seqs.xr deleted file mode 100644 index 4d6c55e5a18..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/special_seqs.xr +++ /dev/null @@ -1,25 +0,0 @@ - This is a test to see if I can do not only `$self' and `method()', but
- also `$self->method()' and `$self->{FIELDNAME}' and `$Foo <=> $Bar'
- without resorting to escape sequences. If I want to refer to the
- right-shift operator I can do something like `$x >> 3' or even `$y >>
- 5'.
-
- Now for the grand finale of `$self->method()->{FIELDNAME} = {FOO=>BAR}'.
- And I also want to make sure that newlines work like this
- `$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b]'
-
- Of course I should still be able to do all this *with* escape sequences
- too: `$self->method()' and `$self->{FIELDNAME}' and `{FOO=>BAR}'.
-
- Dont forget `$self->method()->{FIELDNAME} = {FOO=>BAR}'.
-
- And make sure that `0' works too!
-
- Now, if I use << or >> as my delimiters, then I have to use whitespace.
- So things like `<$self-'method()>> and `<$self-'{FIELDNAME}>> wont end
- up doing what you might expect since the first > will still terminate
- the first < seen.
-
- Lets make sure these work for empty ones too, like and `>>' (just to be
- obnoxious)
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testcmp.pl b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testcmp.pl deleted file mode 100644 index b8592fcc2a8..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testcmp.pl +++ /dev/null @@ -1,94 +0,0 @@ -package TestCompare;
-
-use vars qw(@ISA @EXPORT $MYPKG);
-#use strict;
-#use diagnostics;
-use Carp;
-use Exporter;
-use File::Basename;
-use File::Spec;
-use FileHandle;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(&testcmp);
-$MYPKG = eval { (caller)[0] };
-
-##--------------------------------------------------------------------------
-
-=head1 NAME
-
-testcmp -- compare two files line-by-line
-
-=head1 SYNOPSIS
-
- $is_diff = testcmp($file1, $file2);
-
-or
-
- $is_diff = testcmp({-cmplines => \&mycmp}, $file1, $file2);
-
-=head2 DESCRIPTION
-
-Compare two text files line-by-line and return 0 if they are the
-same, 1 if they differ. Each of $file1 and $file2 may be a filenames,
-or a filehandles (in which case it must already be open for reading).
-
-If the first argument is a hashref, then the B<-cmplines> key in the
-hash may have a subroutine reference as its corresponding value.
-The referenced user-defined subroutine should be a line-comparator
-function that takes two pre-chomped text-lines as its arguments
-(the first is from $file1 and the second is from $file2). It should
-return 0 if it considers the two lines equivalent, and non-zero
-otherwise.
-
-=cut
-
-##--------------------------------------------------------------------------
-
-sub testcmp( $ $ ; $) {
- my %opts = ref($_[0]) eq 'HASH' ? %{shift()} : ();
- my ($file1, $file2) = @_;
- my ($fh1, $fh2) = ($file1, $file2);
- unless (ref $fh1) {
- $fh1 = FileHandle->new($file1, "r") or die "Can't open $file1: $!";
- }
- unless (ref $fh2) {
- $fh2 = FileHandle->new($file2, "r") or die "Can't open $file2: $!";
- }
-
- my $cmplines = $opts{'-cmplines'} || undef;
- my ($f1text, $f2text) = ("", "");
- my ($line, $diffs) = (0, 0);
-
- while ( defined($f1text) and defined($f2text) ) {
- defined($f1text = <$fh1>) and chomp($f1text);
- defined($f2text = <$fh2>) and chomp($f2text);
- ++$line;
- last unless ( defined($f1text) and defined($f2text) );
- # kill any extra line endings
- $f1text =~ s/[\r\n]+$//s;
- $f2text =~ s/[\r\n]+$//s;
- $diffs = (ref $cmplines) ? &$cmplines($f1text, $f2text)
- : ($f1text ne $f2text);
- last if $diffs;
- }
- close($fh1) unless (ref $file1);
- close($fh2) unless (ref $file2);
-
- $diffs = 1 if (defined($f1text) or defined($f2text));
- if ( defined($f1text) and defined($f2text) ) {
- ## these two lines must be different
- warn "$file1 and $file2 differ at line $line\n";
- }
- elsif (defined($f1text) and (! defined($f1text))) {
- ## file1 must be shorter
- warn "$file1 is shorter than $file2\n";
- }
- elsif (defined $f2text) {
- ## file2 must be longer
- warn "$file1 is shorter than $file2\n";
- }
- return $diffs;
-}
-
-1;
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testp2pt.pl b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testp2pt.pl deleted file mode 100644 index 4ed58446876..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testp2pt.pl +++ /dev/null @@ -1,192 +0,0 @@ -package TestPodIncPlainText; - -BEGIN { - use File::Basename; - use File::Spec; - use Cwd qw(abs_path); - push @INC, '..'; - my $THISDIR = abs_path(dirname $0); - unshift @INC, $THISDIR; - require "testcmp.pl"; - import TestCompare; - my $PARENTDIR = dirname $THISDIR; - push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); -} - -#use strict; -#use diagnostics; -use Carp; -use Exporter; -#use File::Compare; -#use Cwd qw(abs_path); - -use vars qw($MYPKG @EXPORT @ISA); -$MYPKG = eval { (caller)[0] }; -@EXPORT = qw(&testpodplaintext); -BEGIN { - require Pod::PlainText; - @ISA = qw( Pod::PlainText ); - require VMS::Filespec if $^O eq 'VMS'; -} - -## Hardcode settings for TERMCAP and COLUMNS so we can try to get -## reproducible results between environments -@ENV{qw(TERMCAP COLUMNS)} = ('co=76:do=^J', 76); - -sub catfile(@) { File::Spec->catfile(@_); } - -my $INSTDIR = abs_path(dirname $0); -$INSTDIR = VMS::Filespec::unixpath($INSTDIR) if $^O eq 'VMS'; -$INSTDIR =~ s#/$## if $^O eq 'VMS'; -$INSTDIR =~ s#:$## if $^O eq 'MacOS'; -$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); -$INSTDIR =~ s#:$## if $^O eq 'MacOS'; -$INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); -my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), - catfile($INSTDIR, 'scripts'), - catfile($INSTDIR, 'pod'), - catfile($INSTDIR, 't', 'pod') - ); - -# FIXME - we should make the core capable of finding utilities built in -# locations in ext. -push @PODINCDIRS, catfile((File::Spec->updir()) x 2, 'pod') if $ENV{PERL_CORE}; - -## Find the path to the file to =include -sub findinclude { - my $self = shift; - my $incname = shift; - - ## See if its already found w/out any "searching; - return $incname if (-r $incname); - - ## Need to search for it. Look in the following directories ... - ## 1. the directory containing this pod file - my $thispoddir = dirname $self->input_file; - ## 2. the parent directory of the above - my $parentdir = dirname $thispoddir; - my @podincdirs = ($thispoddir, $parentdir, @PODINCDIRS); - - for (@podincdirs) { - my $incfile = catfile($_, $incname); - return $incfile if (-r $incfile); - } - warn("*** Can't find =include file $incname in @podincdirs\n"); - return ""; -} - -sub command { - my $self = shift; - my ($cmd, $text, $line_num, $pod_para) = @_; - $cmd = '' unless (defined $cmd); - local $_ = $text || ''; - my $out_fh = $self->output_handle; - - ## Defer to the superclass for everything except '=include' - return $self->SUPER::command(@_) unless ($cmd eq "include"); - - ## We have an '=include' command - my $incdebug = 1; ## debugging - my @incargs = split; - if (@incargs == 0) { - warn("*** No filename given for '=include'\n"); - return; - } - my $incfile = $self->findinclude(shift @incargs) or return; - my $incbase = basename $incfile; - print $out_fh "###### begin =include $incbase #####\n" if ($incdebug); - $self->parse_from_file( {-cutting => 1}, $incfile ); - print $out_fh "###### end =include $incbase #####\n" if ($incdebug); -} - -sub begin_input { - $_[0]->{_INFILE} = VMS::Filespec::unixify($_[0]->{_INFILE}) if $^O eq 'VMS'; -} - -sub podinc2plaintext( $ $ ) { - my ($infile, $outfile) = @_; - local $_; - my $text_parser = $MYPKG->new; - $text_parser->parse_from_file($infile, $outfile); -} - -sub testpodinc2plaintext( @ ) { - my %args = @_; - my $infile = $args{'-In'} || croak "No input file given!"; - my $outfile = $args{'-Out'} || croak "No output file given!"; - my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!"; - - my $different = ''; - my $testname = basename $cmpfile, '.t', '.xr'; - - unless (-e $cmpfile) { - my $msg = "*** Can't find comparison file $cmpfile for testing $infile"; - warn "$msg\n"; - return $msg; - } - - print "# Running testpodinc2plaintext for '$testname'...\n"; - ## Compare the output against the expected result - podinc2plaintext($infile, $outfile); - if ( testcmp($outfile, $cmpfile) ) { - $different = "$outfile is different from $cmpfile"; - } - else { - unlink($outfile); - } - return $different; -} - -sub testpodplaintext( @ ) { - my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : (); - my @testpods = @_; - my ($testname, $testdir) = ("", ""); - my ($podfile , $cmpfile) = ("", ""); - my ($outfile , $errfile) = ("", ""); - my $passes = 0; - my $failed = 0; - local $_; - - print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'}); - - for $podfile (@testpods) { - ($testname, $_) = fileparse($podfile); - $testdir ||= $_; - $testname =~ s/\.t$//; - $cmpfile = $testdir . $testname . '.xr'; - $outfile = $testdir . $testname . '.OUT'; - - if ($opts{'-xrgen'}) { - if ($opts{'-force'} or ! -e $cmpfile) { - ## Create the comparison file - print "# Creating expected result for \"$testname\"" . - " pod2plaintext test ...\n"; - podinc2plaintext($podfile, $cmpfile); - } - else { - print "# File $cmpfile already exists" . - " (use '-force' to regenerate it).\n"; - } - next; - } - - my $failmsg = testpodinc2plaintext - -In => $podfile, - -Out => $outfile, - -Cmp => $cmpfile; - if ($failmsg) { - ++$failed; - print "#\tFAILED. ($failmsg)\n"; - print "not ok ", $failed+$passes, "\n"; - } - else { - ++$passes; - unlink($outfile); - print "#\tPASSED.\n"; - print "ok ", $failed+$passes, "\n"; - } - } - return $passes; -} - -1; diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testpchk.pl b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testpchk.pl deleted file mode 100644 index 0464a9a0fcf..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testpchk.pl +++ /dev/null @@ -1,130 +0,0 @@ -package TestPodChecker;
-
-BEGIN {
- use File::Basename;
- use File::Spec;
- push @INC, '..';
- my $THISDIR = dirname $0;
- unshift @INC, $THISDIR;
- require "testcmp.pl";
- import TestCompare;
- my $PARENTDIR = dirname $THISDIR;
- push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR);
- require VMS::Filespec if $^O eq 'VMS';
-}
-
-use Pod::Checker;
-use vars qw(@ISA @EXPORT $MYPKG);
-#use strict;
-#use diagnostics;
-use Carp;
-use Exporter;
-#use File::Compare;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(&testpodchecker);
-@EXPORT_OK = qw(&testpodcheck);
-$MYPKG = eval { (caller)[0] };
-
-sub stripname( $ ) {
- local $_ = shift;
- return /(\w[.\w]*)\s*$/ ? $1 : $_;
-}
-
-sub msgcmp( $ $ ) {
- ## filter out platform-dependent aspects of error messages
- my ($line1, $line2) = @_;
- for ($line1, $line2) {
- ## remove filenames from error messages to avoid any
- ## filepath naming differences between OS platforms
- s/(at line \S+ in file) .*\W(\w+\.[tT])\s*$/$1 \L$2\E/;
- s/.*\W(\w+\.[tT]) (has \d+ pod syntax error)/\L$1\E $2/;
- }
- return ($line1 ne $line2);
-}
-
-sub testpodcheck( @ ) {
- my %args = @_;
- my $infile = $args{'-In'} || croak "No input file given!";
- my $outfile = $args{'-Out'} || croak "No output file given!";
- my $cmpfile = $args{'-Cmp'} || croak "No compare-result file given!";
-
- my $different = '';
- my $testname = basename $infile, '.t', '.xr';
-
- unless (-e $cmpfile) {
- my $msg = "*** Can't find comparison file $cmpfile for testing $infile";
- warn "$msg\n";
- return $msg;
- }
-
- print "# Running podchecker for '$testname'...\n";
- ## Compare the output against the expected result
- if ($^O eq 'VMS') {
- for ($infile, $outfile, $cmpfile) {
- $_ = VMS::Filespec::unixify($_) unless ref;
- }
- }
- podchecker($infile, $outfile);
- if ( testcmp({'-cmplines' => \&msgcmp}, $outfile, $cmpfile) ) {
- $different = "$outfile is different from $cmpfile";
- }
- else {
- unlink($outfile);
- }
- return $different;
-}
-
-sub testpodchecker( @ ) {
- my %opts = (ref $_[0] eq 'HASH') ? %{shift()} : ();
- my @testpods = @_;
- my ($testname, $testdir) = ("", "");
- my ($podfile, $cmpfile) = ("", "");
- my ($outfile, $errfile) = ("", "");
- my $passes = 0;
- my $failed = 0;
- local $_;
-
- print "1..", scalar @testpods, "\n" unless ($opts{'-xrgen'});
-
- for $podfile (@testpods) {
- ($testname, $_) = fileparse($podfile);
- $testdir ||= $_;
- $testname =~ s/\.t$//;
- $cmpfile = $testdir . $testname . '.xr';
- $outfile = $testdir . $testname . '.OUT';
-
- if ($opts{'-xrgen'}) {
- if ($opts{'-force'} or ! -e $cmpfile) {
- ## Create the comparison file
- print "# Creating expected result for \"$testname\"" .
- " podchecker test ...\n";
- podchecker($podfile, $cmpfile);
- }
- else {
- print "# File $cmpfile already exists" .
- " (use '-force' to regenerate it).\n";
- }
- next;
- }
-
- my $failmsg = testpodcheck
- -In => $podfile,
- -Out => $outfile,
- -Cmp => $cmpfile;
- if ($failmsg) {
- ++$failed;
- print "#\tFAILED. ($failmsg)\n";
- print "not ok ", $failed+$passes, "\n";
- }
- else {
- ++$passes;
- unlink($outfile);
- print "#\tPASSED.\n";
- print "ok ", $failed+$passes, "\n";
- }
- }
- return $passes;
-}
-
-1;
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm deleted file mode 100644 index 00a719c6560..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/testpods/lib/Pod/Stuff.pm +++ /dev/null @@ -1,20 +0,0 @@ -=head1 NAME
-
-Pod::Stuff - dummy testing pod
-
-=head1 DESCRIPTION
-
-This isn't really anything, its just some dummy pod code.
-And stuff.
-
-Lots of stuff.
-
-=head2 STUFF
-
-For all your stuff [tm]
-
-Stuffit
-
-Mmmm, stuffed pizza bread.
-
-=cut
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/twice.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/twice.t deleted file mode 100755 index ffb957dadda..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/pod/twice.t +++ /dev/null @@ -1,36 +0,0 @@ -use strict;
-use Test;
-use File::Spec;
-
-BEGIN { plan tests => 1 }
-
-use Pod::Parser;
-use Carp;
-$SIG{__DIE__} = \&Carp::confess;
-
-eval {require IO::String;};
-skip($@ ? 'no IO::String' : '', sub {
- {
- my $pod_string = 'some I<silly> text';
- my $handle = IO::String->new( \$pod_string );
- my $parser = Pod::Parser->new();
- $parser->parse_from_file( $0, $handle );
- }
- # free the reference
- {
- my $parser = Pod::Parser->new();
- $parser->parse_from_file( $0, File::Spec->devnull );
- }
- 1;
-});
-
-exit 0;
-
-__END__
-
-=head1 EXAMPLE
-
-This test makes sure the parse_from_file is re-entrant
-
-=cut
-
diff --git a/gnu/usr.bin/perl/cpan/Pod-Parser/t/unbalanced.t b/gnu/usr.bin/perl/cpan/Pod-Parser/t/unbalanced.t deleted file mode 100644 index ad109952fed..00000000000 --- a/gnu/usr.bin/perl/cpan/Pod-Parser/t/unbalanced.t +++ /dev/null @@ -1,51 +0,0 @@ -#!/usr/bin/perl -use strict; -use warnings; - -use Pod::PlainText; -use Test::More; - -my $invalid = q{ -=head1 One - -=begin foo - -Foo -}; - -my $valid = q{ -=head1 Two - -=begin bar - -Bar - -=end bar - -=head1 Three -}; - - -my $parser = Pod::PlainText->new; - -my $out = ''; -open my $out_fh, '>', \$out or die "Couldn't open out: $!"; - -{ - open my $fh, '<', \$invalid or die "Couldn't open invalid: $!"; - $parser->parse_from_filehandle($fh, $out_fh); - close $fh; -} - -{ - open my $fh, '<', \$valid or die "Couldn't open valid: $!"; - $parser->parse_from_filehandle($fh, $out_fh); - close $fh; -} - -close $out_fh; - - -is $out, "One\nTwo\nThree\n", "Correctly parsed valid document"; - -done_testing; diff --git a/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm b/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm index 42ed4b49d54..bb6ffc83efb 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc.pm @@ -486,8 +486,6 @@ sub init_formatter_class_list { $self->opt_M_with('Pod::Perldoc::ToPod'); # the always-there fallthru $self->opt_o_with('text'); - $self->opt_o_with('man') - if $ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i; return; } diff --git a/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm b/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm index d8e42b1703b..bfcb5c40ee6 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Perldoc/lib/Pod/Perldoc/ToMan.pm @@ -144,9 +144,7 @@ sub _get_podman_switches { # # See RT #77465 # - # Then again, do *not* comment it out on OpenBSD: - # mandoc handles UTF-8 input just fine. - push @switches, 'utf8' => 1; + #push @switches, 'utf8' => 1; $self->debug( "Pod::Man switches are [@switches]\n" ); @@ -211,6 +209,12 @@ sub _have_groff_with_utf8 { $version ge $minimum_groff_version; } +sub _have_mandoc_with_utf8 { + my( $self ) = @_; + + $self->_is_mandoc and not system 'mandoc -Tlocale -V > /dev/null 2>&1'; + } + sub _collect_nroff_switches { my( $self ) = shift; @@ -223,10 +227,6 @@ sub _collect_nroff_switches { push @render_switches, '-rLL=' . (int $c) . 'n' if $cols > 80; } - if( $self->_is_mandoc ) { - push @render_switches, '-Owidth=' . $self->_get_columns; - } - # I hear persistent reports that adding a -c switch to $render # solves many people's problems. But I also hear that some mans # don't have a -c switch, so that unconditionally adding it here @@ -242,6 +242,7 @@ sub _get_device_switches { if( $self->_is_nroff ) { qw() } elsif( $self->_have_groff_with_utf8 ) { qw(-Kutf8 -Tutf8) } elsif( $self->_is_ebcdic ) { qw(-Tcp1047) } + elsif( $self->_have_mandoc_with_utf8 ) { qw(-Tlocale) } elsif( $self->_is_mandoc ) { qw() } else { qw(-Tlatin1) } } @@ -357,9 +358,6 @@ sub _filter_through_nroff { length $done ); - # wait for it to exit - waitpid( $pid, 0 ); - if( $? ) { $self->warn( "Error from pipe to $render!\n" ); $self->debug( 'Error: ' . do { local $/; <$err> } ); diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pm index 20924153b65..6c91b8ac1fb 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pm @@ -18,7 +18,7 @@ use vars qw( ); @ISA = ('Pod::Simple::BlackBox'); -$VERSION = '3.35'; +$VERSION = '3.40'; @Known_formatting_codes = qw(I B C L E F S X Z); %Known_formatting_codes = map(($_=>1), @Known_formatting_codes); @@ -74,6 +74,9 @@ else { # EBCDIC on early Perl. We know what the values are for the code #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ __PACKAGE__->_accessorize( + '_output_is_for_JustPod', # For use only by Pod::Simple::JustPod, + # If non-zero, don't expand Z<> E<> S<> L<>, + # and count how many brackets in format codes 'nbsp_for_S', # Whether to map S<...>'s to \xA0 characters 'source_filename', # Filename of the source, for use in warnings 'source_dead', # Whether to consider this parser's source dead @@ -103,6 +106,8 @@ __PACKAGE__->_accessorize( 'preserve_whitespace', # whether to try to keep whitespace as-is 'strip_verbatim_indent', # What indent to strip from verbatim + 'expand_verbatim_tabs', # 0: preserve tabs in verbatim blocks + # n: expand tabs to stops every n columns 'parse_characters', # Whether parser should expect chars rather than octets @@ -168,6 +173,7 @@ sub encoding { BEGIN { *pretty = \&Pod::Simple::BlackBox::pretty; *stringify_lol = \&Pod::Simple::BlackBox::stringify_lol; + *my_qr = \&Pod::Simple::BlackBox::my_qr; } #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@ -219,11 +225,14 @@ sub new { my $class = ref($_[0]) || $_[0]; #Carp::croak(__PACKAGE__ . " is a virtual base class -- see perldoc " # . __PACKAGE__ ); - return bless { + my $obj = bless { 'accept_codes' => { map( ($_=>$_), @Known_formatting_codes ) }, 'accept_directives' => { %Known_directives }, 'accept_targets' => {}, }, $class; + + $obj->expand_verbatim_tabs(8); + return $obj; } @@ -339,10 +348,9 @@ sub unaccept_targets { # XXX Probably it is an error that the digit '9' is excluded from these re's. # Broken for early Perls on EBCDIC -my $xml_name_re = eval "qr/[^-.0-8:A-Z_a-z[:^ascii:]]/"; -if (! defined $xml_name_re) { - $xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/; -} +my $xml_name_re = my_qr('[^-.0-8:A-Z_a-z[:^ascii:]]', '9'); +$xml_name_re = qr/[\x00-\x2C\x2F\x39\x3B-\x40\x5B-\x5E\x60\x7B-\x7F]/ + unless $xml_name_re; sub accept_code { shift->accept_codes(@_) } # alias @@ -652,12 +660,13 @@ sub _make_treelet { $treelet = $self->_treelet_from_formatting_codes(@_); } - if( $self->_remap_sequences($treelet) ) { + if( ! $self->{'_output_is_for_JustPod'} # Retain these as-is for pod output + && $self->_remap_sequences($treelet) ) + { $self->_treat_Zs($treelet); # Might as well nix these first $self->_treat_Ls($treelet); # L has to precede E and S $self->_treat_Es($treelet); $self->_treat_Ss($treelet); # S has to come after E - $self->_wrap_up($treelet); # Nix X's and merge texties } else { @@ -1080,9 +1089,14 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # By here, $treelet->[$i] is definitely an L node my $ell = $treelet->[$i]; - DEBUG > 1 and print STDERR "Ogling L node $ell\n"; + DEBUG > 1 and print STDERR "Ogling L node " . pretty($ell) . "\n"; - # bitch if it's empty + # bitch if it's empty or is just '/' + if (@{$ell} == 3 and $ell->[2] =~ m!\A\s*/\s*\z!) { + $self->whine( $start_line, "L<> contains only '/'" ); + $treelet->[$i] = 'L</>'; # just make it a text node + next; # and move on + } if( @{$ell} == 2 or (@{$ell} == 3 and $ell->[2] eq '') ) { @@ -1289,6 +1303,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences $section_name = [splice @ell_content]; $section_name->[ 0] =~ s/^\"//s; $section_name->[-1] =~ s/\"$//s; + $ell->[1]{'~tolerated'} = 1; } # Turn L<Foo Bar> into L</Foo Bar>. @@ -1296,8 +1311,8 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences and grep !ref($_) && m/ /s, @ell_content ) { $section_name = [splice @ell_content]; + $ell->[1]{'~deprecated'} = 1; # That's support for the now-deprecated syntax. - # (Maybe generate a warning eventually?) # Note that it deliberately won't work on L<...|Foo Bar> } @@ -1347,7 +1362,7 @@ sub _treat_Ls { # Process our dear dear friends, the L<...> sequences # And update children to be the link-text: @$ell = (@$ell[0,1], defined($link_text) ? splice(@$link_text) : ''); - DEBUG > 2 and print STDERR "End of L-parsing for this node $treelet->[$i]\n"; + DEBUG > 2 and print STDERR "End of L-parsing for this node " . pretty($treelet->[$i]) . "\n"; unshift @stack, $treelet->[$i]; # might as well recurse } @@ -1507,6 +1522,7 @@ sub _accessorize { # A simple-minded method-maker $Carp::CarpLevel = 1, Carp::croak( "Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)" ) unless (@_ == 1 or @_ == 2) and ref $_[0]; + (@_ == 1) ? $_[0]->{$attrname} : ($_[0]->{$attrname} = $_[1]); }; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pod b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pod index 67a18df0d64..c569e979ae9 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pod +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple.pod @@ -19,7 +19,11 @@ Be sure to read L</ENCODING> if your Pod contains non-ASCII characters. Pod formatters can use Pod::Simple to parse Pod documents and render them into plain text, HTML, or any number of other formats. Typically, such formatters will be subclasses of Pod::Simple, and so they will inherit its methods, like -C<parse_file>. +C<parse_file>. But note that Pod::Simple doesn't understand and +properly parse Perl itself, so if you have a file which contains a Perl +program that has a multi-line quoted string which has lines that look +like pod, Pod::Simple will treat them as pod. This can be avoided if +the file makes these into indented here documents instead. If you're reading this document just because you have a Pod-processing subclass that you want to use, this document (plus the documentation for the @@ -219,6 +223,21 @@ that you don't want I<any> lines indented. You can do something like this: return undef; }); +=item C<< $parser->expand_verbatim_tabs( I<n> ) >> + +Default: 8 + +If after any stripping of indentation in verbatim blocks, there remain +tabs, this method call indicates what to do with them. C<0> +means leave them as tabs, any other number indicates that each tab is to +be translated so as to have tab stops every C<n> columns. + +This is independent of other methods (except that it operates after any +verbatim input stripping is done). + +Like the other methods, the input parameter is not checked for validity. +C<undef> or containing non-digits has the same effect as 8. + =back =head1 TERTIARY METHODS @@ -390,8 +409,8 @@ This module is managed in an open GitHub repository, L<https://github.com/perl-pod/pod-simple/>. Feel free to fork and contribute, or to clone L<git://github.com/perl-pod/pod-simple.git> and send patches! -Patches against Pod::Simple are welcome. Please send bug reports to -<bug-pod-simple@rt.cpan.org>. +Please use L<https://github.com/perl-pod/pod-simple/issues/new> to file a bug +report. =head1 COPYRIGHT AND DISCLAIMERS @@ -419,6 +438,8 @@ Pod::Simple is maintained by: =item * David E. Wheeler C<dwheeler@cpan.org> +=item * Karl Williamson C<khw@cpan.org> + =back Documentation has been contributed by: diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm index 9fe3f702ef9..d115aee7e3e 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/BlackBox.pm @@ -22,8 +22,36 @@ use integer; # vroom! use strict; use Carp (); use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; #use constant DEBUG => 7; + +sub my_qr ($$) { + + # $1 is a pattern to compile and return. Older perls compile any + # syntactically valid property, even if it isn't legal. To cope with + # this, return an empty string unless the compiled pattern also + # successfully matches $2, which the caller furnishes. + + my ($input_re, $should_match) = @_; + # XXX could have a third parameter $shouldnt_match for extra safety + + my $use_utf8 = ($] le 5.006002) ? 'use utf8;' : ""; + + my $re = eval "no warnings; $use_utf8 qr/$input_re/"; + #print STDERR __LINE__, ": $input_re: $@\n" if $@; + return "" if $@; + + my $matches = eval "no warnings; $use_utf8 '$should_match' =~ /$re/"; + #print STDERR __LINE__, ": $input_re: $@\n" if $@; + return "" if $@; + + #print STDERR __LINE__, ": SUCCESS: $re\n" if $matches; + return $re if $matches; + + #print STDERR __LINE__, ": $re: didn't match\n"; + return ""; +} + BEGIN { require Pod::Simple; *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG @@ -32,8 +60,37 @@ BEGIN { # Matches a character iff the character will have a different meaning # if we choose CP1252 vs UTF-8 if there is no =encoding line. # This is broken for early Perls on non-ASCII platforms. -my $non_ascii_re = eval "qr/[[:^ascii:]]/"; -$non_ascii_re = qr/[\x80-\xFF]/ if ! defined $non_ascii_re; +my $non_ascii_re = my_qr('[[:^ascii:]]', "\xB6"); +$non_ascii_re = qr/[\x80-\xFF]/ unless $non_ascii_re; + +# Use patterns understandable by Perl 5.6, if possible +my $cs_re = my_qr('\p{IsCs}', "\x{D800}"); +my $cn_re = my_qr('\p{IsCn}', "\x{09E4}"); # <reserved> code point unlikely + # to get assigned +my $rare_blocks_re = my_qr('[\p{InIPAExtensions}\p{InSpacingModifierLetters}]', + "\x{250}"); +$rare_blocks_re = my_qr('[\x{0250}-\x{02FF}]', "\x{250}") unless $rare_blocks_re; + +my $script_run_re = eval 'no warnings "experimental::script_run"; + qr/(*script_run: ^ .* $ )/x'; +my $latin_re = my_qr('[\p{IsLatin}\p{IsInherited}\p{IsCommon}]', "\x{100}"); +unless ($latin_re) { + # This was machine generated to be the ranges of the union of the above + # three properties, with things that were undefined by Unicode 4.1 filling + # gaps. That is the version in use when Perl advanced enough to + # successfully compile and execute the above pattern. + $latin_re = my_qr('[\x00-\x{02E9}\x{02EC}-\x{0374}\x{037E}\x{0385}\x{0387}\x{0485}\x{0486}\x{0589}\x{060C}\x{061B}\x{061F}\x{0640}\x{064B}-\x{0655}\x{0670}\x{06DD}\x{0951}-\x{0954}\x{0964}\x{0965}\x{0E3F}\x{10FB}\x{16EB}-\x{16ED}\x{1735}\x{1736}\x{1802}\x{1803}\x{1805}\x{1D00}-\x{1D25}\x{1D2C}-\x{1D5C}\x{1D62}-\x{1D65}\x{1D6B}-\x{1D77}\x{1D79}-\x{1DBE}\x{1DC0}-\x{1EF9}\x{2000}-\x{2125}\x{2127}-\x{27FF}\x{2900}-\x{2B13}\x{2E00}-\x{2E1D}\x{2FF0}-\x{3004}\x{3006}\x{3008}-\x{3020}\x{302A}-\x{302D}\x{3030}-\x{3037}\x{303C}-\x{303F}\x{3099}-\x{309C}\x{30A0}\x{30FB}\x{30FC}\x{3190}-\x{319F}\x{31C0}-\x{31CF}\x{3220}-\x{325F}\x{327F}-\x{32CF}\x{3358}-\x{33FF}\x{4DC0}-\x{4DFF}\x{A700}-\x{A716}\x{FB00}-\x{FB06}\x{FD3E}\x{FD3F}\x{FE00}-\x{FE6B}\x{FEFF}-\x{FF65}\x{FF70}\x{FF9E}\x{FF9F}\x{FFE0}-\x{FFFD}\x{10100}-\x{1013F}\x{1D000}-\x{1D1DD}\x{1D300}-\x{1D7FF}]', "\x{100}"); +} + +my $every_char_is_latin_re = my_qr("^(?:$latin_re)*\\z", "A"); + +# Latin script code points not in the first release of Unicode +my $later_latin_re = my_qr('[^\P{IsLatin}\p{IsAge=1.1}]', "\x{1F6}"); + +# If this perl doesn't have the Deprecated property, there's only one code +# point in it that we need be concerned with. +my $deprecated_re = my_qr('\p{IsDeprecated}', "\x{149}"); +$deprecated_re = qr/\x{149}/ unless $deprecated_re; my $utf8_bom; if (($] ge 5.007_003)) { @@ -43,6 +100,11 @@ if (($] ge 5.007_003)) { $utf8_bom = "\xEF\xBB\xBF"; # No EBCDIC BOM detection for early Perls. } +# This is used so that the 'content_seen' method doesn't return true on a +# file that just happens to have a line that matches /^=[a-zA-z]/. Only if +# there is a valid =foo line will we return that content was seen. +my $seen_legal_directive = 0; + #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ sub parse_line { shift->parse_lines(@_) } # alias @@ -57,10 +119,10 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) my $cut_handler = $self->{'cut_handler'}; my $wl_handler = $self->{'whiteline_handler'}; $self->{'line_count'} ||= 0; - + my $scratch; - DEBUG > 4 and + DEBUG > 4 and print STDERR "# Parsing starting at line ", $self->{'line_count'}, ".\n"; DEBUG > 5 and @@ -71,9 +133,17 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # paragraph buffer. Because we need to defer processing of =over # directives and verbatim paragraphs. We call _ponder_paragraph_buffer # to process this. - + $self->{'pod_para_count'} ||= 0; + # An attempt to match the pod portions of a line. This is not fool proof, + # but is good enough to serve as part of the heuristic for guessing the pod + # encoding if not specified. + my $format_codes = join "", '[', grep { / ^ [A-Za-z] $/x } + keys %{$self->{accept_codes}}; + $format_codes .= ']'; + my $pod_chars_re = qr/ ^ = [A-Za-z]+ | $format_codes < /x; + my $line; foreach my $source_line (@_) { if( $self->{'source_dead'} ) { @@ -97,7 +167,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) ($line = $source_line) =~ tr/\n\r//d; # If we don't have two vars, we'll end up with that there # tr/// modding the (potentially read-only) original source line! - + } else { DEBUG > 2 and print STDERR "First line: [$source_line]\n"; @@ -106,7 +176,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) $self->_handle_encoding_line( "=encoding utf8" ); delete $self->{'_processed_encoding'}; $line =~ tr/\n\r//d; - + } elsif( $line =~ s/^\xFE\xFF//s ) { DEBUG and print STDERR "Big-endian UTF-16 BOM seen. Aborting parsing.\n"; $self->scream( @@ -130,7 +200,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) next; # TODO: implement somehow? - + } else { DEBUG > 2 and print STDERR "First line is BOM-less.\n"; ($line = $source_line) =~ tr/\n\r//d; @@ -144,8 +214,8 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) my $encoding; - # No =encoding line, and we are at the first line in the input that - # contains a non-ascii byte, that is one whose meaning varies depending + # No =encoding line, and we are at the first pod line in the input that + # contains a non-ascii byte, that is, one whose meaning varies depending # on whether the file is encoded in UTF-8 or CP1252, which are the two # possibilities permitted by the pod spec. (ASCII is assumed if the # file only contains ASCII bytes.) In order to process this line, we @@ -162,22 +232,28 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # without conflict. CP 1252 uses most of them for graphic characters. # # Note that all ASCII-range bytes represent their corresponding code - # points in CP1252 and UTF-8. In ASCII platform UTF-8 all other code - # points require multiple (non-ASCII) bytes to represent. (A separate - # paragraph for EBCDIC is below.) The multi-byte representation is - # quite structured. If we find an isolated byte that requires multiple - # bytes to represent in UTF-8, we know that the encoding is not UTF-8. - # If we find a sequence of bytes that violates the UTF-8 structure, we - # also can presume the encoding isn't UTF-8, and hence must be 1252. + # points in both CP1252 and UTF-8. In ASCII platform UTF-8, all other + # code points require multiple (non-ASCII) bytes to represent. (A + # separate paragraph for EBCDIC is below.) The multi-byte + # representation is quite structured. If we find an isolated byte that + # would require multiple bytes to represent in UTF-8, we know that the + # encoding is not UTF-8. If we find a sequence of bytes that violates + # the UTF-8 structure, we also can presume the encoding isn't UTF-8, and + # hence must be 1252. # # But there are ambiguous cases where we could guess wrong. If so, the # user will end up having to supply an =encoding line. We use all # readily available information to improve our chances of guessing # right. The odds of something not being UTF-8, but still passing a # UTF-8 validity test go down very rapidly with increasing length of the - # sequence. Therefore we look at all the maximal length non-ascii - # sequences on the line. If any of the sequences can't be UTF-8, we - # quit there and choose CP1252. If all could be UTF-8, we guess UTF-8. + # sequence. Therefore we look at all non-ascii sequences on the line. + # If any of the sequences can't be UTF-8, we quit there and choose + # CP1252. If all could be UTF-8, we see if any of the code points + # represented are unlikely to be in pod. If so, we guess CP1252. If + # not, we check if the line is all in the same script; if not guess + # CP1252; otherwise UTF-8. For perls that don't have convenient script + # run testing, see if there is both Latin and non-Latin. If so, CP1252, + # otherwise UTF-8. # # On EBCDIC platforms, the situation is somewhat different. In # UTF-EBCDIC, not only do ASCII-range bytes represent their code points, @@ -188,51 +264,188 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # very unlikely to be in pod text. So if we encounter one of them, it # means that it is quite likely CP1252 and not UTF-8. The net result is # the same code below is used for both platforms. - while ($line =~ m/($non_ascii_re+)/g) { - my $non_ascii_seq = $1; - - if (length $non_ascii_seq == 1) { - $encoding = 'CP1252'; - goto guessed; - } elsif ($] ge 5.007_003) { - - # On Perls that have this function, we can see if the sequence is - # valid UTF-8 or not. - my $is_utf8; - { - no warnings 'utf8'; - $is_utf8 = utf8::decode($non_ascii_seq); + # + # XXX probably if the line has E<foo> that evaluates to illegal CP1252, + # then it is UTF-8. But we haven't processed E<> yet. + + goto set_1252 if $] lt 5.006_000; # No UTF-8 on very early perls + + my $copy; + + no warnings 'utf8'; + + if ($] ge 5.007_003) { + $copy = $line; + + # On perls that have this function, we can use it to easily see if the + # sequence is valid UTF-8 or not; if valid it turns on the UTF-8 flag + # needed below for script run detection + goto set_1252 if ! utf8::decode($copy); + } + elsif (ord("A") != 65) { # Early EBCDIC, assume UTF-8. What's a windows + # code page doing here anyway? + goto set_utf8; + } + else { # ASCII, no decode(): do it ourselves using the fundamental + # characteristics of UTF-8 + use if $] le 5.006002, 'utf8'; + + my $char_ord; + my $needed; # How many continuation bytes to gobble up + + # Initialize the translated line with a dummy character that will be + # deleted after everything else is done. This dummy makes sure that + # $copy will be in UTF-8. Doing it now avoids the bugs in early perls + # with upgrading in the middle + $copy = chr(0x100); + + # Parse through the line + for (my $i = 0; $i < length $line; $i++) { + my $byte = substr($line, $i, 1); + + # ASCII bytes are trivially dealt with + if ($byte !~ $non_ascii_re) { + $copy .= $byte; + next; + } + + my $b_ord = ord $byte; + + # Now figure out what this code point would be if the input is + # actually in UTF-8. If, in the process, we discover that it isn't + # well-formed UTF-8, we guess CP1252. + # + # Start the process. If it is UTF-8, we are at the first, start + # byte, of a multi-byte sequence. We look at this byte to figure + # out how many continuation bytes are needed, and to initialize the + # code point accumulator with the data from this byte. + # + # Normally the minimum continuation byte is 0x80, but in certain + # instances the minimum is a higher number. So the code below + # overrides this for those instances. + my $min_cont = 0x80; + + if ($b_ord < 0xC2) { # A start byte < C2 is malformed + goto set_1252; + } + elsif ($b_ord <= 0xDF) { + $needed = 1; + $char_ord = $b_ord & 0x1F; } - if (! $is_utf8) { - $encoding = 'CP1252'; - goto guessed; + elsif ($b_ord <= 0xEF) { + $min_cont = 0xA0 if $b_ord == 0xE0; + $needed = 2; + $char_ord = $b_ord & (0x1F >> 1); } - } elsif (ord("A") == 65) { # An early Perl, ASCII platform - - # Without utf8::decode, it's a lot harder to do a rigorous check - # (though some early releases had a different function that - # accomplished the same thing). Since these are ancient Perls, not - # likely to be in use today, we take the easy way out, and look at - # just the first two bytes of the sequence to see if they are the - # start of a UTF-8 character. In ASCII UTF-8, continuation bytes - # must be between 0x80 and 0xBF. Start bytes can range from 0xC2 - # through 0xFF, but anything above 0xF4 is not Unicode, and hence - # extremely unlikely to be in a pod. - if ($non_ascii_seq !~ /^[\xC2-\xF4][\x80-\xBF]/) { - $encoding = 'CP1252'; - goto guessed; + elsif ($b_ord <= 0xF4) { + $min_cont = 0x90 if $b_ord == 0xF0; + $needed = 3; + $char_ord = $b_ord & (0x1F >> 2); + } + else { # F4 is the highest start byte for legal Unicode; higher is + # unlikely to be in pod. + goto set_1252; } - # We don't bother doing anything special for EBCDIC on early Perls. - # If there is a solitary variant, CP1252 will be chosen; otherwise - # UTF-8. - } - } # End of loop through all variant sequences on the line + # ? not enough continuation bytes available + goto set_1252 if $i + $needed >= length $line; + + # Accumulate the ordinal of the character from the remaining + # (continuation) bytes. + while ($needed-- > 0) { + my $cont = substr($line, ++$i, 1); + $b_ord = ord $cont; + goto set_1252 if $b_ord < $min_cont || $b_ord > 0xBF; + + # In all cases, any next continuation bytes all have the same + # minimum legal value + $min_cont = 0x80; + + # Accumulate this byte's contribution to the code point + $char_ord <<= 6; + $char_ord |= ($b_ord & 0x3F); + } + + # Here, the sequence that formed this code point was valid UTF-8, + # so add the completed character to the output + $copy .= chr $char_ord; + } # End of loop through line + + # Delete the dummy first character + $copy = substr($copy, 1); + } + + # Here, $copy is legal UTF-8. + + # If it can't be legal CP1252, no need to look further. (These bytes + # aren't valid in CP1252.) This test could have been placed higher in + # the code, but it seemed wrong to set the encoding to UTF-8 without + # making sure that the very first instance is well-formed. But what if + # it isn't legal CP1252 either? We have to choose one or the other, and + # It seems safer to favor the single-byte encoding over the multi-byte. + goto set_utf8 if ord("A") == 65 && $line =~ /[\x81\x8D\x8F\x90\x9D]/; + + # The C1 controls are not likely to appear in pod + goto set_1252 if ord("A") == 65 && $copy =~ /[\x80-\x9F]/; + + # Nor are surrogates nor unassigned, nor deprecated. + DEBUG > 8 and print STDERR __LINE__, ": $copy: surrogate\n" if $copy =~ $cs_re; + goto set_1252 if $cs_re && $copy =~ $cs_re; + DEBUG > 8 and print STDERR __LINE__, ": $copy: unassigned\n" if $cn_re && $copy =~ $cn_re; + goto set_1252 if $cn_re && $copy =~ $cn_re; + DEBUG > 8 and print STDERR __LINE__, ": $copy: deprecated\n" if $copy =~ $deprecated_re; + goto set_1252 if $copy =~ $deprecated_re; + + # Nor are rare code points. But this is hard to determine. khw + # believes that IPA characters and the modifier letters are unlikely to + # be in pod (and certainly very unlikely to be the in the first line in + # the pod containing non-ASCII) + DEBUG > 8 and print STDERR __LINE__, ": $copy: rare\n" if $copy =~ $rare_blocks_re; + goto set_1252 if $rare_blocks_re && $copy =~ $rare_blocks_re; + + # The first Unicode version included essentially every Latin character + # in modern usage. So, a Latin character not in the first release will + # unlikely be in pod. + DEBUG > 8 and print STDERR __LINE__, ": $copy: later_latin\n" if $later_latin_re && $copy =~ $later_latin_re; + goto set_1252 if $later_latin_re && $copy =~ $later_latin_re; + + # On perls that handle script runs, if the UTF-8 interpretation yields + # a single script, we guess UTF-8, otherwise just having a mixture of + # scripts is suspicious, so guess CP1252. We first strip off, as best + # we can, the ASCII characters that look like they are pod directives, + # as these would always show as mixed with non-Latin text. + $copy =~ s/$pod_chars_re//g; + + if ($script_run_re) { + goto set_utf8 if $copy =~ $script_run_re; + DEBUG > 8 and print STDERR __LINE__, ": not script run\n"; + goto set_1252; + } + + # Even without script runs, but on recent enough perls and Unicodes, we + # can check if there is a mixture of both Latin and non-Latin. Again, + # having a mixture of scripts is suspicious, so assume CP1252 + + # If it's all non-Latin, there is no CP1252, as that is Latin + # characters and punct, etc. + DEBUG > 8 and print STDERR __LINE__, ": $copy: not latin\n" if $copy !~ $latin_re; + goto set_utf8 if $copy !~ $latin_re; + + DEBUG > 8 and print STDERR __LINE__, ": $copy: all latin\n" if $copy =~ $every_char_is_latin_re; + goto set_utf8 if $copy =~ $every_char_is_latin_re; + + DEBUG > 8 and print STDERR __LINE__, ": $copy: mixed\n"; + + set_1252: + DEBUG > 9 and print STDERR __LINE__, ": $copy: is 1252\n"; + $encoding = 'CP1252'; + goto done_set; - # All sequences in the line could be UTF-8. Guess that. + set_utf8: + DEBUG > 9 and print STDERR __LINE__, ": $copy: is UTF-8\n"; $encoding = 'UTF-8'; - guessed: + done_set: $self->_handle_encoding_line( "=encoding $encoding" ); delete $self->{'_processed_encoding'}; $self->{'_transcoder'} && $self->{'_transcoder'}->($line); @@ -254,13 +467,13 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) $self->{'line_count'}, "=cut found outside a pod block. Skipping to next block." ); - + ## Before there were errata sections in the world, it was ## least-pessimal to abort processing the file. But now we can ## just barrel on thru (but still not start a pod block). #splice @_; #push @_, undef; - + next; } else { $self->{'in_pod'} = $self->{'start_of_pod_block'} @@ -273,7 +486,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) if $code_handler; # Note: this may cause code to be processed out of order relative # to pods, but in order relative to cuts. - + # Note also that we haven't yet applied the transcoding to $line # by time we call $code_handler! @@ -284,11 +497,11 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) DEBUG > 1 and print STDERR "# Setting nextline to $1\n"; $self->{'line_count'} = $1 - 1; } - + next; } } - + # . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . # Else we're in pod mode: @@ -308,12 +521,13 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) # ++$self->{'pod_para_count'}; $self->_ponder_paragraph_buffer(); # by now it's safe to consider the previous paragraph as done. + DEBUG > 6 and print STDERR "Processing any cut handler, line ${$self}{'line_count'}\n"; $cut_handler->(map $_, $line, $self->{'line_count'}, $self) if $cut_handler; # TODO: add to docs: Note: this may cause cuts to be processed out # of order relative to pods, but in order relative to code. - + } elsif($line =~ m/^(\s*)$/s) { # it's a blank line if (defined $1 and $1 =~ /[^\S\r\n]/) { # it's a white line $wl_handler->(map $_, $line, $self->{'line_count'}, $self) @@ -324,29 +538,30 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) DEBUG > 1 and print STDERR "Saving blank line at line ${$self}{'line_count'}\n"; push @{$paras->[-1]}, $line; } # otherwise it's not interesting - + if(!$self->{'start_of_pod_block'} and !$self->{'last_was_blank'}) { DEBUG > 1 and print STDERR "Noting para ends with blank line at ${$self}{'line_count'}\n"; } - + $self->{'last_was_blank'} = 1; - + } elsif($self->{'last_was_blank'}) { # A non-blank line starting a new para... - - if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(?:\s+|$)(.*)/s) { + + if($line =~ m/^(=[a-zA-Z][a-zA-Z0-9]*)(\s+|$)(.*)/s) { # THIS IS THE ONE PLACE WHERE WE CONSTRUCT NEW DIRECTIVE OBJECTS - my $new = [$1, {'start_line' => $self->{'line_count'}}, $2]; + my $new = [$1, {'start_line' => $self->{'line_count'}}, $3]; + $new->[1]{'~orig_spacer'} = $2 if $2 && $2 ne " "; # Note that in "=head1 foo", the WS is lost. # Example: ['=head1', {'start_line' => 123}, ' foo'] - + ++$self->{'pod_para_count'}; - + $self->_ponder_paragraph_buffer(); # by now it's safe to consider the previous paragraph as done. - + push @$paras, $new; # the new incipient paragraph DEBUG > 1 and print STDERR "Starting new ${$paras}[-1][0] para at line ${$self}{'line_count'}\n"; - + } elsif($line =~ m/^\s/s) { if(!$self->{'start_of_pod_block'} and @$paras and $paras->[-1][0] eq '~Verbatim') { @@ -379,7 +594,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) } $self->{'last_was_blank'} = $self->{'start_of_pod_block'} = 0; } - + } # ends the big while loop DEBUG > 1 and print STDERR (pretty(@$paras), "\n"); @@ -390,7 +605,7 @@ sub parse_lines { # Usage: $parser->parse_lines(@lines) sub _handle_encoding_line { my($self, $line) = @_; - + return if $self->parse_characters; # The point of this routine is to set $self->{'_transcoder'} as indicated. @@ -492,7 +707,7 @@ sub _handle_encoding_line { sub _handle_encoding_second_level { # By time this is called, the encoding (if well formed) will already - # have been acted one. + # have been acted on. my($self, $para) = @_; my @x = @$para; my $content = join ' ', splice @x, 2; @@ -500,7 +715,7 @@ sub _handle_encoding_second_level { $content =~ s/\s+$//s; DEBUG > 2 and print STDERR "Ogling encoding directive: =encoding $content\n"; - + if (defined($self->{'_processed_encoding'})) { #if($content ne $self->{'_processed_encoding'}) { # Could it happen? @@ -518,14 +733,14 @@ sub _handle_encoding_second_level { } else { DEBUG > 2 and print STDERR " (Yup, it was successfully handled already.)\n"; } - + } else { # Otherwise it's a syntax error $self->whine( $para->[1]{'start_line'}, "Invalid =encoding syntax: $content" ); } - + return; } @@ -542,7 +757,7 @@ sub _gen_errata { return() unless $self->{'errata'} and keys %{$self->{'errata'}}; my @out; - + foreach my $line (sort {$a <=> $b} keys %{$self->{'errata'}}) { push @out, ['=item', {'start_line' => $m}, "Around line $line:"], @@ -555,7 +770,7 @@ sub _gen_errata { ) ; } - + # TODO: report of unknown entities? unrenderable characters? unshift @out, @@ -569,7 +784,7 @@ sub _gen_errata { ['=over', {'start_line' => $m, 'errata' => 1}, ''], ; - push @out, + push @out, ['=back', {'start_line' => $m, 'errata' => 1}, ''], ; @@ -610,7 +825,7 @@ sub _ponder_paragraph_buffer { # Document, # Data, Para, Verbatim # B, C, longdirname (TODO -- wha?), etc. for all directives - # + # my $self = $_[0]; my $paras; @@ -624,11 +839,11 @@ sub _ponder_paragraph_buffer { # We have something in our buffer. So apparently the document has started. unless($self->{'doc_has_started'}) { $self->{'doc_has_started'} = 1; - + my $starting_contentless; $starting_contentless = ( - !@$curr_open + !@$curr_open and @$paras and ! grep $_->[0] ne '~end', @$paras # i.e., if the paras is all ~ends ) @@ -637,7 +852,7 @@ sub _ponder_paragraph_buffer { $starting_contentless ? 'contentless' : 'contentful', " document\n" ; - + $self->_handle_element_start( ($scratch = 'Document'), { @@ -649,15 +864,32 @@ sub _ponder_paragraph_buffer { my($para, $para_type); while(@$paras) { - last if @$paras == 1 and - ( $paras->[0][0] eq '=over' or $paras->[0][0] eq '~Verbatim' - or $paras->[0][0] eq '=item' ) - ; + + # If a directive, assume it's legal; subtract below if found not to be + $seen_legal_directive++ if $paras->[0][0] =~ /^=/; + + last if @$paras == 1 + and ( $paras->[0][0] eq '=over' + or $paras->[0][0] eq '=item' + or ($paras->[0][0] eq '~Verbatim' and $self->{'in_pod'})); # Those're the three kinds of paragraphs that require lookahead. # Actually, an "=item Foo" inside an <over type=text> region # and any =item inside an <over type=block> region (rare) # don't require any lookahead, but all others (bullets # and numbers) do. + # The verbatim is different from the other two, because those might be + # like: + # + # =item + # ... + # =cut + # ... + # =item + # + # The =cut here finishes the paragraph but doesn't terminate the =over + # they should be in. (khw apologizes that he didn't comment at the time + # why the 'in_pod' works, and no longer remembers why, and doesn't think + # it is currently worth the effort to re-figure it out.) # TODO: whinge about many kinds of directives in non-resolving =for regions? # TODO: many? like what? =head1 etc? @@ -667,7 +899,7 @@ sub _ponder_paragraph_buffer { DEBUG > 1 and print STDERR "Pondering a $para_type paragraph, given the stack: (", $self->_dump_curr_open(), ")\n"; - + if($para_type eq '=for') { next if $self->_ponder_for($para,$curr_open,$paras); @@ -704,7 +936,7 @@ sub _ponder_paragraph_buffer { } else { # All non-magical codes!!! - + # Here we start using $para_type for our own twisted purposes, to # mean how it should get treated, not as what the element name # should be. @@ -744,10 +976,10 @@ sub _ponder_paragraph_buffer { ; next; } - - + + my $over_type = $over->[1]{'~type'}; - + if(!$over_type) { # Shouldn't happen1 die "Typeless over in stack, starting at line " @@ -772,7 +1004,7 @@ sub _ponder_paragraph_buffer { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'text') { # Nothing special needs doing for 'text' } elsif($item_type eq 'number' or $item_type eq 'bullet') { @@ -788,16 +1020,16 @@ sub _ponder_paragraph_buffer { } else { die "Unhandled item type $item_type"; # should never happen } - + # =item-text thingies don't need any assimilation, it seems. } elsif($over_type eq 'number') { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; - + if($item_type eq 'bullet') { # Hm, it's not numeric. Correct for this. $para->[1]{'number'} = $expected_value; @@ -822,7 +1054,7 @@ sub _ponder_paragraph_buffer { } elsif($expected_value == $para->[1]{'number'}) { DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; - + } else { DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, " instead of the expected value of $expected_value\n"; @@ -833,7 +1065,7 @@ sub _ponder_paragraph_buffer { ); $para->[1]{'number'} = $expected_value; # correcting!! } - + if(@$para == 2) { # For the cases where we /didn't/ push to @$para if($paras->[0][0] eq '~Para') { @@ -850,13 +1082,13 @@ sub _ponder_paragraph_buffer { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'bullet') { # as expected! if( $para->[1]{'~_freaky_para_hack'} ) { DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; - push @$para, delete $para->[1]{'~_freaky_para_hack'}; + push @$para, $para->[1]{'~_freaky_para_hack'}; } } elsif($item_type eq 'number') { @@ -925,6 +1157,7 @@ sub _ponder_paragraph_buffer { DEBUG > 1 and print STDERR " Pondering known directive ${$para}[0] as $para_type\n"; } else { # An unknown directive! + $seen_legal_directive--; DEBUG > 1 and printf STDERR "Unhandled directive %s (Handled: %s)\n", $para->[0], join(' ', sort keys %{$self->{'accept_directives'}} ) ; @@ -944,15 +1177,15 @@ sub _ponder_paragraph_buffer { my @fors = grep $_->[0] eq '=for', @$curr_open; DEBUG > 1 and print STDERR "Containing fors: ", join(',', map $_->[1]{'target'}, @fors), "\n"; - + if(! @fors) { DEBUG and print STDERR "Treating $para_type paragraph as such because stack has no =for's\n"; - + #} elsif(grep $_->[1]{'~resolve'}, @fors) { #} elsif(not grep !$_->[1]{'~resolve'}, @fors) { } elsif( $fors[-1][1]{'~resolve'} ) { # Look to the immediately containing for - + if($para_type eq 'Data') { DEBUG and print STDERR "Treating Data paragraph as Plain/Verbatim because the containing =for ($fors[-1][1]{'target'}) is a resolver\n"; $para->[0] = 'Para'; @@ -971,7 +1204,7 @@ sub _ponder_paragraph_buffer { if($para_type eq 'Plain') { $self->_ponder_Plain($para); } elsif($para_type eq 'Verbatim') { - $self->_ponder_Verbatim($para); + $self->_ponder_Verbatim($para); } elsif($para_type eq 'Data') { $self->_ponder_Data($para); } else { @@ -985,11 +1218,12 @@ sub _ponder_paragraph_buffer { DEBUG and print STDERR "\n", pretty($para), "\n"; # traverse the treelet (which might well be just one string scalar) - $self->{'content_seen'} ||= 1; + $self->{'content_seen'} ||= 1 if $seen_legal_directive + && ! $self->{'~tried_gen_errata'}; $self->_traverse_treelet_bit(@$para); } } - + return; } @@ -1024,9 +1258,9 @@ sub _ponder_for { } DEBUG > 1 and print STDERR "Faking out a =for $target as a =begin $target / =end $target\n"; - + $para->[0] = 'Data'; - + unshift @$paras, ['=begin', {'start_line' => $para->[1]{'start_line'}, '~really' => '=for'}, @@ -1038,7 +1272,7 @@ sub _ponder_for { $target, ], ; - + return 1; } @@ -1055,20 +1289,20 @@ sub _ponder_begin { DEBUG and print STDERR "Ignoring targetless =begin\n"; return 1; } - + my ($target, $title) = $content =~ m/^(\S+)\s*(.*)$/; $para->[1]{'title'} = $title if ($title); $para->[1]{'target'} = $target; # without any ':' $content = $target; # strip off the title - + $content =~ s/^:!/!:/s; my $neg; # whether this is a negation-match $neg = 1 if $content =~ s/^!//s; my $to_resolve; # whether to process formatting codes $to_resolve = 1 if $content =~ s/^://s; - + my $dont_ignore; # whether this target matches us - + foreach my $target_name ( split(',', $content, -1), $neg ? () : '*' @@ -1076,7 +1310,7 @@ sub _ponder_begin { DEBUG > 2 and print STDERR " Considering whether =begin $content matches $target_name\n"; next unless $self->{'accept_targets'}{$target_name}; - + DEBUG > 2 and print STDERR " It DOES match the acceptable target $target_name!\n"; $to_resolve = 1 @@ -1113,7 +1347,7 @@ sub _ponder_begin { if(!$dont_ignore or scalar grep $_->[1]{'~ignore'}, @$curr_open) { DEBUG > 1 and print STDERR "Ignoring ignorable =begin\n"; } else { - $self->{'content_seen'} ||= 1; + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_start((my $scratch='for'), $para->[1]); } @@ -1139,7 +1373,7 @@ sub _ponder_end { DEBUG and print STDERR "Ignoring targetless =end\n"; return 1; } - + unless($content =~ m/^\S+$/) { # i.e., unless it's one word $self->whine( $para->[1]{'start_line'}, @@ -1149,7 +1383,7 @@ sub _ponder_end { DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; return 1; } - + unless(@$curr_open and $curr_open->[-1][0] eq '=for') { $self->whine( $para->[1]{'start_line'}, @@ -1159,11 +1393,11 @@ sub _ponder_end { DEBUG and print STDERR "Ignoring mistargetted =end $content\n"; return 1; } - + unless($content eq $curr_open->[-1][1]{'target'}) { $self->whine( $para->[1]{'start_line'}, - "=end $content doesn't match =begin " + "=end $content doesn't match =begin " . $curr_open->[-1][1]{'target'} . ". (Stack: " . $self->_dump_curr_open() . ')' @@ -1180,22 +1414,22 @@ sub _ponder_end { } else { $curr_open->[-1][1]{'start_line'} = $para->[1]{'start_line'}; # what's that for? - - $self->{'content_seen'} ||= 1; + + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_end( my $scratch = 'for', $para->[1]); } DEBUG > 1 and print STDERR "Popping $curr_open->[-1][0] $curr_open->[-1][1]{'target'} because of =end $content\n"; pop @$curr_open; return 1; -} +} sub _ponder_doc_end { my ($self,$para,$curr_open,$paras) = @_; if(@$curr_open) { # Deal with things left open DEBUG and print STDERR "Stack is nonempty at end-document: (", $self->_dump_curr_open(), ")\n"; - + DEBUG > 9 and print STDERR "Stack: ", pretty($curr_open), "\n"; unshift @$paras, $self->_closers_for_all_curr_open; # Make sure there is exactly one ~end in the parastack, at the end: @@ -1205,11 +1439,11 @@ sub _ponder_doc_end { # generate errata, and then another to be at the end # when that loop back around to process the errata. return 1; - + } else { DEBUG and print STDERR "Okay, stack is empty now.\n"; } - + # Try generating errata section, if applicable unless($self->{'~tried_gen_errata'}) { $self->{'~tried_gen_errata'} = 1; @@ -1220,7 +1454,7 @@ sub _ponder_doc_end { return 1; # I.e., loop around again to process these fake-o paragraphs } } - + splice @$paras; # Well, that's that for this paragraph buffer. DEBUG and print STDERR "Throwing end-document event.\n"; @@ -1245,7 +1479,7 @@ sub _ponder_pod { # The surrounding methods set content_seen, so let us remain consistent. # I do not know why it was not here before -- should it not be here? - # $self->{'content_seen'} ||= 1; + # $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; return; } @@ -1278,8 +1512,9 @@ sub _ponder_over { $para->[1]{'~type'} = $list_type; push @$curr_open, $para; # yes, we reuse the paragraph as a stack item - + my $content = join ' ', splice @$para, 2; + $para->[1]{'~orig_content'} = $content; my $overness; if($content =~ m/^\s*$/s) { $para->[1]{'indent'} = 4; @@ -1301,13 +1536,13 @@ sub _ponder_over { $para->[1]{'indent'} = 4; } DEBUG > 1 and print STDERR "=over found of type $list_type\n"; - - $self->{'content_seen'} ||= 1; + + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_start((my $scratch = 'over-' . $list_type), $para->[1]); return; } - + sub _ponder_back { my ($self,$para,$curr_open,$paras) = @_; # TODO: fire off </item-number> or </item-bullet> or </item-text> ?? @@ -1324,7 +1559,7 @@ sub _ponder_back { DEBUG > 1 and print STDERR "=back happily closes matching =over\n"; # Expected case: we're closing the most recently opened thing #my $over = pop @$curr_open; - $self->{'content_seen'} ||= 1; + $self->{'content_seen'} ||= 1 unless $self->{'~tried_gen_errata'}; $self->_handle_element_end( my $scratch = 'over-' . ( (pop @$curr_open)->[1]{'~type'} ), $para->[1] ); @@ -1354,10 +1589,10 @@ sub _ponder_item { ; return 1; } - - + + my $over_type = $over->[1]{'~type'}; - + if(!$over_type) { # Shouldn't happen1 die "Typeless over in stack, starting at line " @@ -1382,7 +1617,7 @@ sub _ponder_item { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'text') { # Nothing special needs doing for 'text' } elsif($item_type eq 'number' or $item_type eq 'bullet') { @@ -1398,16 +1633,16 @@ sub _ponder_item { } else { die "Unhandled item type $item_type"; # should never happen } - + # =item-text thingies don't need any assimilation, it seems. } elsif($over_type eq 'number') { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + my $expected_value = ++ $curr_open->[-1][1]{'~counter'}; - + if($item_type eq 'bullet') { # Hm, it's not numeric. Correct for this. $para->[1]{'number'} = $expected_value; @@ -1432,7 +1667,7 @@ sub _ponder_item { } elsif($expected_value == $para->[1]{'number'}) { DEBUG > 1 and print STDERR " Numeric item has the expected value of $expected_value\n"; - + } else { DEBUG > 1 and print STDERR " Numeric item has ", $para->[1]{'number'}, " instead of the expected value of $expected_value\n"; @@ -1443,7 +1678,7 @@ sub _ponder_item { ); $para->[1]{'number'} = $expected_value; # correcting!! } - + if(@$para == 2) { # For the cases where we /didn't/ push to @$para if($paras->[0][0] eq '~Para') { @@ -1460,13 +1695,13 @@ sub _ponder_item { my $item_type = $self->_get_item_type($para); # That kills the content of the item if it's a number or bullet. DEBUG and print STDERR " Item is of type ", $para->[0], " under $over_type\n"; - + if($item_type eq 'bullet') { # as expected! if( $para->[1]{'~_freaky_para_hack'} ) { DEBUG and print STDERR "Accomodating '=item * Foo' tolerance hack.\n"; - push @$para, delete $para->[1]{'~_freaky_para_hack'}; + push @$para, $para->[1]{'~_freaky_para_hack'}; } } elsif($item_type eq 'number') { @@ -1533,30 +1768,44 @@ sub _ponder_Verbatim { $para->[1]{'xml:space'} = 'preserve'; - my $indent = $self->strip_verbatim_indent; - if ($indent && ref $indent eq 'CODE') { - my @shifted = (shift @{$para}, shift @{$para}); - $indent = $indent->($para); - unshift @{$para}, @shifted; - } - - for(my $i = 2; $i < @$para; $i++) { - foreach my $line ($para->[$i]) { # just for aliasing - # Strip indentation. - $line =~ s/^\Q$indent// if $indent - && !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted}); - while( $line =~ - # Sort of adapted from Text::Tabs -- yes, it's hardwired in that - # tabs are at every EIGHTH column. For portability, it has to be - # one setting everywhere, and 8th wins. - s/^([^\t]*)(\t+)/$1.(" " x ((length($2)<<3)-(length($1)&7)))/e - ) {} + unless ($self->{'_output_is_for_JustPod'}) { + # Fix illegal settings for expand_verbatim_tabs() + # This is because this module doesn't do input error checking, but khw + # doesn't want to add yet another instance of that. + $self->expand_verbatim_tabs(8) + if ! defined $self->expand_verbatim_tabs() + || $self->expand_verbatim_tabs() =~ /\D/; + + my $indent = $self->strip_verbatim_indent; + if ($indent && ref $indent eq 'CODE') { + my @shifted = (shift @{$para}, shift @{$para}); + $indent = $indent->($para); + unshift @{$para}, @shifted; + } - # TODO: whinge about (or otherwise treat) unindented or overlong lines + for(my $i = 2; $i < @$para; $i++) { + foreach my $line ($para->[$i]) { # just for aliasing + # Strip indentation. + $line =~ s/^\Q$indent// if $indent; + next unless $self->expand_verbatim_tabs; + + # This is commented out because of github issue #85, and the + # current maintainers don't know why it was there in the first + # place. + #&& !($self->{accept_codes} && $self->{accept_codes}{VerbatimFormatted}); + while( $line =~ + # Sort of adapted from Text::Tabs. + s/^([^\t]*)(\t+)/$1.(" " x ((length($2) + * $self->expand_verbatim_tabs) + -(length($1)&7)))/e + ) {} + + # TODO: whinge about (or otherwise treat) unindented or overlong lines + } } } - + # Now the VerbatimFormatted hoodoo... if( $self->{'accept_codes'} and $self->{'accept_codes'}{'VerbatimFormatted'} @@ -1596,7 +1845,7 @@ sub _traverse_treelet_bit { # for use only by the routine above my $scratch; $self->_handle_element_start(($scratch=$name), shift @_); - + while (@_) { my $x = shift; if (ref($x)) { @@ -1606,7 +1855,7 @@ sub _traverse_treelet_bit { # for use only by the routine above $self->_handle_text($x); } } - + $self->_handle_element_end($scratch=$name); return; } @@ -1651,7 +1900,7 @@ sub _closers_for_all_curr_open { sub _verbatim_format { my($it, $p) = @_; - + my $formatting; for(my $i = 2; $i < @$p; $i++) { # work backwards over the lines @@ -1659,7 +1908,7 @@ sub _verbatim_format { $p->[$i] .= "\n"; # Unlike with simple Verbatim blocks, we don't end up just doing # a join("\n", ...) on the contents, so we have to append a - # newline to ever line, and then nix the last one later. + # newline to every line, and then nix the last one later. } if( DEBUG > 4 ) { @@ -1672,7 +1921,7 @@ sub _verbatim_format { for(my $i = $#$p; $i > 2; $i--) { # work backwards over the lines, except the first (#2) - + #next unless $p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s # and $p->[$i-1] !~ m{^#:[ \^\/\%]*\n?$}s; # look at a formatty line preceding a nonformatty one @@ -1680,7 +1929,7 @@ sub _verbatim_format { if($p->[$i] =~ m{^#:([ \^\/\%]*)\n?$}s) { DEBUG > 5 and print STDERR " It's a formatty line. ", "Peeking at previous line ", $i-1, ": $$p[$i-1]: \n"; - + if( $p->[$i-1] =~ m{^#:[ \^\/\%]*\n?$}s ) { DEBUG > 5 and print STDERR " Previous line is formatty! Skipping this one.\n"; next; @@ -1696,11 +1945,11 @@ sub _verbatim_format { # "^" to mean bold, "/" to mean underline, and "%" to mean bold italic. # Example: # What do you want? i like pie. [or whatever] - # #:^^^^^^^^^^^^^^^^^ ///////////// - + # #:^^^^^^^^^^^^^^^^^ ///////////// + DEBUG > 4 and print STDERR "_verbatim_format considers:\n<$p->[$i-1]>\n<$p->[$i]>\n"; - + $formatting = ' ' . $1; $formatting =~ s/\s+$//s; # nix trailing whitespace unless(length $formatting and $p->[$i-1] =~ m/\S/) { # no-op @@ -1716,7 +1965,7 @@ sub _verbatim_format { } # Make $formatting and the previous line be exactly the same length, # with $formatting having a " " as the last character. - + DEBUG > 4 and print STDERR "Formatting <$formatting> on <", $p->[$i-1], ">\n"; @@ -1741,10 +1990,10 @@ sub _verbatim_format { #print STDERR "Formatting <$new_line[-1][-1]> as $new_line[-1][0]\n"; } } - my @nixed = + my @nixed = splice @$p, $i-1, 2, @new_line; # replace myself and the next line DEBUG > 10 and print STDERR "Nixed count: ", scalar(@nixed), "\n"; - + DEBUG > 6 and print STDERR "New version of the above line is these tokens (", scalar(@new_line), "):", map( ref($_)?"<@$_> ":"<$_>", @new_line ), "\n"; @@ -1791,29 +2040,46 @@ sub _treelet_from_formatting_codes { # [ 'B', {}, "pie" ], # "!" # ] - + # This illustrates the general format of a treelet. It is an array: + # [0] is a scalar indicating its type. In the example above, the + # types are '~Top' and 'B' + # [1] is a hash of various flags about it, possibly empty + # [2] - [N] are an ordered list of the subcomponents of the treelet. + # Scalars are literal text, refs are sub-treelets, to + # arbitrary levels. Stringifying a treelet will recursively + # stringify the sub-treelets, concatentating everything + # together to form the exact text of the treelet. + my($self, $para, $start_line, $preserve_space) = @_; - + my $treelet = ['~Top', {'start_line' => $start_line},]; - + unless ($preserve_space || $self->{'preserve_whitespace'}) { $para =~ s/\s+/ /g; # collapse and trim all whitespace first. $para =~ s/ $//; $para =~ s/^ //; } - + # Only apparent problem the above code is that N<< >> turns into # N<< >>. But then, word wrapping does that too! So don't do that! - + + + # As a Start-code is encountered, the number of opening bracket '<' + # characters minus 1 is pushed onto @stack (so 0 means a single bracket, + # etc). When closing brackets are found in the text, at least this number + # (plus the 1) will be required to mean the Start-code is terminated. When + # those are found, @stack is popped. my @stack; + my @lineage = ($treelet); my $raw = ''; # raw content of L<> fcode before splitting/processing # XXX 'raw' is not 100% accurate: all surrounding whitespace is condensed - # into just 1 ' '. Is this the regex's doing or 'raw's? + # into just 1 ' '. Is this the regex's doing or 'raw's? Answer is it's + # the 'collapse and trim all whitespace first' lines just above. my $inL = 0; DEBUG > 4 and print STDERR "Paragraph:\n$para\n\n"; - + # Here begins our frightening tokenizer RE. The following regex matches # text in four main parts: # @@ -1846,7 +2112,11 @@ sub _treelet_from_formatting_codes { | # Match multiple-bracket end codes. $3 gets the whitespace that # should be discarded before an end bracket but kept in other cases - # and $4 gets the end brackets themselves. + # and $4 gets the end brackets themselves. ($3 can be empty if the + # construct is empty, like C<< >>, and all the white-space has been + # gobbled up already, considered to be space after the opening + # bracket. In this case we use look-behind to verify that there are + # at least 2 spaces in a row before the ">".) (\s+|(?<=\s\s))(>{2,}) | (\s?>) # $5: simple end-codes @@ -1872,23 +2142,48 @@ sub _treelet_from_formatting_codes { ) { DEBUG > 4 and print STDERR "\nParagraphic tokenstack = (@stack)\n"; if(defined $1) { + my $bracket_count; # How many '<<<' in a row this has. Needed for + # Pod::Simple::JustPod if(defined $2) { DEBUG > 3 and print STDERR "Found complex start-text code \"$1\"\n"; - push @stack, length($2) + 1; - # length of the necessary complex end-code string + $bracket_count = length($2) + 1; + push @stack, $bracket_count; # length of the necessary complex + # end-code string } else { DEBUG > 3 and print STDERR "Found simple start-text code \"$1\"\n"; push @stack, 0; # signal that we're looking for simple + $bracket_count = 1; } - push @lineage, [ substr($1,0,1), {}, ]; # new node object - push @{ $lineage[-2] }, $lineage[-1]; - if ('L' eq substr($1,0,1)) { - $raw = $inL ? $raw.$1 : ''; # reset raw content accumulator - $inL = 1; + my $code = substr($1,0,1); + if ('L' eq $code) { + if ($inL) { + $raw .= $1; + $self->scream( $start_line, + 'Nested L<> are illegal. Pretending inner one is ' + . 'X<...> so can continue looking for other errors.'); + $code = "X"; + } + else { + $raw = ""; # reset raw content accumulator + $inL = @stack; + } } else { $raw .= $1 if $inL; } - + push @lineage, [ $code, {}, ]; # new node object + + # Tell Pod::Simple::JustPod how many brackets there were, but to save + # space, not in the most usual case of there was just 1. It can be + # inferred by the absence of this element. Similarly, if there is more + # than one bracket, extract the white space between the final bracket + # and the real beginning of the interior. Save that if it isn't just a + # single space + if ($self->{'_output_is_for_JustPod'} && $bracket_count > 1) { + $lineage[-1][1]{'~bracket_count'} = $bracket_count; + my $lspacer = substr($1, 1 + $bracket_count); + $lineage[-1][1]{'~lspacer'} = $lspacer if $lspacer ne " "; + } + push @{ $lineage[-2] }, $lineage[-1]; } elsif(defined $4) { DEBUG > 3 and print STDERR "Found apparent complex end-text code \"$3$4\"\n"; # This is where it gets messy... @@ -1917,20 +2212,35 @@ sub _treelet_from_formatting_codes { } #print STDERR "\nHOOBOY ", scalar(@{$lineage[-1]}), "!!!\n"; + if ($3 ne " " && $self->{'_output_is_for_JustPod'}) { + if ($3 ne "") { + $lineage[-1][1]{'~rspacer'} = $3; + } + elsif ($lineage[-1][1]{'~lspacer'} eq " ") { + + # Here we had something like C<< >> which was a false positive + delete $lineage[-1][1]{'~lspacer'}; + } + else { + $lineage[-1][1]{'~rspacer'} + = substr($lineage[-1][1]{'~lspacer'}, -1, 1); + chop $lineage[-1][1]{'~lspacer'}; + } + } + push @{ $lineage[-1] }, '' if 2 == @{ $lineage[-1] }; # Keep the element from being childless - - pop @stack; - pop @lineage; - unless (@stack) { # not in an L if there are no open fcodes + if ($inL == @stack) { + $lineage[-1][1]{'raw'} = $raw; $inL = 0; - if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') { - $lineage[-1][-1][1]{'raw'} = $raw - } } + + pop @stack; + pop @lineage; + $raw .= $3.$4 if $inL; - + } elsif(defined $5) { DEBUG > 3 and print STDERR "Found apparent simple end-text code \"$5\"\n"; @@ -1944,6 +2254,11 @@ sub _treelet_from_formatting_codes { push @{ $lineage[-1] }, ''; # keep it from being really childless } + if ($inL == @stack) { + $lineage[-1][1]{'raw'} = $raw; + $inL = 0; + } + pop @stack; pop @lineage; } else { @@ -1951,12 +2266,6 @@ sub _treelet_from_formatting_codes { push @{ $lineage[-1] }, $5; } - unless (@stack) { # not in an L if there are no open fcodes - $inL = 0; - if (ref $lineage[-1][-1] && $lineage[-1][-1][0] eq 'L') { - $lineage[-1][-1][1]{'raw'} = $raw - } - } $raw .= $5 if $inL; } elsif(defined $6) { @@ -1965,6 +2274,7 @@ sub _treelet_from_formatting_codes { $raw .= $6 if $inL; # XXX does not capture multiplace whitespaces -- 'raw' ends up with # at most 1 leading/trailing whitespace, why not all of it? + # Answer, because we deliberately trimmed it above } else { # should never ever ever ever happen @@ -2095,7 +2405,7 @@ sub pretty { # adopted from Class::Classless # letters, but I don't know if it has always worked without bugs. It # seemed safest just to list the characters. # s<([^\x20\x21\x23\x27-\x3F\x41-\x5B\x5D-\x7E])> - s<([^ !#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])> + s<([^ !"#'()*+,\-./0123456789:;\<=\>?ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\]^_`abcdefghijklmnopqrstuvwxyz{|}~])> <$pretty_form{$1} || '\\x{'.sprintf("%x", ord($1)).'}'>eg; #<$pretty_form{$1} || '\\x'.(unpack("H2",$1))>eg; qq{"$_"}; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm index 83415f8e25e..2fef0305a5c 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Checker.pm @@ -9,7 +9,7 @@ use Carp (); use Pod::Simple::Methody (); use Pod::Simple (); use vars qw( @ISA $VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG @@ -88,8 +88,10 @@ sub end_item_text { $_[0]->emit_par(-2) } sub emit_par { return unless $_[0]{'Errata_seen'}; my($self, $tweak_indent) = splice(@_,0,2); - my $indent = ' ' x ( 2 * $self->{'Indent'} + ($tweak_indent||0) ); + my $length = 2 * $self->{'Indent'} + ($tweak_indent||0); + my $indent = ' ' x ($length > 0 ? $length : 0); # Yes, 'STRING' x NEGATIVE gives '', same as 'STRING' x 0 + # 'Negative repeat count does nothing' since 5.22 $self->{'Thispara'} =~ s/$Pod::Simple::shy//g; my $out = Text::Wrap::wrap($indent, $indent, $self->{'Thispara'} .= "\n"); diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm index 428cc723594..aaa5a887e6b 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Debug.pm @@ -2,7 +2,7 @@ require 5; package Pod::Simple::Debug; use strict; use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; sub import { my($value,$variable); diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm index 71bef5070be..bade6fcc472 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsText.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::DumpAsText; -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm index 9d84878cb78..6f0b7b18621 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/DumpAsXML.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::DumpAsXML; -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm index 9cdbed217e5..0219b979100 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTML.pm @@ -9,7 +9,7 @@ use vars qw( $Doctype_decl $Content_decl ); @ISA = ('Pod::Simple::PullParser'); -$VERSION = '3.35'; +$VERSION = '3.40'; BEGIN { if(defined &DEBUG) { } # no-op elsif( defined &Pod::Simple::DEBUG ) { *DEBUG = \&Pod::Simple::DEBUG } @@ -29,7 +29,7 @@ $LamePad = '' unless defined $LamePad; $Linearization_Limit = 120 unless defined $Linearization_Limit; # headings/items longer than that won't get an <a name="..."> -$Perldoc_URL_Prefix = 'http://search.cpan.org/perldoc?' +$Perldoc_URL_Prefix = 'https://metacpan.org/pod/' unless defined $Perldoc_URL_Prefix; $Perldoc_URL_Postfix = '' unless defined $Perldoc_URL_Postfix; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm index 661266d0de4..227d6d3af0d 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/HTMLBatch.pm @@ -5,7 +5,7 @@ use strict; use vars qw( $VERSION $HTML_RENDER_CLASS $HTML_EXTENSION $CSS $JAVASCRIPT $SLEEPY $SEARCH_CLASS @ISA ); -$VERSION = '3.35'; +$VERSION = '3.40'; @ISA = (); # Yup, we're NOT a subclass of Pod::Simple::HTML! # TODO: nocontents stylesheets. Strike some of the color variations? @@ -720,22 +720,21 @@ sub _gen_css_wad { } # Now a few indexless variations: - foreach my $variation ( - 'blkbluw', # black_with_blue_on_white - 'whtpurk', # white_with_purple_on_black - 'whtgrng', # white_with_green_on_grey - 'grygrnw', # grey_with_green_on_white - ) { - my $outname = $variation; + for (my ($outfile, $variation) = each %{{ + blkbluw => 'black_with_blue_on_white', + whtpurk => 'white_with_purple_on_black', + whtgrng => 'white_with_green_on_grey', + grygrnw => 'grey_with_green_on_white', + }}) { my $this_css = join "\n", - "/* This file is autogenerated. Do not edit. $outname */\n", + "/* This file is autogenerated. Do not edit. $outfile */\n", "\@import url(\"./_$variation.css\");", ".indexgroup { display: none; }", "\n", ; - my $name = $outname; + my $name = $outfile; $name =~ tr/-_/ /; - $self->add_css( "_$outname.css", 0, $name, 0, 0, \$this_css); + $self->add_css( "_$outfile.css", 0, $name, 0, 0, \$this_css); } return; @@ -1110,12 +1109,15 @@ Example: =item $batchconv = Pod::Simple::HTMLBatch->new; -This TODO - +This creates a new batch converter. The method doesn't take parameters. +To change the converter's attributes, use the L<"/ACCESSOR METHODS"> +below. =item $batchconv->batch_convert( I<indirs>, I<outdir> ); -this TODO +This searches the directories given in I<indirs> and writes +HTML files for each of these to a corresponding directory +in I<outdir>. The directory I<outdir> must exist. =item $batchconv->batch_convert( undef , ...); diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm index 04612f202e9..b9ca19cdf93 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/LinkSection.pm @@ -2,13 +2,11 @@ require 5; package Pod::Simple::LinkSection; # Based somewhat dimly on Array::Autojoin -use vars qw($VERSION ); -$VERSION = '3.35'; use strict; use Pod::Simple::BlackBox; use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; use overload( # So it'll stringify nice '""' => \&Pod::Simple::BlackBox::stringify_lol, diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm index 67b87067416..5bcee54d4f7 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Methody.pm @@ -4,7 +4,7 @@ package Pod::Simple::Methody; use strict; use Pod::Simple (); use vars qw(@ISA $VERSION); -$VERSION = '3.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple'); # Yes, we could use named variables, but I want this to be impose diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm index 0c18a5b37d6..3d6f4031125 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Progress.pm @@ -1,7 +1,7 @@ require 5; package Pod::Simple::Progress; -$VERSION = '3.35'; +$VERSION = '3.40'; use strict; # Objects of this class are used for noting progress of an diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm index 7c326ec6aee..ceeb3f92504 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParser.pm @@ -1,6 +1,6 @@ require 5; package Pod::Simple::PullParser; -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple (); BEGIN {@ISA = ('Pod::Simple')} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm index d3066a8e87c..d9ebdcbcf0e 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserEndToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.35'; +$VERSION = '3.40'; sub new { # Class->new(tagname); my $class = shift; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm index d938e0adb21..61608fb466c 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserStartToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.35'; +$VERSION = '3.40'; sub new { # Class->new(tagname, optional_attrhash); my $class = shift; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm index a11ce0fd92d..c8247a081e7 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserTextToken.pm @@ -5,7 +5,7 @@ use Pod::Simple::PullParserToken (); use strict; use vars qw(@ISA $VERSION); @ISA = ('Pod::Simple::PullParserToken'); -$VERSION = '3.35'; +$VERSION = '3.40'; sub new { # Class->new(text); my $class = shift; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm index c6618168e6b..f14b5637cd4 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/PullParserToken.pm @@ -3,7 +3,7 @@ require 5; package Pod::Simple::PullParserToken; # Base class for tokens gotten from Pod::Simple::PullParser's $parser->get_token @ISA = (); -$VERSION = '3.35'; +$VERSION = '3.40'; use strict; sub new { # Class->new('type', stuff...); ## Overridden in derived classes anyway diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm index 153c3d3e287..ed0de149ae0 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/RTF.pm @@ -8,24 +8,67 @@ package Pod::Simple::RTF; use strict; use vars qw($VERSION @ISA %Escape $WRAP %Tagmap); -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple::PullParser (); BEGIN {@ISA = ('Pod::Simple::PullParser')} use Carp (); BEGIN { *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG } +sub to_uni ($) { # Convert native code point to Unicode + my $x = shift; + + # Broken for early EBCDICs + $x = chr utf8::native_to_unicode(ord $x) if $] ge 5.007_003 + && ord("A") != 65; + return $x; +} + +# We escape out 'F' so that we can send RTF files thru the mail without the +# slightest worry that paragraphs beginning with "From" will get munged. +# We also escape '\', '{', '}', and '_' +my $map_to_self = ' !"#$%&\'()*+,-./0123456789:;<=>?@ABCDEGHIJKLMNOPQRSTUVWXYZ[]^`abcdefghijklmnopqrstuvwxyz|~'; + $WRAP = 1 unless defined $WRAP; +%Escape = ( + + # Start with every character mapping to its hex equivalent + map( (chr($_) => sprintf("\\'%02x", $_)), 0 .. 0xFF), + + # Override most ASCII printables with themselves (or on non-ASCII platforms, + # their ASCII values. This is because the output is UTF-16, which is always + # based on Unicode code points) + map( ( substr($map_to_self, $_, 1) + => to_uni(substr($map_to_self, $_, 1))), 0 .. length($map_to_self) - 1), + + # And some refinements: + "\r" => "\n", + "\cj" => "\n", + "\n" => "\n\\line ", + + "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay) + "\f" => "\n\\page\n", # Formfeed + "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen + $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space + $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen -# These are broken for early Perls on EBCDIC; they could be fixed to work -# better there, but not worth it. These are part of a larger [...] class, so -# are just the strings to substitute into it, as opposed to compiled patterns. -my $cntrl = '[:cntrl:]'; -$cntrl = '\x00-\x1F\x7F' unless eval "qr/[$cntrl]/"; + # CRAZY HACKS: + "\n" => "\\line\n", + "\r" => "\n", + "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1 + "\cc" => "}", +); -my $not_ascii = '[:^ascii:]'; -$not_ascii = '\x80-\xFF' unless eval "qr/[$not_ascii]/"; +# Generate a string of all the characters in %Escape that don't map to +# themselves. First, one without the hyphen, then one with. +my $escaped_sans_hyphen = ""; +$escaped_sans_hyphen .= $_ for grep { $_ ne $Escape{$_} && $_ ne '-' } + sort keys %Escape; +my $escaped = "-$escaped_sans_hyphen"; +# Then convert to patterns +$escaped_sans_hyphen = qr/[\Q$escaped_sans_hyphen \E]/; +$escaped= qr/[\Q$escaped\E]/; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -158,6 +201,13 @@ sub run { #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +# Match something like an identifier. Prefer XID if available, then plain ID, +# then just ASCII +my $id_re = Pod::Simple::BlackBox::my_qr('[\'_\p{XIDS}][\'\p{XIDC}]+', "ab"); +$id_re = Pod::Simple::BlackBox::my_qr('[\'_\p{IDS}][\'\p{IDC}]+', "ab") + unless $id_re; +$id_re = qr/['_a-zA-Z]['a-zA-Z0-9_]+/ unless $id_re; + sub do_middle { # the main work my $self = $_[0]; my $fh = $self->{'output_fh'}; @@ -172,7 +222,7 @@ sub do_middle { # the main work if( ($type = $token->type) eq 'text' ) { if( $self->{'rtfverbatim'} ) { DEBUG > 1 and print STDERR " $type " , $token->text, " in verbatim!\n"; - rtf_esc_codely($scratch = $token->text); + rtf_esc(0, $scratch = $token->text); # 0 => Don't escape hyphen print $fh $scratch; next; } @@ -195,13 +245,13 @@ sub do_middle { # the main work | # or starting alpha, but containing anything strange: (?: - [a-zA-Z'${not_ascii}]+[\$\@\:_<>\(\\\*]\S+ + ${id_re}[\$\@\:_<>\(\\\*]\S+ ) ) /\cb$1\cc/xsg ; - rtf_esc($scratch); + rtf_esc(1, $scratch); # 1 => escape hyphen $scratch =~ s/( [^\r\n]{65} # Snare 65 characters from a line @@ -311,7 +361,7 @@ sub do_middle { # the main work print $fh $token->attr('number'), ". \n"; } elsif ($tagname eq 'item-bullet') { print $fh "\\'", ord("_"), "\n"; - #for funky testing: print $fh '', rtf_esc("\x{4E4B}\x{9053}"); + #for funky testing: print $fh '', rtf_esc(1, "\x{4E4B}\x{9053}"); } } elsif( $type eq 'end' ) { @@ -465,7 +515,7 @@ sub doc_start { # catches the most common case, at least DEBUG and print STDERR "Title0: <$title>\n"; - $title = rtf_esc($title); + $title = rtf_esc(1, $title); # 1 => escape hyphen DEBUG and print STDERR "Title1: <$title>\n"; $title = '\lang1024\noproof ' . $title if $is_obviously_module_name; @@ -489,90 +539,69 @@ END #------------------------------------------------------------------------- use integer; -sub rtf_esc { - my $x; # scratch - if(!defined wantarray) { # void context: alter in-place! - for(@_) { - s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; - } - return; - } elsif(wantarray) { # return an array - return map {; ($x = $_) =~ - s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; - $x; - } @_; - } else { # return a single scalar - ($x = ((@_ == 1) ? $_[0] : join '', @_) - ) =~ s/([F${cntrl}\-\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - # Escape \, {, }, -, control chars, and 7f-ff. - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + +my $question_mark_code_points = + Pod::Simple::BlackBox::my_qr('([^\x00-\x{D7FF}\x{E000}-\x{10FFFF}])', + "\x{110000}"); +my $plane0 = + Pod::Simple::BlackBox::my_qr('([\x{100}-\x{FFFF}])', "\x{100}"); +my $other_unicode = + Pod::Simple::BlackBox::my_qr('([\x{10000}-\x{10FFFF}])', "\x{10000}"); + +sub esc_uni($) { + use if $] le 5.006002, 'utf8'; + + my $x = shift; + + # The output is expected to be UTF-16. Surrogates and above-Unicode get + # mapped to '?' + $x =~ s/$question_mark_code_points/?/g if $question_mark_code_points; + + # Non-surrogate Plane 0 characters get mapped to their code points. But + # the standard calls for a 16bit SIGNED value. + $x =~ s/$plane0/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg + if $plane0; + + # Use surrogate pairs for the rest + $x =~ s/$other_unicode/'\\uc1\\u' . ((ord($1) >> 10) + 0xD7C0 - 65536) . '\\u' . (((ord$1) & 0x03FF) + 0xDC00 - 65536) . '?'/eg if $other_unicode; + return $x; - } } -sub rtf_esc_codely { - # Doesn't change "-" to hard-hyphen, nor apply computerese style-smarts. - # We don't want to change the "-" to hard-hyphen, because we want to +sub rtf_esc ($$) { + # The parameter is true if we should escape hyphens + my $escape_re = ((shift) ? $escaped : $escaped_sans_hyphen); + + # When false, it doesn't change "-" to hard-hyphen. + # We don't want to change the "-" to hard-hyphen, because we want to # be able to paste this into a file and run it without there being # dire screaming about the mysterious hard-hyphen character (which # looks just like a normal dash character). - + # XXX The comments used to claim that when false it didn't apply computerese + # style-smarts, but khw didn't see this actually + my $x; # scratch if(!defined wantarray) { # void context: alter in-place! for(@_) { - s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + s/($escape_re)/$Escape{$1}/g; # ESCAPER + $_ = esc_uni($_); } return; } elsif(wantarray) { # return an array return map {; ($x = $_) =~ - s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + s/($escape_re)/$Escape{$1}/g; # ESCAPER + $x = esc_uni($x); $x; } @_; } else { # return a single scalar ($x = ((@_ == 1) ? $_[0] : join '', @_) - ) =~ s/([F${cntrl}\\\{\}${not_ascii}])/$Escape{$1}/g; # ESCAPER + ) =~ s/($escape_re)/$Escape{$1}/g; # ESCAPER # Escape \, {, }, -, control chars, and 7f-ff. - $x =~ s/([^\x00-\xFF])/'\\uc1\\u'.((ord($1)<32768)?ord($1):(ord($1)-65536)).'?'/eg; + $x = esc_uni($x); return $x; } } -%Escape = ( - (($] lt 5.007_003) # Broken for non-ASCII on early Perls - ? (map( (chr($_),chr($_)), # things not apparently needing escaping - 0x20 .. 0x7E ), - map( (chr($_),sprintf("\\'%02x", $_)), # apparently escapeworthy things - 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46)) - : (map( (chr(utf8::unicode_to_native($_)),chr(utf8::unicode_to_native($_))), - 0x20 .. 0x7E ), - map( (chr($_),sprintf("\\'%02x", utf8::unicode_to_native($_))), - 0x00 .. 0x1F, 0x5c, 0x7b, 0x7d, 0x7f .. 0xFF, 0x46))), - - # We get to escape out 'F' so that we can send RTF files thru the mail - # without the slightest worry that paragraphs beginning with "From" - # will get munged. - - # And some refinements: - "\r" => "\n", - "\cj" => "\n", - "\n" => "\n\\line ", - - "\t" => "\\tab ", # Tabs (altho theoretically raw \t's are okay) - "\f" => "\n\\page\n", # Formfeed - "-" => "\\_", # Turn plaintext '-' into a non-breaking hyphen - $Pod::Simple::nbsp => "\\~", # Latin-1 non-breaking space - $Pod::Simple::shy => "\\-", # Latin-1 soft (optional) hyphen - - # CRAZY HACKS: - "\n" => "\\line\n", - "\r" => "\n", - "\cb" => "{\n\\cs21\\lang1024\\noproof ", # \\cf1 - "\cc" => "}", -); 1; __END__ diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Search.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Search.pm index df499cacf2d..a07d33b85ac 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Search.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Search.pm @@ -3,7 +3,7 @@ package Pod::Simple::Search; use strict; use vars qw($VERSION $MAX_VERSION_WITHIN $SLEEPY); -$VERSION = '3.35'; ## Current version of this package +$VERSION = '3.40'; ## Current version of this package BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level use Carp (); @@ -12,7 +12,6 @@ $SLEEPY = 1 if !defined $SLEEPY and $^O =~ /mswin|mac/i; # flag to occasionally sleep for $SLEEPY - 1 seconds. $MAX_VERSION_WITHIN ||= 60; -my $IS_CASE_INSENSITIVE = -e uc __FILE__ && -e lc __FILE__; ############################################################################# @@ -26,7 +25,7 @@ use Cwd qw( cwd ); __PACKAGE__->_accessorize( # Make my dumb accessor methods 'callback', 'progress', 'dir_prefix', 'inc', 'laborious', 'limit_glob', 'limit_re', 'shadows', 'verbose', 'name2path', 'path2name', 'recurse', - 'ciseen' + 'ciseen', 'is_case_insensitive' ); #========================================================================== @@ -42,6 +41,7 @@ sub init { $self->inc(1); $self->recurse(1); $self->verbose(DEBUG); + $self->is_case_insensitive(-e uc __FILE__ && -e lc __FILE__); return $self; } @@ -130,12 +130,12 @@ sub _make_search_callback { # Put the options in variables, for easy access my( $laborious, $verbose, $shadows, $limit_re, $callback, $progress, - $path2name, $name2path, $recurse, $ciseen) = + $path2name, $name2path, $recurse, $ciseen, $is_case_insensitive) = map scalar($self->$_()), qw(laborious verbose shadows limit_re callback progress - path2name name2path recurse ciseen); + path2name name2path recurse ciseen is_case_insensitive); my ($seen, $remember, $files_for); - if ($IS_CASE_INSENSITIVE) { + if ($is_case_insensitive) { $seen = sub { $ciseen->{ lc $_[0] } }; $remember = sub { $name2path->{ $_[0] } = $ciseen->{ lc $_[0] } = $_[1]; }; $files_for = sub { my $n = lc $_[0]; grep { lc $path2name->{$_} eq $n } %{ $path2name } }; @@ -259,7 +259,7 @@ sub _path2modname { while(@m and defined($x = lc( $m[0] )) and( $x eq 'site_perl' - or($x eq 'pod' and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) + or($x =~ m/^pods?$/ and @m == 1 and $shortname =~ m{^perl.*\.pod$}s ) or $x =~ m{\\d+\\.z\\d+([_.]?\\d+)?} # if looks like a vernum or $x eq lc( $Config::Config{'archname'} ) )) { shift @m } @@ -546,7 +546,7 @@ sub _limit_glob_to_limit_re { sub _actual_filenames { my $dir = shift; my $fn = lc shift; - opendir my $dh, $dir or return; + opendir my ($dh), $dir or return; return map { File::Spec->catdir($dir, $_) } grep { lc $_ eq $fn } readdir $dh; } @@ -588,7 +588,7 @@ sub find { my $fullext = $fullname . $ext; if ( -f $fullext and $self->contains_pod($fullext) ) { print "FOUND: $fullext\n" if $verbose; - if (@parts > 1 && lc $parts[0] eq 'pod' && $IS_CASE_INSENSITIVE && $ext eq '.pod') { + if (@parts > 1 && lc $parts[0] eq 'pod' && $self->is_case_insensitive() && $ext eq '.pod') { # Well, this file could be for a program (perldoc) but we actually # want a module (Pod::Perldoc). So see if there is a .pm with the # proper casing. @@ -611,7 +611,7 @@ sub find { } # Case-insensitively Look for ./pod directories and slip them in. - for my $subdir ( _actual_filenames($dir, 'pod') ) { + for my $subdir ( _actual_filenames($dir, 'pods'), _actual_filenames($dir, 'pod') ) { if (-d $subdir) { $verbose and print "Noticing $subdir and looking there...\n"; unshift @search_dirs, $subdir; @@ -849,6 +849,20 @@ inspected too, and are noted in the pathname2podname return hash. This attribute's default value is false; and normally you won't need to turn it on. +=item $search->is_case_insensitive( I<true-or-false> ); + +Pod::Simple::Search will by default internally make an assumption +based on the underlying filesystem where the class file is found +whether it is case insensitive or not. + +If it is determined to be case insensitive, during survey() it may +skip pod files/modules that happen to be equal to names it's already +seen, ignoring case. + +However, it's possible to have distinct files in different directories +that intentionally has the same name, just differing in case, that should +be reported. Hence, you may force the behavior by setting this to true +or false. =item $search->limit_re( I<some-regxp> ); @@ -857,7 +871,6 @@ to limit the results just to items whose podnames match the given regexp. Normally this option is not needed, and the more efficient C<limit_glob> attribute is used instead. - =item $search->dir_prefix( I<some-string-value> ); Setting this attribute to a string value means that the searches should diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm index bff5af84c4b..85dbabcd70e 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/SimpleTree.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.35'; +$VERSION = '3.40'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Subclassing.pod b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Subclassing.pod index 88f85e86de2..f9cb09a52ef 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Subclassing.pod +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Subclassing.pod @@ -98,9 +98,14 @@ nodes that represent preformatted text (from verbatim sections). TODO intro... mention that events are supplied for implicits, like for missing >'s - In the following section, we use XML to represent the event structure -associated with a particular construct. That is, TODO +associated with a particular construct. That is, an opening tag +represents the element start, the attributes of that opening tag are +the attributes given to the callback, and the closing tag represents +the end element. + +Three callback methods must be supplied by a class extending +L<Pod::Simple> to receive the corresponding event: =over @@ -112,8 +117,9 @@ associated with a particular construct. That is, TODO =back -TODO describe - +Here's the comprehensive list of values you can expect as +I<element_name> in your implementation of C<_handle_element_start> +and C<_handle_element_end>:: =over diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Text.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Text.pm index 66e15f48cce..de50b510eae 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Text.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Text.pm @@ -6,7 +6,7 @@ use Carp (); use Pod::Simple::Methody (); use Pod::Simple (); use vars qw( @ISA $VERSION $FREAKYMODE); -$VERSION = '3.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple::Methody'); BEGIN { *DEBUG = defined(&Pod::Simple::DEBUG) ? \&Pod::Simple::DEBUG diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm index 980612b3132..ad4172b7a31 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TextContent.pm @@ -6,7 +6,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( @ISA $VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; @ISA = ('Pod::Simple'); sub new { diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm index a7364dfa585..0dd12c412dd 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TiedOutFH.pm @@ -4,7 +4,7 @@ package Pod::Simple::TiedOutFH; use Symbol ('gensym'); use Carp (); use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm index a4bb29ffdb6..eb127022827 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/Transcode.pm @@ -3,7 +3,7 @@ require 5; package Pod::Simple::Transcode; use strict; use vars qw($VERSION @ISA); -$VERSION = '3.35'; +$VERSION = '3.40'; BEGIN { if(defined &DEBUG) {;} # Okay diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm index c2069056574..2b675ccb787 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeDumb.pm @@ -5,7 +5,7 @@ require 5; package Pod::Simple::TranscodeDumb; use strict; use vars qw($VERSION %Supported); -$VERSION = '3.35'; +$VERSION = '3.40'; # This module basically pretends it knows how to transcode, except # only for null-transcodings! We use this when Encode isn't # available. diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm index e4d4f7eb60e..99f55683ab3 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/TranscodeSmart.pm @@ -9,7 +9,7 @@ use strict; use Pod::Simple; require Encode; use vars qw($VERSION ); -$VERSION = '3.35'; +$VERSION = '3.40'; sub is_dumb {0} sub is_smart {1} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm index 8c2cf1a01ba..b9c6269bf98 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XHTML.pm @@ -45,7 +45,7 @@ declare the output character set as UTF-8 before parsing, like so: package Pod::Simple::XHTML; use strict; use vars qw( $VERSION @ISA $HAS_HTML_ENTITIES ); -$VERSION = '3.35'; +$VERSION = '3.40'; use Pod::Simple::Methody (); @ISA = ('Pod::Simple::Methody'); @@ -92,7 +92,7 @@ the call to C<parse_file>: In turning L<Foo::Bar> into http://whatever/Foo%3a%3aBar, what to put before the "Foo%3a%3aBar". The default value is -"http://search.cpan.org/perldoc?". +"https://metacpan.org/pod/". =head2 perldoc_url_postfix @@ -247,7 +247,7 @@ sub new { my $self = shift; my $new = $self->SUPER::new(@_); $new->{'output_fh'} ||= *STDOUT{IO}; - $new->perldoc_url_prefix('http://search.cpan.org/perldoc?'); + $new->perldoc_url_prefix('https://metacpan.org/pod/'); $new->man_url_prefix('http://man.he.net/man'); $new->html_charset('ISO-8859-1'); $new->nix_X_codes(1); @@ -685,8 +685,8 @@ sub emit { Resolves a POD link target (typically a module or POD file name) and section name to a URL. The resulting link will be returned for the above examples as: - http://search.cpan.org/perldoc?Net::Ping#INSTALL - http://search.cpan.org/perldoc?perlpodspec + https://metacpan.org/pod/Net::Ping#INSTALL + https://metacpan.org/pod/perlpodspec #SYNOPSIS Note that when there is only a section argument the URL will simply be a link diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm index 62fe39549da..cb818a17409 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/XMLOutStream.pm @@ -5,7 +5,7 @@ use strict; use Carp (); use Pod::Simple (); use vars qw( $ATTR_PAD @ISA $VERSION $SORT_ATTRS); -$VERSION = '3.35'; +$VERSION = '3.40'; BEGIN { @ISA = ('Pod::Simple'); *DEBUG = \&Pod::Simple::DEBUG unless defined &DEBUG; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/encod04.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/encod04.t index 88727cca521..8f41f98a6cc 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/encod04.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/encod04.t @@ -12,14 +12,14 @@ BEGIN { use strict; use Test; BEGIN { - if ($] lt 5.007_003) { - plan tests => 5, todo => [4, 5]; # Need utf8::decode() to pass #5 - # and isn't available in this - # release - } - else { - plan tests => 5, todo => [4]; - } + plan tests => 6, todo => []; +} + +# fail with the supplied diagnostic + +sub my_nok { + my ($diag) = @_; + ok (1, 0, $diag); } ok 1; @@ -61,16 +61,13 @@ if( $guess ) { if( grep m{Dash $dash}, @output_lines ) { ok 1; } else { - ok 0; - print STDERR "# failed to find expected control character in output\n" + my_nok "failed to find expected control character in output"; } } else { - ok 0; - print STDERR "# parser guessed wrong encoding expected 'CP1252' got '$guess'\n"; + my_nok "parser guessed wrong encoding expected 'CP1252' got '$guess'"; } } else { - ok 0; - print STDERR "# parser failed to detect non-ASCII bytes in input\n"; + my_nok "parser failed to detect non-ASCII bytes in input"; } @@ -95,18 +92,18 @@ else { if( $guess eq 'CP1252' ) { ok 1; } else { - ok 0; - print STDERR "# parser guessed wrong encoding expected 'CP1252' got '$guess'\n"; + my_nok "parser guessed wrong encoding expected 'CP1252' got '$guess'"; } } else { - ok 0; - print STDERR "# parser failed to detect non-ASCII bytes in input\n"; + my_nok "parser failed to detect non-ASCII bytes in input"; } } -# Initial accented character followed by 'smart' apostrophe causes heuristic -# to choose UTF8 (a somewhat contrived example) +# Initial accented character (E acute) followed by 'smart' apostrophe is legal +# CP1252, which should be preferred over UTF-8 because the latter +# interpretation would be "JOS" . \N{LATIN SMALL LETTER TURNED ALPHA} . "S +# PLACE", and that \N{} letter is an IPA one. @output_lines = split m/[\r\n]+/, Pod::Simple::XMLOutStream->_out( qq{ @@ -127,12 +124,10 @@ else { if( $guess eq 'CP1252' ) { ok 1; } else { - ok 0; - print STDERR "# parser guessed wrong encoding expected 'CP1252' got '$guess'\n"; + my_nok "parser guessed wrong encoding expected 'CP1252' got '$guess'"; } } else { - ok 0; - print STDERR "# parser failed to detect non-ASCII bytes in input\n"; + my_nok "parser failed to detect non-ASCII bytes in input"; } } @@ -160,12 +155,40 @@ else { if( $guess eq 'CP1252' ) { ok 1; } else { - ok 0; - print STDERR "# parser guessed wrong encoding expected 'CP1252' got '$guess'\n"; + my_nok "parser guessed wrong encoding expected 'CP1252' got '$guess'"; + } + } else { + my_nok "parser failed to detect non-ASCII bytes in input"; + } +} + +# The following is a real word example of something in CP1252 expressible in +# UTF-8, but doesn't make sense in UTF-8, contributed by Bo Lindbergh. +# Muvrarášša is a Sami word + +@output_lines = split m/[\r\n]+/, Pod::Simple::XMLOutStream->_out( qq{ + +=head1 NAME + +Muvrar\xE1\x9A\x9Aa is a mountain in Norway + +=cut + +} ); + +if (ord("A") != 65) { # ASCII-platform dependent test skipped on this platform + ok (1); +} +else { + ($guess) = "@output_lines" =~ m{Non-ASCII.*?Assuming ([\w-]+)}; + if( $guess ) { + if( $guess eq 'CP1252' ) { + ok 1; + } else { + my_nok "parser guessed wrong encoding expected 'CP1252' got '$guess'"; } } else { - ok 0; - print STDERR "# parser failed to detect non-ASCII bytes in input\n"; + my_nok "parser failed to detect non-ASCII bytes in input"; } } diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/html01.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/html01.t index b4caa39dc66..8d8e528320d 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/html01.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/html01.t @@ -9,7 +9,7 @@ BEGIN { use strict; use Test; -BEGIN { plan tests => 13 }; +BEGIN { plan tests => 14 }; #use Pod::Simple::Debug (10); @@ -137,6 +137,16 @@ ok( "\n<dl>\n<dt><a name=\"howdy\"\n>Foo</a></dt>\n</dl>\n", ); +{ # Test that strip_verbatim_indent() works. github issue #i5 + my $output; + + my $obj = Pod::Simple::HTML->new; + $obj->strip_verbatim_indent(" "); + $obj->output_string(\$output); + $obj->parse_string_document("=pod\n\n First line\n 2nd line\n"); + ok($output, qr!<pre>First line\n2nd line</pre>!s); +} + print "# And one for the road...\n"; ok 1; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search20.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search20.t index cbc3ac3fcf5..1b17c3b021a 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search20.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search20.t @@ -78,16 +78,16 @@ require $ascii_order; { my $names = join "|", sort ascii_order values %$where2name; -skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, - $names, - "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzoned|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; } { my $names = join "|", sort ascii_order keys %$name2where; -skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, - $names, - "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzoned|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; } ok( ($name2where->{'squaa'} || 'huh???'), '/squaa\.pm$/'); diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search22.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search22.t index c6b33eea753..6fb498a3318 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search22.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search22.t @@ -8,7 +8,7 @@ BEGIN { use strict; use Pod::Simple::Search; use Test; -BEGIN { plan tests => 13 } +BEGIN { plan tests => 15 } print "# ", __FILE__, ": Testing the scanning of several docroots...\n"; @@ -80,17 +80,17 @@ require $ascii_order; { print "# won't show any shadows, since we're just looking at the name2where keys\n"; my $names = join "|", sort ascii_order keys %$name2where; -skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, - $names, - "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Vliff|perlflif|perlthng|perlzoned|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Wowo|zikzik"; } { print "# but here we'll see shadowing:\n"; my $names = join "|", sort ascii_order values %$where2name; -skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, - $names, - "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Glunk|hinkhonk::Vliff|hinkhonk::Vliff|perlflif|perlthng|perlthng|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo|zikzik"; +skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, + $names, + "Blorm|Suzzle|Zonk::Pronk|hinkhonk::Glunk|hinkhonk::Glunk|hinkhonk::Vliff|hinkhonk::Vliff|perlflif|perlthng|perlthng|perlzoned|perlzuk|squaa|squaa::Glunk|squaa::Vliff|squaa::Vliff|squaa::Vliff|squaa::Wowo|zikzik"; my %count; for(values %$where2name) { ++$count{$_} }; @@ -120,7 +120,9 @@ skip $^O eq 'VMS' ? '-- case may or may not be preserved' : 0, ($name2where->{'squaa::Wowo'} || 'huh???'), '/testlib2/'; - +my $in_pods = $x->find('perlzoned', $here2); +ok $in_pods, qr{^\Q$here2\E}; +ok $in_pods, qr{perlzoned.pod$}; print "# OK, bye from ", __FILE__, "\n"; ok 1; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search50.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search50.t index 126f24a7b1e..0dc9d75a296 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search50.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search50.t @@ -23,6 +23,7 @@ ok $x->inc; # make sure inc=1 is the default use Pod::Simple; *pretty = \&Pod::Simple::BlackBox::pretty; +*pretty = \&Pod::Simple::BlackBox::pretty; # avoid 'once' warning my $found = 0; $x->callback(sub { diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/whine.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/whine.t index b33f0a91efa..4ac76e5bd3d 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/whine.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/whine.t @@ -1,6 +1,6 @@ use strict; use warnings; -use Test::More tests => 4; +use Test::More tests => 6; { package Pod::Simple::ErrorFinder; @@ -51,3 +51,23 @@ sub errors { Pod::Simple::ErrorFinder->errors_for_input(@_) } "warning for / in text part of L<>", ); } + +{ + my $input = "=pod\n\nnested LE<lt>E<sol>E<gt>: L<Nested L<http://foobar>|http://baz>\n"; + my $errors = errors("$input"); + is_deeply( + $errors, + { 3 => [ "Nested L<> are illegal. Pretending inner one is X<...> so can continue looking for other errors." ] }, + "warning for nested L<>", + ); +} + +{ + my $input = "=pod\n\nLE<lt>E<sol>E<gt> containing only slash: L< / >\n"; + my $errors = errors("$input"); + is_deeply( + $errors, + { 3 => [ "L<> contains only '/'" ] }, + "warning for L< / > containing only a slash", + ); +} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/xhtml01.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/xhtml01.t index 01e6f189b42..7ee08652162 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/xhtml01.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/xhtml01.t @@ -18,7 +18,7 @@ isa_ok ($parser, 'Pod::Simple::XHTML'); my $results; -my $PERLDOC = "http://search.cpan.org/perldoc"; +my $PERLDOC = "https://metacpan.org/pod"; my $MANURL = "http://man.he.net/man"; initialize($parser, $results); @@ -541,7 +541,7 @@ $parser->parse_string_document(<<'EOPOD'); A plain paragraph with a L<Newlines>. EOPOD is($results, <<"EOHTML", "Link entity in a paragraph"); -<p>A plain paragraph with a <a href="$PERLDOC?Newlines">Newlines</a>.</p> +<p>A plain paragraph with a <a href="$PERLDOC/Newlines">Newlines</a>.</p> EOHTML @@ -552,7 +552,7 @@ $parser->parse_string_document(<<'EOPOD'); A plain paragraph with a L<perlport/Newlines>. EOPOD is($results, <<"EOHTML", "Link entity in a paragraph"); -<p>A plain paragraph with a <a href="$PERLDOC?perlport#Newlines">"Newlines" in perlport</a>.</p> +<p>A plain paragraph with a <a href="$PERLDOC/perlport#Newlines">"Newlines" in perlport</a>.</p> EOHTML @@ -742,16 +742,16 @@ like $results, qr{\Q<meta http-equiv="Content-Type" content="text/html; charset= # Test the link generation methods. is $parser->resolve_pod_page_link('Net::Ping', 'INSTALL'), - "$PERLDOC?Net::Ping#INSTALL", + "$PERLDOC/Net::Ping#INSTALL", 'POD link with fragment'; is $parser->resolve_pod_page_link('perlpodspec'), - "$PERLDOC?perlpodspec", 'Simple POD link'; + "$PERLDOC/perlpodspec", 'Simple POD link'; is $parser->resolve_pod_page_link(undef, 'SYNOPSIS'), '#SYNOPSIS', 'Simple fragment link'; is $parser->resolve_pod_page_link(undef, 'this that'), '#this-that', 'Fragment link with space'; is $parser->resolve_pod_page_link('perlpod', 'this that'), - "$PERLDOC?perlpod#this-that", + "$PERLDOC/perlpod#this-that", 'POD link with fragment with space'; is $parser->resolve_man_page_link('crontab(5)', 'EXAMPLE CRON FILE'), diff --git a/gnu/usr.bin/perl/cpan/Pod-Usage/t/pod/testp2pt.pl b/gnu/usr.bin/perl/cpan/Pod-Usage/t/pod/testp2pt.pl index cd312453273..720575336c0 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Usage/t/pod/testp2pt.pl +++ b/gnu/usr.bin/perl/cpan/Pod-Usage/t/pod/testp2pt.pl @@ -11,7 +11,7 @@ BEGIN { unshift @INC, $THISDIR; require "testcmp.pl"; import TestCompare; - $PARENTDIR = dirname $THISDIR; + $PARENTDIR = File::Spec->catdir($THISDIR, File::Spec->updir()); push @INC, map { File::Spec->catfile($_, 'lib') } ($PARENTDIR, $THISDIR); } diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs index 12f98cde192..5bccc88444d 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/ListUtil.xs @@ -2,6 +2,7 @@ * This program is free software; you can redistribute it and/or * modify it under the same terms as Perl itself. */ + #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include <EXTERN.h> #include <perl.h> @@ -14,20 +15,35 @@ # include "ppport.h" #endif +/* For uniqnum, define ACTUAL_NVSIZE to be the number * + * of bytes that are actually used to store the NV */ + +#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 64 +# define ACTUAL_NVSIZE 10 +#else +# define ACTUAL_NVSIZE NVSIZE +#endif + +/* Detect "DoubleDouble" nvtype */ + +#if defined(USE_LONG_DOUBLE) && LDBL_MANT_DIG == 106 +# define NV_IS_DOUBLEDOUBLE +#endif + #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) + 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)) + (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)) + (PERL_DECIMAL_VERSION <= PERL_VERSION_DECIMAL(r,v,s)) #endif #if PERL_VERSION_GE(5,6,0) @@ -72,6 +88,12 @@ #define sv_catpvn_flags(b,n,l,f) sv_catpvn(b,n,l) #endif +#if !PERL_VERSION_GE(5,8,0) +static NV Perl_ceil(NV nv) { + return -Perl_floor(-nv); +} +#endif + /* Some platforms have strict exports. And before 5.7.3 cxinc (or Perl_cxinc) was not exported. Therefore platforms like win32, VMS etc have problems so we redefine it here -- GMB @@ -124,6 +146,38 @@ my_sv_copypv(pTHX_ SV *const dsv, SV *const ssv) # define SvNV_nomg SvNV #endif +#if PERL_VERSION_GE(5,16,0) +# define HAVE_UNICODE_PACKAGE_NAMES + +# ifndef sv_sethek +# define sv_sethek(a, b) Perl_sv_sethek(aTHX_ a, b) +# endif + +# ifndef sv_ref +# define sv_ref(dst, sv, ob) my_sv_ref(aTHX_ dst, sv, ob) +static SV * +my_sv_ref(pTHX_ SV *dst, const SV *sv, int ob) +{ + /* cargoculted from perl 5.22's sv.c */ + if(!dst) + dst = sv_newmortal(); + + if(ob && SvOBJECT(sv)) { + if(HvNAME_get(SvSTASH(sv))) + sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))); + else + sv_setpvs(dst, "__ANON__"); + } + else { + const char *reftype = sv_reftype(sv, 0); + sv_setpv(dst, reftype); + } + + return dst; +} +# endif +#endif /* HAVE_UNICODE_PACKAGE_NAMES */ + enum slu_accum { ACC_IV, ACC_NV, @@ -143,6 +197,53 @@ static enum slu_accum accum_type(SV *sv) { /* Magic for set_subname */ static MGVTBL subname_vtbl; +static void MY_initrand(pTHX) +{ +#if (PERL_VERSION < 9) + struct op dmy_op; + struct op *old_op = PL_op; + + /* We call pp_rand here so that Drand01 get initialized if rand() + or srand() has not already been called + */ + memzero((char*)(&dmy_op), sizeof(struct op)); + /* we let pp_rand() borrow the TARG allocated for this XS sub */ + dmy_op.op_targ = PL_op->op_targ; + PL_op = &dmy_op; + (void)*(PL_ppaddr[OP_RAND])(aTHX); + PL_op = old_op; +#else + /* Initialize Drand01 if rand() or srand() has + not already been called + */ + if(!PL_srand_called) { + (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX)); + PL_srand_called = TRUE; + } +#endif +} + +static double MY_callrand(pTHX_ CV *randcv) +{ + dSP; + double ret, dummy; + + ENTER; + PUSHMARK(SP); + PUTBACK; + + call_sv((SV *)randcv, G_SCALAR); + + SPAGAIN; + + ret = modf(POPn, &dummy); /* bound to < 1 */ + if(ret < 0) ret += 1.0; /* bound to 0 <= ret < 1 */ + + LEAVE; + + return ret; +} + MODULE=List::Util PACKAGE=List::Util void @@ -344,9 +445,9 @@ CODE: /* else fallthrough */ } - /* fallthrough to NV now */ retnv = retiv; accum = ACC_NV; + /* FALLTHROUGH */ case ACC_NV: is_product ? (retnv *= slu_sv_value(sv)) : (retnv += slu_sv_value(sv)); @@ -419,10 +520,14 @@ void reduce(block,...) SV *block PROTOTYPE: &@ +ALIAS: + reduce = 0 + reductions = 1 CODE: { SV *ret = sv_newmortal(); int index; + AV *retvals; GV *agv,*bgv,*gv; HV *stash; SV **args = &PL_stack_base[ax]; @@ -431,8 +536,12 @@ CODE: if(cv == Nullcv) croak("Not a subroutine reference"); - if(items <= 1) - XSRETURN_UNDEF; + if(items <= 1) { + if(ix) + XSRETURN(0); + else + XSRETURN_UNDEF; + } agv = gv_fetchpv("a", GV_ADD, SVt_PV); bgv = gv_fetchpv("b", GV_ADD, SVt_PV); @@ -440,6 +549,17 @@ CODE: SAVESPTR(GvSV(bgv)); GvSV(agv) = ret; SvSetMagicSV(ret, args[1]); + + if(ix) { + /* Precreate an AV for return values; -1 for cv, -1 for top index */ + retvals = newAV(); + av_extend(retvals, items-1-1); + + /* so if throw an exception they can be reclaimed */ + SAVEFREESV(retvals); + + av_push(retvals, newSVsv(ret)); + } #ifdef dMULTICALL assert(cv); if(!CvISXSUB(cv)) { @@ -452,6 +572,8 @@ CODE: GvSV(bgv) = args[index]; MULTICALL; SvSetMagicSV(ret, *PL_stack_sp); + if(ix) + av_push(retvals, newSVsv(ret)); } # ifdef PERL_HAS_BAD_MULTICALL_REFCOUNT if(CvDEPTH(multicall_cv) > 1) @@ -470,11 +592,26 @@ CODE: call_sv((SV*)cv, G_SCALAR); SvSetMagicSV(ret, *PL_stack_sp); + if(ix) + av_push(retvals, newSVsv(ret)); } } - ST(0) = ret; - XSRETURN(1); + if(ix) { + int i; + SV **svs = AvARRAY(retvals); + /* steal the SVs from retvals */ + for(i = 0; i < items-1; i++) { + ST(i) = sv_2mortal(svs[i]); + svs[i] = NULL; + } + + XSRETURN(items-1); + } + else { + ST(0) = ret; + XSRETURN(1); + } } void @@ -1105,31 +1242,17 @@ PROTOTYPE: @ CODE: { int index; -#if (PERL_VERSION < 9) - struct op dmy_op; - struct op *old_op = PL_op; + SV *randsv = get_sv("List::Util::RAND", 0); + CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ? + (CV *)SvRV(randsv) : NULL; - /* We call pp_rand here so that Drand01 get initialized if rand() - or srand() has not already been called - */ - memzero((char*)(&dmy_op), sizeof(struct op)); - /* we let pp_rand() borrow the TARG allocated for this XS sub */ - dmy_op.op_targ = PL_op->op_targ; - PL_op = &dmy_op; - (void)*(PL_ppaddr[OP_RAND])(aTHX); - PL_op = old_op; -#else - /* Initialize Drand01 if rand() or srand() has - not already been called - */ - if(!PL_srand_called) { - (void)seedDrand01((Rand_seed_t)Perl_seed(aTHX)); - PL_srand_called = TRUE; - } -#endif + if(!randcv) + MY_initrand(aTHX); for (index = items ; index > 1 ; ) { - int swap = (int)(Drand01() * (double)(index--)); + int swap = (int)( + (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(index--) + ); SV *tmp = ST(swap); ST(swap) = ST(index); ST(index) = tmp; @@ -1138,12 +1261,58 @@ CODE: XSRETURN(items); } +void +sample(...) +PROTOTYPE: $@ +CODE: +{ + IV count = items ? SvUV(ST(0)) : 0; + IV reti = 0; + SV *randsv = get_sv("List::Util::RAND", 0); + CV * const randcv = randsv && SvROK(randsv) && SvTYPE(SvRV(randsv)) == SVt_PVCV ? + (CV *)SvRV(randsv) : NULL; + + if(!count) + XSRETURN(0); + + /* Now we've extracted count from ST(0) the rest of this logic will be a + * lot neater if we move the topmost item into ST(0) so we can just work + * within 0..items-1 */ + ST(0) = POPs; + items--; + + if(count > items) + count = items; + + if(!randcv) + MY_initrand(aTHX); + + /* Partition the stack into ST(0)..ST(reti-1) containing the sampled results + * and ST(reti)..ST(items-1) containing the remaining pending candidates + */ + while(reti < count) { + int index = (int)( + (randcv ? MY_callrand(aTHX_ randcv) : Drand01()) * (double)(items - reti) + ); + + SV *selected = ST(reti + index); + /* preserve the element we're about to stomp on by putting it back into + * the pending partition */ + ST(reti + index) = ST(reti); + + ST(reti) = selected; + reti++; + } + + XSRETURN(reti); +} + void uniq(...) PROTOTYPE: @ ALIAS: - uniqnum = 0 + uniqint = 0 uniqstr = 1 uniq = 2 CODE: @@ -1152,6 +1321,7 @@ CODE: int index; SV **args = &PL_stack_base[ax]; HV *seen; + int seen_undef = 0; if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) { /* Optimise for the case of the empty list or a defined nonmagic @@ -1162,88 +1332,230 @@ CODE: sv_2mortal((SV *)(seen = newHV())); - if(ix == 0) { - /* uniqnum */ - /* A temporary buffer for number stringification */ - SV *keysv = sv_newmortal(); - - for(index = 0 ; index < items ; index++) { - SV *arg = args[index]; + for(index = 0 ; index < items ; index++) { + SV *arg = args[index]; #ifdef HV_FETCH_EMPTY_HE - HE* he; + HE *he; #endif - if(SvGAMAGIC(arg)) - /* clone the value so we don't invoke magic again */ - arg = sv_mortalcopy(arg); + if(SvGAMAGIC(arg)) + /* clone the value so we don't invoke magic again */ + arg = sv_mortalcopy(arg); - if(SvUOK(arg)) - sv_setpvf(keysv, "%" UVuf, SvUV(arg)); - else if(SvIOK(arg)) - sv_setpvf(keysv, "%" IVdf, SvIV(arg)); + if(ix == 2 && !SvOK(arg)) { + /* special handling of undef for uniq() */ + if(seen_undef) + continue; + + seen_undef++; + + if(GIMME_V == G_ARRAY) + ST(retcount) = arg; + retcount++; + continue; + } + if(ix == 0) { + /* uniqint */ + /* coerce to integer */ +#if PERL_VERSION >= 8 + /* int_amg only appeared in perl 5.8.0 */ + if(SvAMAGIC(arg) && (arg = AMG_CALLun(arg, int))) + ; /* nothing to do */ else - sv_setpvf(keysv, "%" NVgf, SvNV(arg)); +#endif + if(!SvOK(arg) || SvNOK(arg) || SvPOK(arg)) + { + /* Convert undef, NVs and PVs into a well-behaved int */ + NV nv = SvNV(arg); + + if(nv > (NV)UV_MAX) + /* Too positive for UV - use NV */ + arg = newSVnv(Perl_floor(nv)); + else if(nv < (NV)IV_MIN) + /* Too negative for IV - use NV */ + arg = newSVnv(Perl_ceil(nv)); + else if(nv > 0 && (UV)nv > (UV)IV_MAX) + /* Too positive for IV - use UV */ + arg = newSVuv(nv); + else + /* Must now fit into IV */ + arg = newSViv(nv); + + sv_2mortal(arg); + } + } #ifdef HV_FETCH_EMPTY_HE - he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); - if (HeVAL(he)) - continue; + he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); + if (HeVAL(he)) + continue; - HeVAL(he) = &PL_sv_undef; + HeVAL(he) = &PL_sv_undef; #else - if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv))) - continue; + if (hv_exists_ent(seen, arg, 0)) + continue; - hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0); + hv_store_ent(seen, arg, &PL_sv_yes, 0); #endif - if(GIMME_V == G_ARRAY) - ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0)); - retcount++; - } + if(GIMME_V == G_ARRAY) + ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0)); + retcount++; + } + + finish: + if(GIMME_V == G_ARRAY) + XSRETURN(retcount); + else + ST(0) = sv_2mortal(newSViv(retcount)); +} + +void +uniqnum(...) +PROTOTYPE: @ +CODE: +{ + int retcount = 0; + int index; + SV **args = &PL_stack_base[ax]; + HV *seen; + /* A temporary buffer for number stringification */ + SV *keysv = sv_newmortal(); + + if(items == 0 || (items == 1 && !SvGAMAGIC(args[0]) && SvOK(args[0]))) { + /* Optimise for the case of the empty list or a defined nonmagic + * singleton. Leave a singleton magical||undef for the regular case */ + retcount = items; + goto finish; } - else { - /* uniqstr or uniq */ - int seen_undef = 0; - for(index = 0 ; index < items ; index++) { - SV *arg = args[index]; + sv_2mortal((SV *)(seen = newHV())); + + for(index = 0 ; index < items ; index++) { + SV *arg = args[index]; + NV nv_arg; #ifdef HV_FETCH_EMPTY_HE - HE *he; + HE* he; #endif - if(SvGAMAGIC(arg)) - /* clone the value so we don't invoke magic again */ - arg = sv_mortalcopy(arg); + if(SvGAMAGIC(arg)) + /* clone the value so we don't invoke magic again */ + arg = sv_mortalcopy(arg); - if(ix == 2 && !SvOK(arg)) { - /* special handling of undef for uniq() */ - if(seen_undef) - continue; + if(SvOK(arg) && !(SvUOK(arg) || SvIOK(arg) || SvNOK(arg))) { +#if PERL_VERSION >= 8 + SvIV(arg); /* sets SVf_IOK/SVf_IsUV if it's an integer */ +#else + SvNV(arg); /* SvIV() sets SVf_IOK even on floats on 5.6 */ +#endif + } +#if NVSIZE > IVSIZE /* $Config{nvsize} > $Config{ivsize} */ + /* Avoid altering arg's flags */ + if(SvUOK(arg)) nv_arg = (NV)SvUV(arg); + else if(SvIOK(arg)) nv_arg = (NV)SvIV(arg); + else nv_arg = SvNV(arg); + + /* use 0 for all zeros */ + if(nv_arg == 0) sv_setpvs(keysv, "0"); + + /* for NaN, use the platform's normal stringification */ + else if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg); +#ifdef NV_IS_DOUBLEDOUBLE + /* If the least significant double is zero, it could be either 0.0 * + * or -0.0. We therefore ignore the least significant double and * + * assign to keysv the bytes of the most significant double only. */ + else if(nv_arg == (double)nv_arg) { + double double_arg = (double)nv_arg; + sv_setpvn(keysv, (char *) &double_arg, 8); + } +#endif + else { + /* Use the byte structure of the NV. * + * ACTUAL_NVSIZE == sizeof(NV) minus the number of bytes * + * that are allocated but never used. (It is only the 10-byte * + * extended precision long double that allocates bytes that are * + * never used. For all other NV types ACTUAL_NVSIZE == sizeof(NV). */ + sv_setpvn(keysv, (char *) &nv_arg, ACTUAL_NVSIZE); + } +#else /* $Config{nvsize} == $Config{ivsize} == 8 */ + if( SvIOK(arg) || !SvOK(arg) ) { - seen_undef++; + /* It doesn't matter if SvUOK(arg) is TRUE */ + IV iv = SvIV(arg); - if(GIMME_V == G_ARRAY) - ST(retcount) = arg; - retcount++; - continue; + /* use "0" for all zeros */ + if(iv == 0) sv_setpvs(keysv, "0"); + + else { + int uok = SvUOK(arg); + int sign = ( iv > 0 || uok ) ? 1 : -1; + + /* Set keysv to the bytes of SvNV(arg) if and only if the integer value * + * held by arg can be represented exactly as a double - ie if there are * + * no more than 51 bits between its least significant set bit and its * + * most significant set bit. * + * The neatest approach I could find was provided by roboticus at: * + * https://www.perlmonks.org/?node_id=11113490 * + * First, identify the lowest set bit and assign its value to an IV. * + * Note that this value will always be > 0, and always a power of 2. */ + IV lowest_set = iv & -iv; + + /* Second, shift it left 53 bits to get location of the first bit * + * beyond arg's highest "allowed" set bit. * + * NOTE: If lowest set bit is initially far enough left, then this left * + * shift operation will result in a value of 0, which is fine. * + * Then subtract 1 so that all of the ("allowed") bits below the set bit * + * are 1 && all other ("disallowed") bits are set to 0. * + * (If the value prior to subtraction was 0, then subtracting 1 will set * + * all bits - which is also fine.) */ + UV valid_bits = (lowest_set << 53) - 1; + + /* The value of arg can be exactly represented by a double unless one * + * or more of its "disallowed" bits are set - ie if iv & (~valid_bits) * + * is untrue. However, if (iv < 0 && !SvUOK(arg)) we need to multiply iv * + * by -1 prior to performing that '&' operation - so multiply iv by sign.*/ + if( !((iv * sign) & (~valid_bits)) ) { + /* Avoid altering arg's flags */ + nv_arg = uok ? (NV)SvUV(arg) : (NV)SvIV(arg); + sv_setpvn(keysv, (char *) &nv_arg, 8); + } + else { + /* Read in the bytes, rather than the numeric value of the IV/UV as * + * this is more efficient, despite having to sv_catpvn an extra byte.*/ + sv_setpvn(keysv, (char *) &iv, 8); + /* We add an extra byte to distinguish between an IV/UV and an NV. * + * We also use that byte to distinguish between a -ve IV and a UV. */ + if(uok) sv_catpvn(keysv, "U", 1); + else sv_catpvn(keysv, "I", 1); + } } + } + else { + nv_arg = SvNV(arg); + + /* for NaN, use the platform's normal stringification */ + if (nv_arg != nv_arg) sv_setpvf(keysv, "%" NVgf, nv_arg); + + /* use "0" for all zeros */ + else if(nv_arg == 0) sv_setpvs(keysv, "0"); + else sv_setpvn(keysv, (char *) &nv_arg, 8); + } +#endif #ifdef HV_FETCH_EMPTY_HE - he = (HE*) hv_common(seen, arg, NULL, 0, 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); - if (HeVAL(he)) - continue; + he = (HE*) hv_common(seen, NULL, SvPVX(keysv), SvCUR(keysv), 0, HV_FETCH_LVALUE | HV_FETCH_EMPTY_HE, NULL, 0); + if (HeVAL(he)) + continue; - HeVAL(he) = &PL_sv_undef; + HeVAL(he) = &PL_sv_undef; #else - if (hv_exists_ent(seen, arg, 0)) - continue; + if(hv_exists(seen, SvPVX(keysv), SvCUR(keysv))) + continue; - hv_store_ent(seen, arg, &PL_sv_yes, 0); + hv_store(seen, SvPVX(keysv), SvCUR(keysv), &PL_sv_yes, 0); #endif - if(GIMME_V == G_ARRAY) - ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSVpvn("", 0)); - retcount++; - } + if(GIMME_V == G_ARRAY) + ST(retcount) = SvOK(arg) ? arg : sv_2mortal(newSViv(0)); + retcount++; } finish: @@ -1302,7 +1614,7 @@ CODE: ST(0) = boolSV((SvPOK(sv) || SvPOKp(sv)) && (SvNIOK(sv) || SvNIOKp(sv))); XSRETURN(1); -char * +SV * blessed(sv) SV *sv PROTOTYPE: $ @@ -1312,8 +1624,12 @@ CODE: if(!(SvROK(sv) && SvOBJECT(SvRV(sv)))) XSRETURN_UNDEF; - - RETVAL = (char*)sv_reftype(SvRV(sv),TRUE); +#ifdef HAVE_UNICODE_PACKAGE_NAMES + RETVAL = newSVsv(sv_ref(NULL, SvRV(sv), TRUE)); +#else + RETVAL = newSV(0); + sv_setpv(RETVAL, sv_reftype(SvRV(sv), TRUE)); +#endif } OUTPUT: RETVAL @@ -1601,15 +1917,18 @@ PPCODE: /* under debugger, provide information about sub location */ if (PL_DBsub && CvGV(cv)) { HV* DBsub = GvHV(PL_DBsub); - HE* old_data; + HE* old_data = NULL; GV* oldgv = CvGV(cv); HV* oldhv = GvSTASH(oldgv); - SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); - sv_catpvn(old_full_name, "::", 2); - sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); - old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); + if (oldhv) { + SV* old_full_name = sv_2mortal(newSVpvn_flags(HvNAME(oldhv), HvNAMELEN_get(oldhv), HvNAMEUTF8(oldhv) ? SVf_UTF8 : 0)); + sv_catpvn(old_full_name, "::", 2); + sv_catpvn_flags(old_full_name, GvNAME(oldgv), GvNAMELEN(oldgv), GvNAMEUTF8(oldgv) ? SV_CATUTF8 : SV_CATBYTES); + + old_data = hv_fetch_ent(DBsub, old_full_name, 0, 0); + } if (old_data && HeVAL(old_data)) { SV* new_full_name = sv_2mortal(newSVpvn_flags(HvNAME(stash), HvNAMELEN_get(stash), HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); @@ -1660,6 +1979,7 @@ subname(code) PREINIT: CV *cv; GV *gv; + const char *stashname; PPCODE: if (!SvROK(code) && SvGMAGICAL(code)) mg_get(code); @@ -1670,7 +1990,12 @@ PPCODE: if(!(gv = CvGV(cv))) XSRETURN(0); - mPUSHs(newSVpvf("%s::%s", HvNAME(GvSTASH(gv)), GvNAME(gv))); + if(GvSTASH(gv)) + stashname = HvNAME(GvSTASH(gv)); + else + stashname = "__ANON__"; + + mPUSHs(newSVpvf("%s::%s", stashname, GvNAME(gv))); XSRETURN(1); BOOT: diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm index b650d3585ac..e582d608743 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util.pm @@ -12,16 +12,20 @@ require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw( - all any first min max minstr maxstr none notall product reduce sum sum0 shuffle uniq uniqnum uniqstr + all any first min max minstr maxstr none notall product reduce reductions sum sum0 + sample shuffle uniq uniqint uniqnum uniqstr head tail pairs unpairs pairkeys pairvalues pairmap pairgrep pairfirst ); -our $VERSION = "1.50"; +our $VERSION = "1.55"; our $XS_VERSION = $VERSION; -$VERSION = eval $VERSION; +$VERSION =~ tr/_//d; require XSLoader; XSLoader::load('List::Util', $XS_VERSION); +# Used by shuffle() +our $RAND; + sub import { my $pkg = caller; @@ -38,6 +42,7 @@ sub import # For objects returned by pairs() sub List::Util::_Pair::key { shift->[0] } sub List::Util::_Pair::value { shift->[1] } +sub List::Util::_Pair::TO_JSON { [ @{+shift} ] } =head1 NAME @@ -46,13 +51,13 @@ List::Util - A selection of general-utility list subroutines =head1 SYNOPSIS use List::Util qw( - reduce any all none notall first + reduce any all none notall first reductions max maxstr min minstr product sum sum0 pairs unpairs pairkeys pairvalues pairfirst pairgrep pairmap - shuffle uniq uniqnum uniqstr + shuffle uniq uniqint uniqnum uniqstr ); =head1 DESCRIPTION @@ -68,7 +73,8 @@ By default C<List::Util> does not export any subroutines. =head1 LIST-REDUCTION FUNCTIONS -The following set of functions all reduce a list down to a single value. +The following set of functions all apply a given block of code to a list of +values. =cut @@ -128,8 +134,28 @@ block that accumulates lengths by writing this instead as: $total = reduce { $a + length $b } 0, @strings -The remaining list-reduction functions are all specialisations of this generic -idea. +The other scalar-returning list reduction functions are all specialisations of +this generic idea. + +=head2 reductions + + @results = reductions { BLOCK } @list + +I<Since version 1.54.> + +Similar to C<reduce> except that it also returns the intermediate values along +with the final result. As before, C<$a> is set to the first element of the +given list, and the C<BLOCK> is then called once for remaining item in the +list set into C<$b>, with the result being captured for return as well as +becoming the new value for C<$a>. + +The returned list will begin with the initial value for C<$a>, followed by +each return value from the block in order. The final value of the result will +be identical to what the C<reduce> function would have returned given the same +block and list. + + reduce { "$a-$b" } "a".."d" # "a-b-c-d" + reductions { "$a-$b" } "a".."d" # "a", "a-b", "a-b-c", "a-b-c-d" =head2 any @@ -341,6 +367,9 @@ equivalent: ... } +Since version C<1.51> they also have a C<TO_JSON> method to ease +serialisation. + =head2 unpairs my @kvlist = unpairs @pairs @@ -485,6 +514,25 @@ Returns the values of the input in a random order @cards = shuffle 0..51 # 0..51 in a random order +This function is affected by the C<$RAND> variable. + +=cut + +=head2 sample + + my @items = sample $count, @values + +I<Since version 1.54.> + +Randomly select the given number of elements from the input list. Any given +position in the input list will be selected at most once. + +If there are fewer than C<$count> items in the list then the function will +return once all of them have been randomly selected; effectively the function +behaves similarly to L</shuffle>. + +This function is affected by the C<$RAND> variable. + =head2 uniq my @subset = uniq @values @@ -505,6 +553,28 @@ string, and no warning will be produced. It is left as-is in the returned list. Subsequent C<undef> values are still considered identical to the first, and will be removed. +=head2 uniqint + + my @subset = uniqint @values + +I<Since version 1.55.> + +Filters a list of values to remove subsequent duplicates, as judged by an +integer numerical equality test. Preserves the order of unique elements, and +retains the first value of any duplicate set. Values in the returned list will +be coerced into integers. + + my $count = uniqint @values + +In scalar context, returns the number of elements that would have been +returned as a list. + +Note that C<undef> is treated much as other numerical operations treat it; it +compares equal to zero but additionally produces a warning if such warnings +are enabled (C<use warnings 'uninitialized';>). In addition, an C<undef> in +the returned list is coerced into a numerical zero, so that the entire list of +values returned by C<uniqint> are well-behaved as integers. + =head2 uniqnum my @subset = uniqnum @values @@ -557,6 +627,8 @@ entire list of values returned by C<uniqstr> are well-behaved as strings. my @values = head $size, @list; +I<Since version 1.50.> + Returns the first C<$size> elements from C<@list>. If C<$size> is negative, returns all but the last C<$size> elements from C<@list>. @@ -570,6 +642,8 @@ all but the last C<$size> elements from C<@list>. my @values = tail $size, @list; +I<Since version 1.50.> + Returns the last C<$size> elements from C<@list>. If C<$size> is negative, returns all but the first C<$size> elements from C<@list>. @@ -579,6 +653,21 @@ all but the first C<$size> elements from C<@list>. @result = tail -2, qw( foo bar baz ); # baz +=head1 CONFIGURATION VARIABLES + +=head2 $RAND + + local $List::Util::RAND = sub { ... }; + +I<Since version 1.54.> + +This package variable is used by code which needs to generate random numbers +(such as the L</shuffle> and L</sample> functions). If set to a CODE reference +it provides an alternative to perl's builtin C<rand()> function. When a new +random number is needed this function will be invoked with no arguments and is +expected to return a floating-point value, of which only the fractional part +will be used. + =head1 KNOWN BUGS =head2 RT #95409 diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm index c8c066f8256..88f663f0ec4 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/List/Util/XS.pm @@ -3,8 +3,8 @@ use strict; use warnings; use List::Util; -our $VERSION = "1.50"; # FIXUP -$VERSION = eval $VERSION; # FIXUP +our $VERSION = "1.55"; # FIXUP +$VERSION =~ tr/_//d; # FIXUP 1; __END__ diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm index 69821587059..a7345aad78a 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Scalar/Util.pm @@ -17,8 +17,8 @@ our @EXPORT_OK = qw( dualvar isdual isvstring looks_like_number openhandle readonly set_prototype tainted ); -our $VERSION = "1.50"; -$VERSION = eval $VERSION; +our $VERSION = "1.55"; +$VERSION =~ tr/_//d; require List::Util; # List::Util loads the XS List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863) @@ -134,6 +134,11 @@ is returned. $obj = bless {}, "Foo"; $type = reftype $obj; # HASH +Note that for internal reasons, all precompiled regexps (C<qr/.../>) are +blessed references; thus C<ref()> returns the package name string C<"Regexp"> +on these but C<reftype()> will return the underlying C structure type of +C<"REGEXP"> in all capitals. + =head2 weaken weaken( $ref ); @@ -276,8 +281,8 @@ L<perlapi/looks_like_number>. my $fh = openhandle( $fh ); -Returns C<$fh> itself if C<$fh> may be used as a filehandle and is open, or is -is a tied handle. Otherwise C<undef> is returned. +Returns C<$fh> itself, if C<$fh> may be used as a filehandle and is open, or if +it is a tied handle. Otherwise C<undef> is returned. $fh = openhandle(*STDIN); # \*STDIN $fh = openhandle(\*STDIN); # \*STDIN diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm index edcc6544f6e..d7b59aebab8 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/lib/Sub/Util.pm @@ -15,8 +15,8 @@ our @EXPORT_OK = qw( subname set_subname ); -our $VERSION = "1.50"; -$VERSION = eval $VERSION; +our $VERSION = "1.55"; +$VERSION =~ tr/_//d; require List::Util; # as it has the XS List::Util->VERSION( $VERSION ); # Ensure we got the right XS version (RT#100863) @@ -95,8 +95,10 @@ I<Since version 1.40.> Returns the name of the given C<$code> reference, if it has one. Normal named subs will give a fully-qualified name consisting of the package and the localname separated by C<::>. Anonymous code references will give C<__ANON__> -as the localname. If a name has been set using L</set_subname>, this name will -be returned instead. +as the localname. If the package the code was compiled in has been deleted +(e.g. using C<delete_package> from L<Symbol>), C<__ANON__> will be returned as +the package name. If a name has been set using L</set_subname>, this name will be +returned instead. This function was inspired by C<sub_fullname> from L<Sub::Identify>. The remaining functions that C<Sub::Identify> implements can easily be emulated diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t index 21d3a9ade49..49eb355ffc5 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/blessed.t @@ -3,28 +3,28 @@ use strict; use warnings; -use Test::More tests => 11; +use Test::More tests => 12; use Scalar::Util qw(blessed); my $t; -ok(!defined blessed(undef), 'undef is not blessed'); -ok(!defined blessed(1), 'Numbers are not blessed'); -ok(!defined blessed('A'), 'Strings are not blessed'); -ok(!defined blessed({}), 'Unblessed HASH-ref'); -ok(!defined blessed([]), 'Unblessed ARRAY-ref'); -ok(!defined blessed(\$t), 'Unblessed SCALAR-ref'); +ok(!defined blessed(undef), 'undef is not blessed'); +ok(!defined blessed(1), 'Numbers are not blessed'); +ok(!defined blessed('A'), 'Strings are not blessed'); +ok(!defined blessed({}), 'Unblessed HASH-ref'); +ok(!defined blessed([]), 'Unblessed ARRAY-ref'); +ok(!defined blessed(\$t), 'Unblessed SCALAR-ref'); my $x; $x = bless [], "ABC"; -is(blessed($x), "ABC", 'blessed ARRAY-ref'); +is(blessed($x), "ABC", 'blessed ARRAY-ref'); $x = bless {}, "DEF"; -is(blessed($x), "DEF", 'blessed HASH-ref'); +is(blessed($x), "DEF", 'blessed HASH-ref'); $x = bless {}, "0"; -cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref'); +cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref'); { my $blessed = do { @@ -46,3 +46,11 @@ cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref'); ::is( ::blessed($obj), __PACKAGE__, "blessed on broken isa() and can()" ); } +SKIP: { + # Unicode package names only supported in perl 5.16 onwards + skip "Unicode package names are not supported", 1 if $] < 5.016; + + my $utf8_pack= "X\x{100}"; + my $obj= bless {}, $utf8_pack; + ::is( ::blessed($obj), $utf8_pack, "blessed preserves utf8ness for utf8 class names" ); +} diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t index 08dff11778e..bd77c969b5a 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/dualvar.t @@ -5,8 +5,8 @@ use warnings; use Scalar::Util (); use Test::More (grep { /dualvar/ } @Scalar::Util::EXPORT_FAIL) - ? (skip_all => 'dualvar requires XS version') - : (tests => 41); + ? (skip_all => 'dualvar requires XS version') + : (tests => 41); use Config; Scalar::Util->import('dualvar'); @@ -15,44 +15,44 @@ Scalar::Util->import('isdual'); my $var; $var = dualvar( 2.2,"string"); -ok( isdual($var), 'Is a dualvar'); -ok( $var == 2.2, 'Numeric value'); -ok( $var eq "string", 'String value'); +ok( isdual($var), 'Is a dualvar'); +ok( $var == 2.2, 'Numeric value'); +ok( $var eq "string", 'String value'); my $var2 = $var; -ok( isdual($var2), 'Is a dualvar'); -ok( $var2 == 2.2, 'copy Numeric value'); -ok( $var2 eq "string", 'copy String value'); +ok( isdual($var2), 'Is a dualvar'); +ok( $var2 == 2.2, 'copy Numeric value'); +ok( $var2 eq "string", 'copy String value'); $var++; -ok( ! isdual($var), 'No longer dualvar'); -ok( $var == 3.2, 'inc Numeric value'); -ok( $var ne "string", 'inc String value'); +ok( ! isdual($var), 'No longer dualvar'); +ok( $var == 3.2, 'inc Numeric value'); +ok( $var ne "string", 'inc String value'); my $numstr = "10.2"; my $numtmp = int($numstr); # use $numstr as an int $var = dualvar($numstr, ""); -ok( isdual($var), 'Is a dualvar'); -ok( $var == $numstr, 'NV'); +ok( isdual($var), 'Is a dualvar'); +ok( $var == $numstr, 'NV'); SKIP: { skip("dualvar with UV value known to fail with $]",3) if $] < 5.006_001; my $bits = ($Config{'use64bitint'}) ? 63 : 31; $var = dualvar(1<<$bits, ""); - ok( isdual($var), 'Is a dualvar'); - ok( $var == (1<<$bits), 'UV 1'); - ok( $var > 0, 'UV 2'); + ok( isdual($var), 'Is a dualvar'); + ok( $var == (1<<$bits), 'UV 1'); + ok( $var > 0, 'UV 2'); } # Create a dualvar "the old fashioned way" $var = "10"; -ok( ! isdual($var), 'Not a dualvar'); +ok( ! isdual($var), 'Not a dualvar'); my $foo = $var + 0; -ok( isdual($var), 'Is a dualvar'); +ok( isdual($var), 'Is a dualvar'); { package Tied; @@ -63,9 +63,9 @@ ok( isdual($var), 'Is a dualvar'); tie my $tied, 'Tied'; $var = dualvar($tied, "ok"); -ok(isdual($var), 'Is a dualvar'); -ok($var == 7.5, 'Tied num'); -ok($var eq 'ok', 'Tied str'); +ok(isdual($var), 'Is a dualvar'); +ok($var == 7.5, 'Tied num'); +ok($var eq 'ok', 'Tied str'); SKIP: { diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t index ba7726ae562..3f008e703c0 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/first.t @@ -5,10 +5,10 @@ use warnings; use List::Util qw(first); use Test::More; -plan tests => 22 + ($::PERL_ONLY ? 0 : 2); +plan tests => 24; my $v; -ok(defined &first, 'defined'); +ok(defined &first, 'defined'); $v = first { 8 == ($_ - 1) } 9,4,5,6; is($v, 9, 'one more than 8'); @@ -20,7 +20,7 @@ $v = first { 0 }; is($v, undef, 'no args'); $v = first { $_->[1] le "e" and "e" le $_->[2] } - [qw(a b c)], [qw(d e f)], [qw(g h i)]; + [qw(a b c)], [qw(d e f)], [qw(g h i)]; is_deeply($v, [qw(d e f)], 'reference args'); # Check that eval{} inside the block works correctly @@ -89,11 +89,9 @@ SKIP: { is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged"); } -# The remainder of the tests are only relevant for the XS -# implementation. The Perl-only implementation behaves differently -# (and more flexibly) in a way that we can't emulate from XS. -if (!$::PERL_ONLY) { SKIP: { - +# These tests are only relevant for the real multicall implementation. The +# psuedo-multicall implementation behaves differently. +SKIP: { $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once skip("Poor man's MULTICALL can't cope", 2) if !$List::Util::REAL_MULTICALL; @@ -105,8 +103,7 @@ if (!$::PERL_ONLY) { SKIP: { # Can we goto a subroutine? eval {()=first{goto sub{}} 1,2;}; like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); - -} } +} use constant XSUBC_TRUE => 1; use constant XSUBC_FALSE => 0; diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t index 9d345aa26fa..3649d41c59f 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/isvstring.t @@ -6,18 +6,18 @@ use warnings; $|=1; use Scalar::Util (); use Test::More (grep { /isvstring/ } @Scalar::Util::EXPORT_FAIL) - ? (skip_all => 'isvstring requires XS version') - : (tests => 3); + ? (skip_all => 'isvstring requires XS version') + : (tests => 3); Scalar::Util->import(qw[isvstring]); my $vs = ord("A") == 193 ? 241.75.240 : 49.46.48; -ok( $vs == "1.0", 'dotted num'); -ok( isvstring($vs), 'isvstring'); +ok( $vs == "1.0", 'dotted num'); +ok( isvstring($vs), 'isvstring'); my $sv = "1.0"; -ok( !isvstring($sv), 'not isvstring'); +ok( !isvstring($sv), 'not isvstring'); diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t index df9ea3aea93..84583446716 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/lln.t @@ -10,18 +10,18 @@ foreach my $num (qw(1 -1 +1 1.0 +1.0 -1.0 -1.0e-12)) { ok(looks_like_number($num), "'$num'"); } -is(!!looks_like_number("Inf"), $] >= 5.006001, 'Inf'); -is(!!looks_like_number("Infinity"), $] >= 5.008, 'Infinity'); -is(!!looks_like_number("NaN"), $] >= 5.008, 'NaN'); -is(!!looks_like_number("foo"), '', 'foo'); -is(!!looks_like_number(undef), '', 'undef'); -is(!!looks_like_number({}), '', 'HASH Ref'); -is(!!looks_like_number([]), '', 'ARRAY Ref'); +is(!!looks_like_number("Inf"), $] >= 5.006001, 'Inf'); +is(!!looks_like_number("Infinity"), $] >= 5.008, 'Infinity'); +is(!!looks_like_number("NaN"), $] >= 5.008, 'NaN'); +is(!!looks_like_number("foo"), '', 'foo'); +is(!!looks_like_number(undef), '', 'undef'); +is(!!looks_like_number({}), '', 'HASH Ref'); +is(!!looks_like_number([]), '', 'ARRAY Ref'); use Math::BigInt; my $bi = Math::BigInt->new('1234567890'); -is(!!looks_like_number($bi), 1, 'Math::BigInt'); -is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt'); +is(!!looks_like_number($bi), 1, 'Math::BigInt'); +is(!!looks_like_number("$bi"), 1, 'Stringified Math::BigInt'); { package Foo; sub TIEHASH { bless {} } @@ -29,9 +29,9 @@ sub FETCH { $_[1] } } my %foo; tie %foo, 'Foo'; -is(!!looks_like_number($foo{'abc'}), '', 'Tied'); -is(!!looks_like_number($foo{'123'}), 1, 'Tied'); +is(!!looks_like_number($foo{'abc'}), '', 'Tied'); +is(!!looks_like_number($foo{'123'}), 1, 'Tied'); -is(!!looks_like_number("\x{1815}"), '', 'MONGOLIAN DIGIT FIVE'); +is(!!looks_like_number("\x{1815}"), '', 'MONGOLIAN DIGIT FIVE'); # We should copy some of perl core tests like t/base/num.t here diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t index e65123cc2c7..7d7a6a9bb59 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/pair.t @@ -3,8 +3,9 @@ use strict; use warnings; -use Test::More tests => 27; +use Test::More tests => 29; use List::Util qw(pairgrep pairfirst pairmap pairs unpairs pairkeys pairvalues); +use Scalar::Util qw(blessed); no warnings 'misc'; # avoid "Odd number of elements" warnings most of the time @@ -104,6 +105,10 @@ is_deeply( [ pairs one => 1, two => ], my @p = pairs one => 1, two => 2; is( $p[0]->key, "one", 'pairs ->key' ); is( $p[0]->value, 1, 'pairs ->value' ); + is_deeply( $p[0]->TO_JSON, + [ one => 1 ], + 'pairs ->TO_JSON' ); + ok( !blessed($p[0]->TO_JSON) , 'pairs ->TO_JSON is not blessed' ); } is_deeply( [ unpairs [ four => 4 ], [ five => 5 ], [ six => 6 ] ], diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t index c8e19ff4c85..1333adeb4fc 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/readonly.t @@ -6,26 +6,26 @@ use warnings; use Scalar::Util qw(readonly); use Test::More tests => 11; -ok( readonly(1), 'number constant'); +ok( readonly(1), 'number constant'); my $var = 2; -ok( !readonly($var), 'number variable'); -is( $var, 2, 'no change to number variable'); +ok( !readonly($var), 'number variable'); +is( $var, 2, 'no change to number variable'); -ok( readonly("fred"), 'string constant'); +ok( readonly("fred"), 'string constant'); $var = "fred"; -ok( !readonly($var), 'string variable'); -is( $var, 'fred', 'no change to string variable'); +ok( !readonly($var), 'string variable'); +is( $var, 'fred', 'no change to string variable'); $var = \2; -ok( !readonly($var), 'reference to constant'); -ok( readonly($$var), 'de-reference to constant'); +ok( !readonly($var), 'reference to constant'); +ok( readonly($$var), 'de-reference to constant'); -ok( !readonly(*STDOUT), 'glob'); +ok( !readonly(*STDOUT), 'glob'); sub try { diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t index 848c34fb221..67fdbaac228 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reduce.t @@ -5,25 +5,25 @@ use warnings; use List::Util qw(reduce min); use Test::More; -plan tests => 30 + ($::PERL_ONLY ? 0 : 2); +plan tests => 33; my $v = reduce {}; -is( $v, undef, 'no args'); +is( $v, undef, 'no args'); $v = reduce { $a / $b } 756,3,7,4; -is( $v, 9, '4-arg divide'); +is( $v, 9, '4-arg divide'); $v = reduce { $a / $b } 6; -is( $v, 6, 'one arg'); +is( $v, 6, 'one arg'); my @a = map { rand } 0 .. 20; $v = reduce { $a < $b ? $a : $b } @a; -is( $v, min(@a), 'min'); +is( $v, min(@a), 'min'); @a = map { pack("C", int(rand(256))) } 0 .. 20; $v = reduce { $a . $b } @a; -is( $v, join("",@a), 'concat'); +is( $v, join("",@a), 'concat'); sub add { my($aa, $bb) = @_; @@ -31,26 +31,26 @@ sub add { } $v = reduce { my $t="$a $b\n"; 0+add($a, $b) } 3, 2, 1; -is( $v, 6, 'call sub'); +is( $v, 6, 'call sub'); # Check that eval{} inside the block works correctly $v = reduce { eval { die }; $a + $b } 0,1,2,3,4; -is( $v, 10, 'use eval{}'); +is( $v, 10, 'use eval{}'); $v = !defined eval { reduce { die if $b > 2; $a + $b } 0,1,2,3,4 }; ok($v, 'die'); sub foobar { reduce { (defined(wantarray) && !wantarray) ? $a+1 : 0 } 0,1,2,3 } ($v) = foobar(); -is( $v, 3, 'scalar context'); +is( $v, 3, 'scalar context'); sub add2 { $a + $b } $v = reduce \&add2, 1,2,3; -is( $v, 6, 'sub reference'); +is( $v, 6, 'sub reference'); $v = reduce { add2() } 3,4,5; -is( $v, 12, 'call sub'); +is( $v, 12, 'call sub'); $v = reduce { eval "$a + $b" } 1,2,3; @@ -125,11 +125,9 @@ SKIP: { is($ok, '', 'Not a subroutine reference'); } -# The remainder of the tests are only relevant for the XS -# implementation. The Perl-only implementation behaves differently -# (and more flexibly) in a way that we can't emulate from XS. -if (!$::PERL_ONLY) { SKIP: { - +# These tests are only relevant for the real multicall implementation. The +# psuedo-multicall implementation behaves differently. +SKIP: { $List::Util::REAL_MULTICALL ||= 0; # Avoid use only once skip("Poor man's MULTICALL can't cope", 2) if !$List::Util::REAL_MULTICALL; @@ -141,8 +139,12 @@ if (!$::PERL_ONLY) { SKIP: { # Can we goto a subroutine? eval {()=reduce{goto sub{}} 1,2;}; like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub"); +} -} } +{ + my @ret = reduce { $a + $b } 1 .. 5; + is_deeply( \@ret, [ 15 ], 'reduce in list context yields only final answer' ); +} # XSUB callback use constant XSUBC => 42; @@ -162,4 +164,4 @@ ok($@ =~ /^Not a subroutine reference/, 'check for code reference'); my @names = ("a\x{100}c", "d\x{101}efgh", 'ijk'); my $longest = reduce { length($a) > length($b) ? $a : $b } @names; -is( length($longest), 6, 'missing SMG rt#121992'); +is( length($longest), 6, 'missing SMG rt#121992'); diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t index 8d7c441bb32..91b6fa9ec68 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/refaddr.t @@ -64,9 +64,10 @@ foreach my $r ({}, \$t, [], \*F, sub {}) { package FooBar; -use overload '0+' => sub { 10 }, - '+' => sub { 10 + $_[1] }, - '""' => sub { "10" }; +use overload + '0+' => sub { 10 }, + '+' => sub { 10 + $_[1] }, + '""' => sub { "10" }; package MyTie; @@ -85,21 +86,21 @@ use Scalar::Util qw(refaddr); sub TIEHASH { - my $pkg = shift; - return bless [ @_ ], $pkg; + my $pkg = shift; + return bless [ @_ ], $pkg; } sub FETCH { - my $self = shift; - my $key = shift; - my ($underlying) = @$self; - return $underlying->{refaddr($key)}; + my $self = shift; + my $key = shift; + my ($underlying) = @$self; + return $underlying->{refaddr($key)}; } sub STORE { - my $self = shift; - my $key = shift; - my $value = shift; - my ($underlying) = @$self; - return ($underlying->{refaddr($key)} = $key); + my $self = shift; + my $key = shift; + my $value = shift; + my ($underlying) = @$self; + return ($underlying->{refaddr($key)} = $key); } diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t index a40e41493b5..2fefd8fbef0 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reftype.t @@ -18,18 +18,18 @@ $s = undef; # SvTYPE($s) is SVt_RV, but SvROK($s) is false my $t; my @test = ( - [ undef, 1, 'number' ], - [ undef, 'A', 'string' ], - [ HASH => {}, 'HASH ref' ], - [ ARRAY => [], 'ARRAY ref' ], - [ SCALAR => \$t, 'SCALAR ref' ], - [ SCALAR => \$s, 'SCALAR ref (but SVt_RV)' ], - [ REF => \(\$t), 'REF ref' ], - [ GLOB => \*F, 'tied GLOB ref' ], - [ GLOB => gensym, 'GLOB ref' ], - [ CODE => sub {}, 'CODE ref' ], - [ IO => *STDIN{IO},'IO ref' ], - [ $RE => qr/x/, 'REGEEXP' ], + [ undef, 1, 'number' ], + [ undef, 'A', 'string' ], + [ HASH => {}, 'HASH ref' ], + [ ARRAY => [], 'ARRAY ref' ], + [ SCALAR => \$t, 'SCALAR ref' ], + [ SCALAR => \$s, 'SCALAR ref (but SVt_RV)' ], + [ REF => \(\$t), 'REF ref' ], + [ GLOB => \*F, 'tied GLOB ref' ], + [ GLOB => gensym, 'GLOB ref' ], + [ CODE => sub {}, 'CODE ref' ], + [ IO => *STDIN{IO}, 'IO ref' ], + [ $RE => qr/x/, 'REGEEXP' ], ); foreach my $test (@test) { diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t index dff963715dc..7135b5163ce 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/shuffle.t @@ -3,24 +3,35 @@ use strict; use warnings; -use Test::More tests => 6; +use Test::More tests => 7; use List::Util qw(shuffle); my @r; @r = shuffle(); -ok( !@r, 'no args'); +ok( !@r, 'no args'); @r = shuffle(9); -is( 0+@r, 1, '1 in 1 out'); -is( $r[0], 9, 'one arg'); +is( 0+@r, 1, '1 in 1 out'); +is( $r[0], 9, 'one arg'); my @in = 1..100; @r = shuffle(@in); -is( 0+@r, 0+@in, 'arg count'); +is( 0+@r, 0+@in, 'arg count'); -isnt( "@r", "@in", 'result different to args'); +isnt( "@r", "@in", 'result different to args'); my @s = sort { $a <=> $b } @r; -is( "@in", "@s", 'values'); +is( "@in", "@s", 'values'); + +{ + local $List::Util::RAND = sub { 4/10 }; # chosen by a fair die + + @r = shuffle(1..10); + is_deeply( + [ shuffle(1..10) ], + [ shuffle(1..10) ], + 'rigged rand() yields predictable output' + ); +} diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t index e2c416df8c0..5247a37b004 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sum.t @@ -9,7 +9,7 @@ use Config; use List::Util qw(sum); my $v = sum; -is( $v, undef, 'no args'); +is( $v, undef, 'no args'); $v = sum(9); is( $v, 9, 'one arg'); diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t index fb83c86c327..1197b295869 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/tainted.t @@ -13,10 +13,10 @@ my $var = 2; ok( !tainted($var), 'known variable'); -ok( tainted($^X), 'interpreter variable'); +ok( tainted($^X), 'interpreter variable'); $var = $^X; -ok( tainted($var), 'copy of interpreter variable'); +ok( tainted($var), 'copy of interpreter variable'); { package Tainted; diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t index 86ded9794fc..39a4167cd6a 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/weak.t @@ -7,8 +7,8 @@ use Config; use Scalar::Util (); use Test::More ((grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) and !$ENV{PERL_CORE}) - ? (skip_all => 'weaken requires XS version') - : (tests => 28); + ? (skip_all => 'weaken requires XS version') + : (tests => 28); Scalar::Util->import(qw(weaken unweaken isweak)); diff --git a/gnu/usr.bin/perl/cpan/Socket/Makefile.PL b/gnu/usr.bin/perl/cpan/Socket/Makefile.PL index 5eab38080a9..b69f50c9c78 100644 --- a/gnu/usr.bin/perl/cpan/Socket/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Socket/Makefile.PL @@ -165,9 +165,9 @@ my @names = ( qw( AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6 - AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI - AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN - AF_X25 + AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_LOCAL AF_MAX AF_NBS AF_NIT + AF_NS AF_OSI AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER + AF_WAN AF_X25 AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST @@ -203,9 +203,9 @@ my @names = ( PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6 - PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI - PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN - PF_X25 + PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_LOCAL PF_MAX PF_NBS PF_NIT + PF_NS PF_OSI PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER + PF_WAN PF_X25 SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_TIMESTAMP diff --git a/gnu/usr.bin/perl/cpan/Socket/Socket.pm b/gnu/usr.bin/perl/cpan/Socket/Socket.pm index 370deef1036..2c6b5e45d04 100644 --- a/gnu/usr.bin/perl/cpan/Socket/Socket.pm +++ b/gnu/usr.bin/perl/cpan/Socket/Socket.pm @@ -3,7 +3,7 @@ package Socket; use strict; { use 5.006001; } -our $VERSION = '2.027'; +our $VERSION = '2.029'; =head1 NAME diff --git a/gnu/usr.bin/perl/cpan/Socket/Socket.xs b/gnu/usr.bin/perl/cpan/Socket/Socket.xs index b11ea751a7d..e46c93e1719 100644 --- a/gnu/usr.bin/perl/cpan/Socket/Socket.xs +++ b/gnu/usr.bin/perl/cpan/Socket/Socket.xs @@ -79,6 +79,25 @@ typedef int socklen_t; #endif +/* + * Under Windows, sockaddr_un is defined in afunix.h. Unfortunately + * MinGW and SDKs older than 10.0.17063.0 don't have it, so we have to + * define it here. Don't worry, it's portable. Windows has ironclad ABI + * stability guarantees which means that the definitions will *never* + * change. + */ +#ifndef UNIX_PATH_MAX + +#define UNIX_PATH_MAX 108 + +struct sockaddr_un +{ + USHORT sun_family; + char sun_path[UNIX_PATH_MAX]; +}; + +#endif + static int inet_pton(int af, const char *src, void *dst) { struct sockaddr_storage ss; @@ -813,7 +832,7 @@ pack_sockaddr_un(pathname) SV * pathname CODE: { -#ifdef I_SYS_UN +#if defined(I_SYS_UN) || defined(WIN32) struct sockaddr_un sun_ad; /* fear using sun */ STRLEN len; char * pathname_pv; @@ -883,7 +902,7 @@ unpack_sockaddr_un(sun_sv) SV * sun_sv CODE: { -#ifdef I_SYS_UN +#if defined(I_SYS_UN) || defined(WIN32) struct sockaddr_un addr; STRLEN sockaddrlen; char * sun_ad; diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL b/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL index c76963d0b96..d09ba69fc90 100644 --- a/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/Makefile.PL @@ -14,7 +14,7 @@ if ($] < 5.008) { } # create a lib/ dir in order to avoid warnings in Test::Distribution -mkdir "lib", $ENV{PERL_CORE} ? 0770 : 0755; +mkdir "lib", 0755; # virtual paths given to EU::MM my %virtual_path = ( 'Syslog.pm' => '$(INST_LIBDIR)/Syslog.pm' ); diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm b/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm index 96e8632f6e0..ebbac5db27b 100644 --- a/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/Syslog.pm @@ -15,7 +15,7 @@ require 5.005; { no strict 'vars'; - $VERSION = '0.35'; + $VERSION = '0.36'; %EXPORT_TAGS = ( standard => [qw(openlog syslog closelog setlogmask)], @@ -935,7 +935,7 @@ Sys::Syslog - Perl interface to the UNIX syslog(3) calls =head1 VERSION -This is the documentation of version 0.35 +This is the documentation of version 0.36 =head1 SYNOPSIS diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/lib/Term/ANSIColor.pm b/gnu/usr.bin/perl/cpan/Term-ANSIColor/lib/Term/ANSIColor.pm index 730124b7f6d..db329081406 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/lib/Term/ANSIColor.pm +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/lib/Term/ANSIColor.pm @@ -1,17 +1,17 @@ # Color screen output using ANSI escape sequences. # -# Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010, -# 2011, 2012, 2013, 2014, 2015, 2016 Russ Allbery <rra@cpan.org> -# Copyright 1996 Zenin -# Copyright 2012 Kurt Starsinic <kstarsinic@gmail.com> +# This module provides utility functions (in two different forms) for coloring +# output with ANSI escape sequences. # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# PUSH/POP support submitted 2007 by openmethods.com voice solutions +# This module is sometimes used in low-memory environments, so avoid use of +# \d, \w, [:upper:], and similar constructs in the most important functions +# (color, colored, AUTOLOAD, and the generated constant functions) since +# loading the Unicode attribute files consumes a lot of memory. # # Ah, September, when the sysadmins turn colors and fall off the trees.... # -- Dave Van Domelen +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl ############################################################################## # Modules and declarations @@ -19,15 +19,15 @@ package Term::ANSIColor; -use 5.006; +use 5.008; use strict; use warnings; # Also uses Carp but loads it on demand to reduce memory usage. -use Exporter (); +use Exporter; -# use Exporter plus @ISA instead of use base for 5.6 compatibility. +# use Exporter plus @ISA instead of use base to reduce memory usage. ## no critic (ClassHierarchies::ProhibitExplicitISA) # Declare variables that should be set in BEGIN for robustness. @@ -41,7 +41,7 @@ our $AUTOLOAD; # against circular module loading (not that we load any modules, but # consistency is good). BEGIN { - $VERSION = '4.06'; + $VERSION = '5.01'; # All of the basic supported constants, used in %EXPORT_TAGS. my @colorlist = qw( @@ -173,7 +173,7 @@ for my $n (0 .. 23) { # Reverse lookup. Alphabetically first name for a sequence is preferred. our %ATTRIBUTES_R; -for my $attr (reverse sort keys %ATTRIBUTES) { +for my $attr (reverse(sort(keys(%ATTRIBUTES)))) { $ATTRIBUTES_R{ $ATTRIBUTES{$attr} } = $attr; } @@ -188,17 +188,18 @@ for my $code (16 .. 255) { # Import any custom colors set in the environment. our %ALIASES; -if (exists $ENV{ANSI_COLORS_ALIASES}) { +if (exists($ENV{ANSI_COLORS_ALIASES})) { my $spec = $ENV{ANSI_COLORS_ALIASES}; - $spec =~ s{\s+}{}xmsg; + $spec =~ s{ \A \s+ }{}xms; + $spec =~ s{ \s+ \z }{}xms; # Error reporting here is an interesting question. Use warn rather than # carp because carp would report the line of the use or require, which # doesn't help anyone understand what's going on, whereas seeing this code # will be more helpful. ## no critic (ErrorHandling::RequireCarping) - for my $definition (split m{,}xms, $spec) { - my ($new, $old) = split m{=}xms, $definition, 2; + for my $definition (split(m{\s*,\s*}xms, $spec)) { + my ($new, $old) = split(m{\s*=\s*}xms, $definition, 2); if (!$new || !$old) { warn qq{Bad color mapping "$definition"}; } else { @@ -249,10 +250,10 @@ sub croak { # called sub against the list of attributes, and if it's an all-caps version # of one of them, we define the sub on the fly and then run it. # -# If the environment variable ANSI_COLORS_DISABLED is set to a true value, -# just return the arguments without adding any escape sequences. This is to -# make it easier to write scripts that also work on systems without any ANSI -# support, like Windows consoles. +# If the environment variable ANSI_COLORS_DISABLED is set to a true value, or +# if the variable NO_COLOR is set, just return the arguments without adding +# any escape sequences. This is to make it easier to write scripts that also +# work on systems without any ANSI support, like Windows consoles. # # Avoid using character classes like [:upper:] and \w here, since they load # Unicode character tables and consume a ton of memory. All of our constants @@ -274,7 +275,7 @@ sub AUTOLOAD { # If colors are disabled, just return the input. Do this without # installing a sub for (marginal, unbenchmarked) speed. - if ($ENV{ANSI_COLORS_DISABLED}) { + if ($ENV{ANSI_COLORS_DISABLED} || defined($ENV{NO_COLOR})) { return join(q{}, @_); } @@ -296,7 +297,7 @@ sub AUTOLOAD { ## no critic (ValuesAndExpressions::ProhibitImplicitNewlines) my $eval_result = eval qq{ sub $AUTOLOAD { - if (\$ENV{ANSI_COLORS_DISABLED}) { + if (\$ENV{ANSI_COLORS_DISABLED} || defined(\$ENV{NO_COLOR})) { return join(q{}, \@_); } elsif (\$AUTOLOCAL && \@_) { return PUSHCOLOR('$escape') . join(q{}, \@_) . POPCOLOR; @@ -320,7 +321,6 @@ sub AUTOLOAD { $@ = $eval_err; # Dispatch to the newly-created sub. - ## no critic (References::ProhibitDoubleSigils) goto &$AUTOLOAD; } ## use critic @@ -393,25 +393,35 @@ sub LOCALCOLOR { # Throws: Text exception for any invalid attribute sub color { my (@codes) = @_; - @codes = map { split } @codes; # Return the empty string if colors are disabled. - if ($ENV{ANSI_COLORS_DISABLED}) { + if ($ENV{ANSI_COLORS_DISABLED} || defined($ENV{NO_COLOR})) { return q{}; } + # Split on whitespace and expand aliases. + @codes = map { split } @codes; + @codes = map { defined($ALIASES{$_}) ? @{ $ALIASES{$_} } : $_ } @codes; + # Build the attribute string from semicolon-separated numbers. + ## no critic (RegularExpressions::ProhibitEnumeratedClasses) my $attribute = q{}; for my $code (@codes) { $code = lc($code); if (defined($ATTRIBUTES{$code})) { $attribute .= $ATTRIBUTES{$code} . q{;}; - } elsif (defined($ALIASES{$code})) { - $attribute .= $ALIASES{$code} . q{;}; + } elsif ($code =~ m{ \A (on_)? r([0-9]+) g([0-9]+) b([0-9]+) \z }xms) { + my ($r, $g, $b) = ($2 + 0, $3 + 0, $4 + 0); + if ($r > 255 || $g > 255 || $b > 255) { + croak("Invalid attribute name $code"); + } + my $prefix = $1 ? '48' : '38'; + $attribute .= "$prefix;2;$r;$g;$b;"; } else { croak("Invalid attribute name $code"); } } + ## use critic # We added one too many semicolons for simplicity. Remove the last one. chop($attribute); @@ -444,20 +454,38 @@ sub uncolor { croak("Bad escape sequence $escape"); } - # Pull off 256-color codes (38;5;n or 48;5;n) as a unit. - push(@nums, $attrs =~ m{ ( 0*[34]8;0*5;\d+ | \d+ ) (?: ; | \z ) }xmsg); + # Pull off 256-color codes (38;5;n or 48;5;n) and true color codes + # (38;2;n;n;n or 48;2;n;n;n) as a unit. + my $regex = qr{ + ( + 0*[34]8 ; 0*2 ; \d+ ; \d+ ; \d+ + | 0*[34]8 ; 0*5 ; \d+ + | \d+ + ) + (?: ; | \z ) + }xms; + push(@nums, $attrs =~ m{$regex}xmsg); } # Now, walk the list of numbers and convert them to attribute names. # Strip leading zeroes from any of the numbers. (xterm, at least, allows # leading zeroes to be added to any number in an escape sequence.) for my $num (@nums) { - $num =~ s{ ( \A | ; ) 0+ (\d) }{$1$2}xmsg; - my $name = $ATTRIBUTES_R{$num}; - if (!defined($name)) { - croak("No name for escape sequence $num"); + if ($num =~ m{ \A 0*([34])8 ; 0*2 ; (\d+) ; (\d+) ; (\d+) \z }xms) { + my ($r, $g, $b) = ($2 + 0, $3 + 0, $4 + 0); + if ($r > 255 || $g > 255 || $b > 255) { + croak("No name for escape sequence $num"); + } + my $prefix = ($1 == 4) ? 'on_' : q{}; + push(@result, "${prefix}r${r}g${g}b${b}"); + } else { + $num =~ s{ ( \A | ; ) 0+ (\d) }{$1$2}xmsg; + my $name = $ATTRIBUTES_R{$num}; + if (!defined($name)) { + croak("No name for escape sequence $num"); + } + push(@result, $name); } - push(@result, $name); } # Return the attribute names. @@ -484,7 +512,7 @@ sub colored { my ($first, @rest) = @_; my ($string, @codes); if (ref($first) && ref($first) eq 'ARRAY') { - @codes = @{$first}; + @codes = @{$first}; $string = join(q{}, @rest); } else { $string = $first; @@ -492,7 +520,7 @@ sub colored { } # Return the string unmolested if colors are disabled. - if ($ENV{ANSI_COLORS_DISABLED}) { + if ($ENV{ANSI_COLORS_DISABLED} || defined($ENV{NO_COLOR})) { return $string; } @@ -514,19 +542,20 @@ sub colored { # Define a new color alias, or return the value of an existing alias. # # $alias - The color alias to define -# $color - The standard color the alias will correspond to (optional) +# @color - The color attributes the alias will correspond to (optional) # -# Returns: The standard color value of the alias +# Returns: The standard color value of the alias as a string (may be multiple +# attributes separated by spaces) # undef if one argument was given and the alias was not recognized # Throws: Text exceptions for invalid alias names, attempts to use a # standard color name as an alias, or an unknown standard color name sub coloralias { - my ($alias, $color) = @_; - if (!defined($color)) { - if (!exists $ALIASES{$alias}) { - return; + my ($alias, @color) = @_; + if (!@color) { + if (exists($ALIASES{$alias})) { + return join(q{ }, @{ $ALIASES{$alias} }); } else { - return $ATTRIBUTES_R{ $ALIASES{$alias} }; + return; } } @@ -538,14 +567,23 @@ sub coloralias { croak(qq{Invalid alias name "$alias"}); } elsif ($ATTRIBUTES{$alias}) { croak(qq{Cannot alias standard color "$alias"}); - } elsif (!exists $ATTRIBUTES{$color}) { - croak(qq{Invalid attribute name "$color"}); } ## use critic + # Split on whitespace and expand aliases. + @color = map { split } @color; + @color = map { defined($ALIASES{$_}) ? @{ $ALIASES{$_} } : $_ } @color; + + # Check that all of the attributes are valid. + for my $attribute (@color) { + if (!exists($ATTRIBUTES{$attribute})) { + croak(qq{Invalid attribute name "$attribute"}); + } + } + # Set the alias and return. - $ALIASES{$alias} = $ATTRIBUTES{$color}; - return $color; + $ALIASES{$alias} = [@color]; + return join(q{ }, @color); } # Given a string, strip the ANSI color codes out of that string and return the @@ -574,9 +612,12 @@ sub colorvalid { my (@codes) = @_; @codes = map { split(q{ }, lc) } @codes; for my $code (@codes) { - if (!(defined($ATTRIBUTES{$code}) || defined($ALIASES{$code}))) { - return; + next if defined($ATTRIBUTES{$code}); + next if defined($ALIASES{$code}); + if ($code =~ m{ \A (?: on_ )? r (\d+) g (\d+) b (\d+) \z }xms) { + next if ($1 <= 255 && $2 <= 255 && $3 <= 255); } + return; } return 1; } @@ -599,7 +640,7 @@ command.com NT ESC Delvare SSH OpenSSH aixterm ECMA-048 Fraktur overlining Zenin reimplemented Allbery PUSHCOLOR POPCOLOR LOCALCOLOR openmethods.com openmethods.com. grey ATTR urxvt mistyped prepending Bareword filehandle Cygwin Starsinic aterm rxvt CPAN RGB Solarized Whitespace alphanumerics -undef +undef CLICOLOR NNN GGG RRR =head1 SYNOPSIS @@ -617,8 +658,8 @@ undef # Map escape sequences back to color names. use Term::ANSIColor 1.04 qw(uncolor); - my $names = uncolor('01;31'); - print join(q{ }, @{$names}), "\n"; + my @names = uncolor('01;31'); + print join(q{ }, @names), "\n"; # Strip all color escape sequences. use Term::ANSIColor 2.01 qw(colorstrip); @@ -666,16 +707,20 @@ other through constants. It also offers the utility functions uncolor(), colorstrip(), colorvalid(), and coloralias(), which have to be explicitly imported to be used (see L</SYNOPSIS>). +If you are using Term::ANSIColor in a console command, consider supporting the +CLICOLOR standard. See L</"Supporting CLICOLOR"> for more information. + See L</COMPATIBILITY> for the versions of Term::ANSIColor that introduced particular features and the versions of Perl that included them. =head2 Supported Colors -Terminal emulators that support color divide into three types: ones that -support only eight colors, ones that support sixteen, and ones that -support 256. This module provides the ANSI escape codes for all of them. -These colors are referred to as ANSI colors 0 through 7 (normal), 8 -through 15 (16-color), and 16 through 255 (256-color). +Terminal emulators that support color divide into four types: ones that +support only eight colors, ones that support sixteen, ones that support 256, +and ones that support 24-bit color. This module provides the ANSI escape +codes for all of them. These colors are referred to as ANSI colors 0 through +7 (normal), 8 through 15 (16-color), 16 through 255 (256-color), and true +color (called direct-color by B<xterm>). Unfortunately, interpretation of colors 0 through 7 often depends on whether the emulator supports eight colors or sixteen colors. Emulators @@ -698,6 +743,16 @@ C<red> is color 1 and C<bright_red> is color 9. The same applies for background colors: C<on_red> is the normal color and C<on_bright_red> is the bright color. Capitalize these strings for the constant interface. +There is unfortunately no way to know whether the current emulator +supports more than eight colors, which makes the choice of colors +difficult. The most conservative choice is to use only the regular +colors, which are at least displayed on all emulators. However, they will +appear dark in sixteen-color terminal emulators, including most common +emulators in UNIX X environments. If you know the display is one of those +emulators, you may wish to use the bright variants instead. Even better, +offer the user a way to configure the colors for a given application to +fit their terminal emulator. + For 256-color emulators, this module additionally provides C<ansi0> through C<ansi15>, which are the same as colors 0 through 15 in sixteen-color emulators but use the 256-color escape syntax, C<grey0> @@ -711,15 +766,12 @@ completely on non-256-color terminals or may be misinterpreted and produce random behavior. Additional attributes such as blink, italic, or bold may not work with the 256-color palette. -There is unfortunately no way to know whether the current emulator -supports more than eight colors, which makes the choice of colors -difficult. The most conservative choice is to use only the regular -colors, which are at least displayed on all emulators. However, they will -appear dark in sixteen-color terminal emulators, including most common -emulators in UNIX X environments. If you know the display is one of those -emulators, you may wish to use the bright variants instead. Even better, -offer the user a way to configure the colors for a given application to -fit their terminal emulator. +For true color emulators, this module supports attributes of the form C<< +rI<NNN>gI<NNN>bI<NNN> >> and C<< on_rI<NNN>gI<NNN>bI<NNN> >> for all values of +I<NNN> between 0 and 255. These represent foreground and background colors, +respectively, with the RGB values given by the I<NNN> numbers. These colors +may be ignored completely on non-true-color terminals or may be misinterpreted +and produce random behavior. =head2 Function Interface @@ -766,6 +818,12 @@ C<rgb000> or C<rgb515>. Similarly, the recognized background colors are: plus C<on_rgbI<RGB>> for I<R>, I<G>, and I<B> values from 0 to 5. +For true color terminals, the recognized foreground colors are C<< +rI<RRR>gI<GGG>bI<BBB> >> for I<RRR>, I<GGG>, and I<BBB> values between 0 and +255. Similarly, the recognized background colors are C<< +on_rI<RRR>gI<GGG>bI<BBB> >> for I<RRR>, I<GGG>, and I<BBB> values between 0 +and 255. + For any of the above listed attributes, case is not significant. Attributes, once set, last until they are unset (by printing the attribute @@ -808,6 +866,13 @@ default background color for the next line. Programs like pagers can also be confused by attributes that span lines. Normally you'll want to set $Term::ANSIColor::EACHLINE to C<"\n"> to use this feature. +Particularly consider setting $Term::ANSIColor::EACHLINE if you are +interleaving output to standard output and standard error and you aren't +flushing standard output (via autoflush() or setting C<$|>). If you don't, +the code to reset the color may unexpectedly sit in the standard output buffer +rather than going to the display, causing standard error output to appear in +the wrong color. + =item uncolor(ESCAPE) uncolor() performs the opposite translation as color(), turning escape @@ -827,17 +892,26 @@ together in scalar context. Its arguments are not modified. colorvalid() takes attribute strings the same as color() and returns true if all attributes are known and false otherwise. -=item coloralias(ALIAS[, ATTR]) +=item coloralias(ALIAS[, ATTR ...]) -If ATTR is specified, coloralias() sets up an alias of ALIAS for the -standard color ATTR. From that point forward, ALIAS can be passed into -color(), colored(), and colorvalid() and will have the same meaning as -ATTR. One possible use of this facility is to give more meaningful names -to the 256-color RGB colors. Only ASCII alphanumerics, C<.>, C<_>, and -C<-> are allowed in alias names. +If ATTR is specified, it is interpreted as a list of space-separated strings +naming attributes or existing aliases. In this case, coloralias() sets up an +alias of ALIAS for the set of attributes given by ATTR. From that point +forward, ALIAS can be passed into color(), colored(), and colorvalid() and +will have the same meaning as the sequence of attributes given in ATTR. One +possible use of this facility is to give more meaningful names to the +256-color RGB colors. Only ASCII alphanumerics, C<.>, C<_>, and C<-> are +allowed in alias names. -If ATTR is not specified, coloralias() returns the standard color name to -which ALIAS is aliased, if any, or undef if ALIAS does not exist. +If ATTR includes aliases, those aliases will be expanded at definition time +and their values will be used to define the new alias. This means that if you +define an alias A in terms of another alias B, and then later redefine alias +B, the value of alias A will not change. + +If ATTR is not specified, coloralias() returns the standard attribute or +attributes to which ALIAS is aliased, if any, or undef if ALIAS does not +exist. If it is aliased to multiple attributes, the return value will be a +single string and the attributes will be separated by spaces. This is the same facility used by the ANSI_COLORS_ALIASES environment variable (see L</ENVIRONMENT> below) but can be used at runtime, not just @@ -904,6 +978,8 @@ to explicitly import at least C<RESET>, as in: use Term::ANSIColor 4.00 qw(RESET :constants256); +True color and aliases are not supported by the constant interface. + When using the constants, if you don't want to have to remember to add the C<, RESET> at the end of each print line, you can set $Term::ANSIColor::AUTORESET to a true value. Then, the display mode will @@ -925,13 +1001,14 @@ over $Term::ANSIColor::AUTORESET, and the latter is ignored. The subroutine interface has the advantage over the constants interface in that only two subroutines are exported into your namespace, versus -thirty-eight in the constants interface. On the flip side, the constants -interface has the advantage of better compile time error checking, since -misspelled names of colors or attributes in calls to color() and colored() -won't be caught until runtime whereas misspelled names of constants will -be caught at compile time. So, pollute your namespace with almost two -dozen subroutines that you may not even use that often, or risk a silly -bug by mistyping an attribute. Your choice, TMTOWTDI after all. +thirty-eight in the constants interface, and aliases and true color attributes +are supported. On the flip side, the constants interface has the advantage of +better compile time error checking, since misspelled names of colors or +attributes in calls to color() and colored() won't be caught until runtime +whereas misspelled names of constants will be caught at compile time. So, +pollute your namespace with almost two dozen subroutines that you may not even +use that often, or risk a silly bug by mistyping an attribute. Your choice, +TMTOWTDI after all. =head2 The Color Stack @@ -971,6 +1048,31 @@ PUSHCOLOR pushes the attributes set by its argument, which is normally a string of color constants. It can't ask the terminal what the current attributes are. +=head2 Supporting CLICOLOR + +L<https://bixense.com/clicolors/> proposes a standard for enabling and +disabling color output from console commands using two environment variables, +CLICOLOR and CLICOLOR_FORCE. Term::ANSIColor cannot automatically support +this standard, since the correct action depends on where the output is going +and Term::ANSIColor may be used in a context where colors should always be +generated even if CLICOLOR is set in the environment. But you can use the +supported environment variable ANSI_COLORS_DISABLED to implement CLICOLOR in +your own programs with code like this: + + if (exists($ENV{CLICOLOR}) && $ENV{CLICOLOR} == 0) { + if (!$ENV{CLICOLOR_FORCE}) { + $ENV{ANSI_COLORS_DISABLED} = 1; + } + } + +If you are using the constant interface, be sure to include this code before +you use any color constants (such as at the very top of your script), since +this environment variable is only honored the first time a color constant is +seen. + +Be aware that this will export ANSI_COLORS_DISABLED to any child processes of +your program as well. + =head1 DIAGNOSTICS =over 4 @@ -1070,9 +1172,10 @@ The format is: ANSI_COLORS_ALIASES='newcolor1=oldcolor1,newcolor2=oldcolor2' -Whitespace is ignored. +Whitespace is ignored. The alias value can be a single attribute or a +space-separated list of attributes. -For example the L<Solarized|http://ethanschoonover.com/solarized> colors +For example the L<Solarized|https://ethanschoonover.com/solarized> colors can be mapped with: ANSI_COLORS_ALIASES='\ @@ -1095,11 +1198,20 @@ coloralias() for an equivalent facility that can be used at runtime. =item ANSI_COLORS_DISABLED If this environment variable is set to a true value, all of the functions -defined by this module (color(), colored(), and all of the constants not -previously used in the program) will not output any escape sequences and -instead will just return the empty string or pass through the original -text as appropriate. This is intended to support easy use of scripts -using this module on platforms that don't support ANSI escape sequences. +defined by this module (color(), colored(), and all of the constants) will not +output any escape sequences and instead will just return the empty string or +pass through the original text as appropriate. This is intended to support +easy use of scripts using this module on platforms that don't support ANSI +escape sequences. + +=item NO_COLOR + +If this environment variable is set to any value, it suppresses generation of +escape sequences the same as if ANSI_COLORS_DISABLED is set to a true value. +This implements the L<https://no-color.org/> informal standard. Programs that +want to enable color despite NO_COLOR being set will need to unset that +environment variable before any constant or function provided by this module +is used. =back @@ -1135,12 +1247,27 @@ $Term::ANSIColor::AUTOLOCAL was changed to take precedence over $Term::ANSIColor::AUTORESET, rather than the other way around, in Term::ANSIColor 4.00, included in Perl 5.17.8. -C<ansi16> through C<ansi255>, as aliases for the C<rgb> and C<grey> -colors, and the corresponding C<on_ansi> names and C<ANSI> and C<ON_ANSI> -constants, were added in Term::ANSIColor 4.06. +C<ansi16> through C<ansi255>, as aliases for the C<rgb> and C<grey> colors, +and the corresponding C<on_ansi> names and C<ANSI> and C<ON_ANSI> constants +were added in Term::ANSIColor 4.06, included in Perl 5.25.7. + +Support for true color (the C<rNNNgNNNbNNN> and C<on_rNNNgNNNbNNN> +attributes), defining aliases in terms of other aliases, and aliases mapping +to multiple attributes instead of only a single attribute was added in +Term::ANSIColor 5.00. + +Support for NO_COLOR was added in Term::ANSIColor 5.01. =head1 RESTRICTIONS +Both colored() and many uses of the color constants will add the reset escape +sequence after a newline. If a program mixes colored output to standard +output with output to standard error, this can result in the standard error +text having the wrong color because the reset escape sequence hasn't yet been +flushed to the display (since standard output to a terminal is line-buffered +by default). To avoid this, either set autoflush() on STDOUT or set +$Term::ANSIColor::EACHLINE to C<"\n">. + It would be nice if one could leave off the commas around the constants entirely and just say: @@ -1210,18 +1337,20 @@ table. It is not believed to be fully supported by any of the terminals listed, although it's displayed as green in the Linux console, but it is reportedly supported by urxvt. -Note that codes 6 (rapid blink) and 9 (strike-through) are specified in -ANSI X3.64 and ECMA-048 but are not commonly supported by most displays -and emulators and therefore aren't supported by this module at the present -time. ECMA-048 also specifies a large number of other attributes, -including a sequence of attributes for font changes, Fraktur characters, -double-underlining, framing, circling, and overlining. As none of these -attributes are widely supported or useful, they also aren't currently -supported by this module. +Note that codes 6 (rapid blink) and 9 (strike-through) are specified in ANSI +X3.64 and ECMA-048 but are not commonly supported by most displays and +emulators and therefore aren't supported by this module. ECMA-048 also +specifies a large number of other attributes, including a sequence of +attributes for font changes, Fraktur characters, double-underlining, framing, +circling, and overlining. As none of these attributes are widely supported or +useful, they also aren't currently supported by this module. Most modern X terminal emulators support 256 colors. Known to not support those colors are aterm, rxvt, Terminal.app, and TTY/VC. +For information on true color support in various terminal emulators, see +L<True Colour support|https://gist.github.com/XVilka/8346728>. + =head1 AUTHORS Original idea (using constants) by Zenin, reimplemented using subs by Russ @@ -1234,10 +1363,10 @@ voice solutions. =head1 COPYRIGHT AND LICENSE -Copyright 1996 Zenin +Copyright 1996-1998, 2000-2002, 2005-2006, 2008-2018, 2020 Russ Allbery +<rra@cpan.org> -Copyright 1996, 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2008, 2009, 2010, -2011, 2012, 2013, 2014, 2015, 2016 Russ Allbery <rra@cpan.org> +Copyright 1996 Zenin Copyright 2012 Kurt Starsinic <kstarsinic@gmail.com> @@ -1254,7 +1383,7 @@ The CPAN module L<Term::Chrome> provides a different interface using objects and operator overloading. ECMA-048 is available on-line (at least at the time of this writing) at -L<http://www.ecma-international.org/publications/standards/Ecma-048.htm>. +L<https://www.ecma-international.org/publications/standards/Ecma-048.htm>. ISO 6429 is available from ISO for a charge; the author of this module does not own a copy of it. Since the source material for ISO 6429 was @@ -1262,11 +1391,24 @@ ECMA-048 and the latter is available for free, there seems little reason to obtain the ISO standard. The 256-color control sequences are documented at -L<http://invisible-island.net/xterm/ctlseqs/ctlseqs.html> (search for +L<https://invisible-island.net/xterm/ctlseqs/ctlseqs.html> (search for 256-color). +Information about true color support in various terminal emulators and test +programs you can run to check the true color support in your terminal emulator +are available at L<https://gist.github.com/XVilka/8346728>. + +L<CLICOLORS|https://bixense.com/clicolors/> and +L<NO_COLOR|https://no-color.org/> are useful standards to be aware of, and +ideally follow, for any application using color. Term::ANSIColor complies +with the latter. + The current version of this module is always available from its web site at L<https://www.eyrie.org/~eagle/software/ansicolor/>. It is also part of the Perl core distribution as of 5.6.0. =cut + +# Local Variables: +# copyright-at-end-flag: t +# End: diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA.pm b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA.pm index bcd653240f4..1d5e4db23d4 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA.pm +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA.pm @@ -5,28 +5,46 @@ # by both C packages with Automake and by stand-alone Perl modules. See # Test::RRA::Automake for additional functions specifically for C Automake # distributions. +# +# SPDX-License-Identifier: MIT package Test::RRA; -use 5.006; +use 5.008; +use base qw(Exporter); use strict; use warnings; -use Exporter; +use Carp qw(croak); use File::Temp; -use Test::More; -# For Perl 5.006 compatibility. -## no critic (ClassHierarchies::ProhibitExplicitISA) +# Abort if Test::More was loaded before Test::RRA to be sure that we get the +# benefits of the Test::More probing below. +if ($INC{'Test/More.pm'}) { + croak('Test::More loaded before Test::RRA'); +} + +# Red Hat's base perl package doesn't include Test::More (one has to install +# the perl-core package in addition). Try to detect this and skip any Perl +# tests if Test::More is not present. This relies on Test::RRA being included +# before Test::More. +eval { + require Test::More; + Test::More->import(); +}; +if ($@) { + print "1..0 # SKIP Test::More required for test\n" + or croak('Cannot write to stdout'); + exit 0; +} # Declare variables that should be set in BEGIN for robustness. -our (@EXPORT_OK, @ISA, $VERSION); +our (@EXPORT_OK, $VERSION); # Set $VERSION and everything export-related in a BEGIN block for robustness # against circular module loading (not that we load any modules, but # consistency is good). BEGIN { - @ISA = qw(Exporter); @EXPORT_OK = qw( is_file_contents skip_unless_author skip_unless_automated use_prereq ); @@ -34,7 +52,7 @@ BEGIN { # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '6.02'; + $VERSION = '8.01'; } # Compare a string to the contents of a file, similar to the standard is() @@ -59,22 +77,27 @@ sub is_file_contents { return; } - # Otherwise, we show a diff, but only if we have IPC::System::Simple. - eval { require IPC::System::Simple }; + # Otherwise, we show a diff, but only if we have IPC::System::Simple and + # diff succeeds. Otherwise, we fall back on showing the full expected and + # seen output. + eval { + require IPC::System::Simple; + + my $tmp = File::Temp->new(); + my $tmpname = $tmp->filename; + print {$tmp} $got or BAIL_OUT("Cannot write to $tmpname: $!\n"); + my @command = ('diff', '-u', $expected, $tmpname); + my $diff = IPC::System::Simple::capturex([0 .. 1], @command); + diag($diff); + }; if ($@) { - ok(0, $message); - return; + diag('Expected:'); + diag($expected); + diag('Seen:'); + diag($data); } - # They're not equal. Write out what we got so that we can run diff. - my $tmp = File::Temp->new(); - my $tmpname = $tmp->filename; - print {$tmp} $got or BAIL_OUT("Cannot write to $tmpname: $!\n"); - my @command = ('diff', '-u', $expected, $tmpname); - my $diff = IPC::System::Simple::capturex([0 .. 1], @command); - diag($diff); - - # Remove the temporary file and report failure. + # Report failure. ok(0, $message); return; } @@ -89,7 +112,7 @@ sub is_file_contents { sub skip_unless_author { my ($description) = @_; if (!$ENV{AUTHOR_TESTING}) { - plan skip_all => "$description only run for author"; + plan(skip_all => "$description only run for author"); } return; } @@ -108,7 +131,7 @@ sub skip_unless_automated { for my $env (qw(AUTOMATED_TESTING RELEASE_TESTING AUTHOR_TESTING)) { return if $ENV{$env}; } - plan skip_all => "$description normally skipped"; + plan(skip_all => "$description normally skipped"); return; } @@ -150,14 +173,14 @@ sub use_prereq { use $module $version \@imports; 1; }; - $error = $@; + $error = $@; $sigdie = $SIG{__DIE__} || undef; } # If the use failed for any reason, skip the test. if (!$result || $error) { my $name = length($version) > 0 ? "$module $version" : $module; - plan skip_all => "$name required for test"; + plan(skip_all => "$name required for test"); } # If the module set $SIG{__DIE__}, we cleared that via local. Restore it. @@ -200,6 +223,14 @@ This module collects utility functions that are useful for Perl test scripts. It assumes Russ Allbery's Perl module layout and test conventions and will only be useful for other people if they use the same conventions. +This module B<must> be loaded before Test::More or it will abort during +import. It will skip the test (by printing a skip message to standard output +and exiting with status 0, equivalent to C<plan skip_all>) during import if +Test::More is not available. This allows tests written in Perl using this +module to be skipped if run on a system with Perl but not Test::More, such as +Red Hat systems with the C<perl> package but not the C<perl-core> package +installed. + =head1 FUNCTIONS None of these functions are imported by default. The ones used by a script @@ -244,7 +275,9 @@ Russ Allbery <eagle@eyrie.org> =head1 COPYRIGHT AND LICENSE -Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior +Copyright 2016, 2018-2019 Russ Allbery <eagle@eyrie.org> + +Copyright 2013-2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining a copy @@ -277,3 +310,7 @@ by the L<Lancaster Consensus|https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md>. =cut + +# Local Variables: +# copyright-at-end-flag: t +# End: diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA/Config.pm b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA/Config.pm index bdb31e60c0f..80a15739410 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA/Config.pm +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/lib/Test/RRA/Config.pm @@ -4,27 +4,25 @@ # configuration file to store some package-specific data. This module loads # that configuration and provides the namespace for the configuration # settings. +# +# SPDX-License-Identifier: MIT package Test::RRA::Config; -use 5.006; +use 5.008; +use base qw(Exporter); use strict; use warnings; -# For Perl 5.006 compatibility. -## no critic (ClassHierarchies::ProhibitExplicitISA) - -use Exporter; use Test::More; # Declare variables that should be set in BEGIN for robustness. -our (@EXPORT_OK, @ISA, $VERSION); +our (@EXPORT_OK, $VERSION); # Set $VERSION and everything export-related in a BEGIN block for robustness # against circular module loading (not that we load any modules, but # consistency is good). BEGIN { - @ISA = qw(Exporter); @EXPORT_OK = qw( $COVERAGE_LEVEL @COVERAGE_SKIP_TESTS @CRITIC_IGNORE $LIBRARY_PATH $MINIMUM_VERSION %MINIMUM_VERSION @MODULE_VERSION_IGNORE @@ -34,7 +32,7 @@ BEGIN { # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '6.02'; + $VERSION = '8.01'; } # If C_TAP_BUILD or C_TAP_SOURCE are set in the environment, look for @@ -185,9 +183,9 @@ Russ Allbery <eagle@eyrie.org> =head1 COPYRIGHT AND LICENSE -Copyright 2015, 2016 Russ Allbery <eagle@eyrie.org> +Copyright 2015-2016, 2019 Russ Allbery <eagle@eyrie.org> -Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior +Copyright 2013-2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining a copy @@ -220,3 +218,7 @@ The C TAP Harness test driver and libraries for TAP-based C testing are available from L<https://www.eyrie.org/~eagle/software/c-tap-harness/>. =cut + +# Local Variables: +# copyright-at-end-flag: t +# End: diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic256.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic256.t index ae06d1ada5c..6f639f80cf6 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic256.t +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic256.t @@ -3,20 +3,21 @@ # Tests for 256-color support. # # Copyright 2012 Kurt Starsinic <kstarsinic@gmail.com> -# Copyright 2012, 2013, 2016 Russ Allbery <rra@cpan.org> +# Copyright 2012-2013, 2016, 2020 Russ Allbery <rra@cpan.org> # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl +use 5.008; use strict; use warnings; -use Test::More tests => 94; +use Test::More tests => 100; # Load the module. BEGIN { delete $ENV{ANSI_COLORS_ALIASES}; delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; use_ok('Term::ANSIColor', qw(:constants256 color uncolor colorvalid)); } @@ -98,6 +99,16 @@ is(GREY0, q{}, '...and for GREY0'); is(GREY23, q{}, '...and for GREY23'); delete $ENV{ANSI_COLORS_DISABLED}; +# Do the same with NO_COLOR. +local $ENV{NO_COLOR} = 0; +is(ANSI0, q{}, 'NO_COLOR works for ANSI0'); +is(ANSI15, q{}, '...and for ANSI15'); +is(RGB000, q{}, '...and for RGB000'); +is(RGB555, q{}, '...and for RGB555'); +is(GREY0, q{}, '...and for GREY0'); +is(GREY23, q{}, '...and for GREY23'); +delete $ENV{NO_COLOR}; + # Do the same for AUTORESET. $Term::ANSIColor::AUTORESET = 1; is((ANSI0 't'), "\e[38;5;0mt\e[0m", 'AUTORESET works for ANSI0'); diff --git a/gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml b/gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml deleted file mode 100644 index 1e46f325428..00000000000 --- a/gnu/usr.bin/perl/cpan/Term-ReadKey/META.yml +++ /dev/null @@ -1,29 +0,0 @@ ---- -abstract: 'Change terminal modes, and perform non-blocking reads.' -author: - - 'Kenneth Albanowski' - - 'Jonathan Stowe' -build_requires: - ExtUtils::MakeMaker: '6.58' -configure_requires: - ExtUtils::MakeMaker: '6.58' -dynamic_config: 1 -generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' -license: perl -meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.4.html - version: '1.4' -name: TermReadKey -no_index: - file: - - Configure.pm - package: - - Configure -provides: - Term::ReadKey: - file: ReadKey.pm.PL - version: '2.38' -resources: - repository: https://github.com/jonathanstowe/TermReadKey.git -version: '2.38' -x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder.pm index b61bd5024da..1a49b7a8e7c 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder.pm @@ -4,7 +4,7 @@ use 5.006; use strict; use warnings; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; BEGIN { if( $] < 5.008 ) { @@ -63,7 +63,8 @@ sub _add_ts_hooks { $todo = ${"$cpkg\::TODO"} if $cpkg; $todo = ${"$epkg\::TODO"} if $epkg && !$todo; - return $e unless defined $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'; @@ -390,7 +391,7 @@ sub name { sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms) my ($self, %params) = @_; - Test2::API::test2_set_is_end(0); + 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. @@ -695,7 +696,7 @@ sub _ok_debug { my $self = shift; my ($trace, $orig_name) = @_; - my $is_todo = defined($self->todo); + my $is_todo = $self->in_todo; my $msg = $is_todo ? "Failed (TODO)" : "Failed"; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Module.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Module.pm index 1ca914dee65..6e550eb6f7f 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Module.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Module.pm @@ -7,7 +7,7 @@ use Test::Builder; require Exporter; our @ISA = qw(Exporter); -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; =head1 NAME @@ -172,4 +172,11 @@ 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; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester.pm index 469336d8755..da98e3d9a07 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester; use strict; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use Test::Builder; use Symbol; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm index 0bf39c60d71..116e6057d85 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Tester/Color.pm @@ -1,7 +1,7 @@ package Test::Builder::Tester::Color; use strict; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; require Test::Builder::Tester; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/More.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/More.pm index 473c86eba63..b2f82286b44 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/More.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/More.pm @@ -17,7 +17,7 @@ sub _carp { return warn @_, " at $file line $line\n"; } -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); @@ -1402,7 +1402,7 @@ You then know the thing you had todo is done and can remove the TODO flag. The nice part about todo tests, as opposed to simply commenting out a -block of tests, is it's like having a programmatic todo list. You know +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. @@ -1848,7 +1848,7 @@ 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 seem by +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 diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Simple.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Simple.pm index 9218173bc50..6ff8183b804 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Simple.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.006; use strict; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use Test::Builder::Module; our @ISA = qw(Test::Builder::Module); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester.pm index 19cbf665712..1cc7bd179e7 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester.pm @@ -18,7 +18,7 @@ require Exporter; use vars qw( @ISA @EXPORT ); -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; @EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); @ISA = qw( Exporter ); @@ -393,7 +393,7 @@ The easiest way to test is to do something like } ); -this will execute the is_mystyle_eq test, capturing it's results and +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 diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Capture.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Capture.pm index e28dbf83432..c5c454215f5 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Capture.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Capture.pm @@ -2,7 +2,7 @@ use strict; package Test::Tester::Capture; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use Test::Builder; @@ -13,14 +13,8 @@ use vars qw( @ISA ); # Make Test::Tester::Capture thread-safe for ithreads. BEGIN { use Config; - if( $] >= 5.008 && $Config{useithreads} ) { - require threads::shared; - threads::shared->import; - } - else { - *share = sub { 0 }; - *lock = sub { 0 }; - } + *share = sub { 0 }; + *lock = sub { 0 }; } my $Curr_Test = 0; share($Curr_Test); @@ -30,7 +24,7 @@ my $Prem_Diag = {diag => ""}; share($Curr_Test); sub new { # Test::Tester::Capgture::new used to just return __PACKAGE__ - # because Test::Builder::new enforced it's singleton nature by + # 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 @@ -229,7 +223,7 @@ 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 it's own set of test +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. diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm index 7cf3c0f0b52..a86ef0616c8 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/CaptureRunner.pm @@ -3,7 +3,7 @@ use strict; package Test::Tester::CaptureRunner; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use Test::Tester::Capture; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Delegate.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Delegate.pm index ebfd4e21681..2036f2ebc28 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Delegate.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Tester/Delegate.pm @@ -3,7 +3,7 @@ use warnings; package Test::Tester::Delegate; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use Scalar::Util(); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/use/ok.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/use/ok.pm index a81bbfb64a3..4113ef59c86 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/use/ok.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/use/ok.pm @@ -1,7 +1,7 @@ package Test::use::ok; use 5.005; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; __END__ diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/ok.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/ok.pm index 66dcad8635f..f3b394d9f69 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/ok.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/ok.pm @@ -1,5 +1,5 @@ package ok; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; use strict; use Test::More (); diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm b/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm index 4fbb1bc6315..f1a5780a0b9 100644 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/lib/Text/Balanced.pm @@ -1508,7 +1508,7 @@ C<extract_tagged> returns the complete text up to the point of failure. If the string is "PARA", C<extract_tagged> returns only the first paragraph after the tag (up to the first line that is either empty or contains only whitespace characters). -If the string is "", the default behaviour (i.e. failure) is reinstated. +If the string is "", the the default behaviour (i.e. failure) is reinstated. For example, suppose the start tag "/para" introduces a paragraph, which then continues until the next "/endpara" tag or until another "/para" tag is diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/Piece.pm b/gnu/usr.bin/perl/cpan/Time-Piece/Piece.pm index d5624636c6f..f5d87cd0316 100644 --- a/gnu/usr.bin/perl/cpan/Time-Piece/Piece.pm +++ b/gnu/usr.bin/perl/cpan/Time-Piece/Piece.pm @@ -19,7 +19,7 @@ our %EXPORT_TAGS = ( ':override' => 'internal', ); -our $VERSION = '1.33'; +our $VERSION = '1.3401'; XSLoader::load( 'Time::Piece', $VERSION ); @@ -126,6 +126,7 @@ sub _mktime { if ($class->_is_time_struct($time)) { my @new_time = @$time; my @tm_parts = (@new_time[c_sec .. c_mon], $new_time[c_year]+1900); + $new_time[c_epoch] = $islocal ? timelocal(@tm_parts) : timegm(@tm_parts); return wantarray ? @new_time : bless [@new_time[0..9], $islocal], $class; @@ -805,8 +806,14 @@ sub use_locale { #get locale month/day names from posix strftime (from Piece.xs) my $locales = _get_localization(); - $locales->{PM} ||= ''; - $locales->{AM} ||= ''; + #If AM and PM are the same, set both to '' + if ( !$locales->{PM} + || !$locales->{AM} + || ( $locales->{PM} eq $locales->{AM} ) ) + { + $locales->{PM} = ''; + $locales->{AM} = ''; + } $locales->{pm} = lc $locales->{PM}; $locales->{am} = lc $locales->{AM}; @@ -896,7 +903,7 @@ in perlfunc will still return what you expect. The module actually implements most of an interface described by Larry Wall on the perl5-porters mailing list here: -L<http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html> +L<https://www.nntp.perl.org/group/perl.perl5.porters/2000/01/msg5283.html> =head1 USAGE @@ -1152,6 +1159,14 @@ moves afoot to fix that in perl. Alternatively use 64 bit perl. Or if none of those are options, use the L<DateTime> module which has support for years well into the future and past. +Also, the internal representation of Time::Piece->strftime deviates from the +standard POSIX implementation in that is uses the epoch (instead of separate +year, month, day parts). This change was added in version 1.30. If you must +have a more traditional strftime (which will normally never calculate day +light saving times correctly), you can pass the date parts from Time::Piece +into the strftime function provided by the POSIX module +(see strftime in L<POSIX> ). + =head1 AUTHOR Matt Sergeant, matt@sergeant.org diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/Seconds.pm b/gnu/usr.bin/perl/cpan/Time-Piece/Seconds.pm index 71a4bd27f29..6aa864d97ec 100644 --- a/gnu/usr.bin/perl/cpan/Time-Piece/Seconds.pm +++ b/gnu/usr.bin/perl/cpan/Time-Piece/Seconds.pm @@ -1,7 +1,7 @@ package Time::Seconds; use strict; -our $VERSION = '1.33'; +our $VERSION = '1.3401'; use Exporter 5.57 'import'; diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/t/02core_dst.t b/gnu/usr.bin/perl/cpan/Time-Piece/t/02core_dst.t index 3f54fff233c..f4433511195 100644 --- a/gnu/usr.bin/perl/cpan/Time-Piece/t/02core_dst.t +++ b/gnu/usr.bin/perl/cpan/Time-Piece/t/02core_dst.t @@ -1,4 +1,9 @@ -use Test::More tests => 56; +use Test::More; + +# Skip if doing a regular install +# Avoids mystery DST bugs [rt 128240], [GH40] +plan skip_all => "DST tests not required for installation" + unless ( $ENV{AUTOMATED_TESTING} ); my $is_win32 = ($^O =~ /Win32/); my $is_qnx = ($^O eq 'qnx'); @@ -121,7 +126,7 @@ cmp_ok($t->month_last_day, '==', 31); # test more SKIP: { skip "Extra tests for Linux, BSD only.", 8 unless $is_linux or $is_mac or $is_bsd; - local $ENV{TZ} = "EST5EDT4"; + local $ENV{TZ} = "EST5EDT4,M3.2.0/2,M11.1.0/2"; Time::Piece::_tzset(); my $lt = localtime(1373371631); #2013-07-09T12:07:11 cmp_ok(scalar($lt->tzoffset), 'eq', '-14400'); @@ -136,4 +141,4 @@ SKIP: { is ($lt->strftime("%s"), 1357733231, 'Epoch output is the same with EST'); } - +done_testing(56); diff --git a/gnu/usr.bin/perl/cpan/Win32/Win32.pm b/gnu/usr.bin/perl/cpan/Win32/Win32.pm index 7b9ab455bea..5a197e9e9e3 100644 --- a/gnu/usr.bin/perl/cpan/Win32/Win32.pm +++ b/gnu/usr.bin/perl/cpan/Win32/Win32.pm @@ -8,7 +8,7 @@ package Win32; require DynaLoader; @ISA = qw|Exporter DynaLoader|; - $VERSION = '0.52'; + $VERSION = '0.53'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; diff --git a/gnu/usr.bin/perl/cpan/Win32/Win32.xs b/gnu/usr.bin/perl/cpan/Win32/Win32.xs index de3764edab5..03519cbc3ad 100644 --- a/gnu/usr.bin/perl/cpan/Win32/Win32.xs +++ b/gnu/usr.bin/perl/cpan/Win32/Win32.xs @@ -1,7 +1,9 @@ #define WIN32_LEAN_AND_MEAN +#include <wchar.h> #include <wctype.h> #include <windows.h> #include <shlobj.h> +#include <wchar.h> #define PERL_NO_GET_CONTEXT #include "EXTERN.h" @@ -114,7 +116,7 @@ typedef void (WINAPI *PFNGetNativeSystemInfo)(LPSYSTEM_INFO lpSystemInfo); * WORD type has been replaced by unsigned short because * WORD is already used by Perl itself. */ -struct { +struct g_osver_t { DWORD dwOSVersionInfoSize; DWORD dwMajorVersion; DWORD dwMinorVersion; @@ -126,7 +128,7 @@ struct { unsigned short wSuiteMask; BYTE wProductType; BYTE wReserved; -} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0}; +} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0}; BOOL g_osver_ex = TRUE; #define ONE_K_BUFSIZE 1024 @@ -201,7 +203,7 @@ wstr_to_sv(pTHX_ WCHAR *wstr) * characters for the characters not in the ANSI codepage. */ SV* -get_unicode_env(pTHX_ WCHAR *name) +get_unicode_env(pTHX_ const WCHAR *name) { SV *sv = NULL; void *env; @@ -377,6 +379,7 @@ get_childenv(void) void free_childenv(void *d) { + PERL_UNUSED_ARG(d); } # define PerlDir_mapA(dir) (dir) @@ -388,7 +391,7 @@ XS(w32_ExpandEnvironmentStrings) dXSARGS; if (items != 1) - croak("usage: Win32::ExpandEnvironmentStrings($String);\n"); + croak("usage: Win32::ExpandEnvironmentStrings($String)"); if (IsWin2000()) { WCHAR value[31*1024]; @@ -536,7 +539,7 @@ XS(w32_LookupAccountName) if (items != 5) croak("usage: Win32::LookupAccountName($system, $account, $domain, " - "$sid, $sidtype);\n"); + "$sid, $sidtype)"); SIDLen = sizeof(SID); DomLen = sizeof(Domain); @@ -570,7 +573,7 @@ XS(w32_LookupAccountSID) BOOL bResult; if (items != 5) - croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n"); + croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype)"); sid = SvPV_nolen(ST(1)); if (IsValidSid(sid)) { @@ -601,7 +604,7 @@ XS(w32_InitiateSystemShutdown) if (items != 5) croak("usage: Win32::InitiateSystemShutdown($machineName, $message, " - "$timeOut, $forceClose, $reboot);\n"); + "$timeOut, $forceClose, $reboot)"); machineName = SvPV_nolen(ST(0)); @@ -642,7 +645,7 @@ XS(w32_AbortSystemShutdown) char *machineName; if (items != 1) - croak("usage: Win32::AbortSystemShutdown($machineName);\n"); + croak("usage: Win32::AbortSystemShutdown($machineName)"); machineName = SvPV_nolen(ST(0)); @@ -680,7 +683,7 @@ XS(w32_MsgBox) I32 result; if (items < 1 || items > 3) - croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n"); + croak("usage: Win32::MsgBox($message [, $flags [, $title]])"); if (items > 1) flags = (DWORD)SvIV(ST(1)); @@ -696,7 +699,7 @@ XS(w32_MsgBox) Safefree(title); } else { - char *title = "Perl"; + const char *title = "Perl"; char *msg = SvPV_nolen(ST(0)); if (items > 2) title = SvPV_nolen(ST(2)); @@ -787,6 +790,8 @@ XS(w32_UnregisterServer) XS(w32_GetArchName) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetArchName()"); XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE")); } @@ -796,6 +801,8 @@ XS(w32_GetChipName) SYSTEM_INFO sysinfo; HMODULE module; PFNGetNativeSystemInfo pfnGetNativeSystemInfo; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetChipName()"); Zero(&sysinfo,1,SYSTEM_INFO); module = GetModuleHandle("kernel32.dll"); @@ -814,8 +821,11 @@ XS(w32_GuidGen) dXSARGS; GUID guid; char szGUID[50] = {'\0'}; - HRESULT hr = CoCreateGuid(&guid); + HRESULT hr; + if (items) + Perl_croak(aTHX_ "usage: Win32::GuidGen()"); + hr = CoCreateGuid(&guid); if (SUCCEEDED(hr)) { LPOLESTR pStr = NULL; #ifdef __cplusplus @@ -896,7 +906,7 @@ XS(w32_GetFolderPath) SV *sv; HKEY hkey; HKEY root = HKEY_CURRENT_USER; - WCHAR *name = NULL; + const WCHAR *name = NULL; switch (folder) { case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break; @@ -997,7 +1007,7 @@ XS(w32_GetFileVersion) char *data; if (items != 1) - croak("usage: Win32::GetFileVersion($filename)\n"); + croak("usage: Win32::GetFileVersion($filename)"); filename = SvPV_nolen(ST(0)); size = GetFileVersionInfoSize(filename, &handle); @@ -1048,7 +1058,9 @@ XS(w32_SetChildShowWindow) * inside the thread_intern structure, the MSWin32 implementation * lives in win32/win32.c in the core Perl distribution. */ - dXSARGS; + dSP; + I32 ax = POPMARK; + EXTEND(SP,1); XSRETURN_UNDEF; } #endif @@ -1056,8 +1068,12 @@ XS(w32_SetChildShowWindow) XS(w32_GetCwd) { dXSARGS; + char* ptr; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetCwd()"); + /* Make the host for current directory */ - char* ptr = PerlEnv_get_childdir(); + ptr = PerlEnv_get_childdir(); /* * If ptr != Nullch * then it worked, set PV valid, @@ -1108,6 +1124,8 @@ XS(w32_GetNextAvailDrive) char ix = 'C'; char root[] = "_:\\"; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetNextAvailDrive()"); EXTEND(SP,1); while (ix <= 'Z') { root[0] = ix++; @@ -1122,6 +1140,8 @@ XS(w32_GetNextAvailDrive) XS(w32_GetLastError) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetLastError()"); EXTEND(SP,1); XSRETURN_IV(GetLastError()); } @@ -1138,6 +1158,8 @@ XS(w32_SetLastError) XS(w32_LoginName) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::LoginName()"); EXTEND(SP,1); if (IsWin2000()) { WCHAR name[128]; @@ -1164,6 +1186,8 @@ XS(w32_NodeName) dXSARGS; char name[MAX_COMPUTERNAME_LENGTH+1]; DWORD size = sizeof(name); + if (items) + Perl_croak(aTHX_ "usage: Win32::NodeName()"); EXTEND(SP,1); if (GetComputerName(name,&size)) { /* size does NOT include NULL :-( */ @@ -1178,9 +1202,11 @@ XS(w32_DomainName) { dXSARGS; HMODULE module = LoadLibrary("netapi32.dll"); - PFNNetApiBufferFree pfnNetApiBufferFree; - PFNNetWkstaGetInfo pfnNetWkstaGetInfo; + PFNNetApiBufferFree pfnNetApiBufferFree = NULL; + PFNNetWkstaGetInfo pfnNetWkstaGetInfo = NULL; + if (items) + Perl_croak(aTHX_ "usage: Win32::DomainName()"); if (module) { GETPROC(NetApiBufferFree); GETPROC(NetWkstaGetInfo); @@ -1242,8 +1268,10 @@ XS(w32_FsType) dXSARGS; char fsname[256]; DWORD flags, filecomplen; + if (items) + Perl_croak(aTHX_ "usage: Win32::FsType()"); if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, - &flags, fsname, sizeof(fsname))) { + &flags, fsname, sizeof(fsname))) { if (GIMME_V == G_ARRAY) { XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname)))); XPUSHs(sv_2mortal(newSViv(flags))); @@ -1260,6 +1288,8 @@ XS(w32_FsType) XS(w32_GetOSVersion) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetOSVersion()"); if (GIMME_V == G_SCALAR) { XSRETURN_IV(g_osver.dwPlatformId); @@ -1282,6 +1312,8 @@ XS(w32_GetOSVersion) XS(w32_IsWinNT) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::IsWinNT()"); EXTEND(SP,1); XSRETURN_IV(IsWinNT()); } @@ -1289,6 +1321,8 @@ XS(w32_IsWinNT) XS(w32_IsWin95) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::IsWin95()"); EXTEND(SP,1); XSRETURN_IV(IsWin95()); } @@ -1364,6 +1398,8 @@ XS(w32_GetTickCount) { dXSARGS; DWORD msec = GetTickCount(); + if (items) + Perl_croak(aTHX_ "usage: Win32::GetTickCount()"); EXTEND(SP,1); if ((IV)msec > 0) XSRETURN_IV(msec); @@ -1525,7 +1561,7 @@ XS(w32_GetLongPathName) WCHAR wide_path[MAX_PATH+1]; WCHAR *long_path; - if (wcslen(wstr) < countof(wide_path)) { + if (wcslen(wstr) < (size_t)countof(wide_path)) { wcscpy(wide_path, wstr); long_path = my_longpathW(wide_path); if (long_path) { @@ -1619,6 +1655,8 @@ XS(w32_OutputDebugString) XS(w32_GetCurrentProcessId) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetCurrentProcessId()"); EXTEND(SP,1); XSRETURN_IV(GetCurrentProcessId()); } @@ -1626,6 +1664,8 @@ XS(w32_GetCurrentProcessId) XS(w32_GetCurrentThreadId) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetCurrentThreadId()"); EXTEND(SP,1); XSRETURN_IV(GetCurrentThreadId()); } @@ -1713,6 +1753,8 @@ XS(w32_GetProductInfo) XS(w32_GetACP) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetACP()"); EXTEND(SP,1); XSRETURN_IV(GetACP()); } @@ -1720,6 +1762,8 @@ XS(w32_GetACP) XS(w32_GetConsoleCP) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetConsoleCP()"); EXTEND(SP,1); XSRETURN_IV(GetConsoleCP()); } @@ -1727,6 +1771,8 @@ XS(w32_GetConsoleCP) XS(w32_GetConsoleOutputCP) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetConsoleOutputCP()"); EXTEND(SP,1); XSRETURN_IV(GetConsoleOutputCP()); } @@ -1734,6 +1780,8 @@ XS(w32_GetConsoleOutputCP) XS(w32_GetOEMCP) { dXSARGS; + if (items) + Perl_croak(aTHX_ "usage: Win32::GetOEMCP()"); EXTEND(SP,1); XSRETURN_IV(GetOEMCP()); } @@ -1764,7 +1812,7 @@ PROTOTYPES: DISABLE BOOT: { - char *file = __FILE__; + const char *file = __FILE__; if (g_osver.dwOSVersionInfoSize == 0) { g_osver.dwOSVersionInfoSize = sizeof(g_osver); diff --git a/gnu/usr.bin/perl/cpan/Win32API-File/File.pm b/gnu/usr.bin/perl/cpan/Win32API-File/File.pm index 10c5d2ff662..804a7f6ea00 100644 --- a/gnu/usr.bin/perl/cpan/Win32API-File/File.pm +++ b/gnu/usr.bin/perl/cpan/Win32API-File/File.pm @@ -10,7 +10,7 @@ use Fcntl qw( O_RDONLY O_RDWR O_WRONLY O_APPEND O_BINARY O_TEXT ); use vars qw( $VERSION @ISA ); use vars qw( @EXPORT @EXPORT_OK @EXPORT_FAIL %EXPORT_TAGS ); -$VERSION= '0.1203'; +$VERSION= '0.1203_01'; use base qw( Exporter DynaLoader Tie::Handle IO::File ); diff --git a/gnu/usr.bin/perl/cpan/Win32API-File/File.xs b/gnu/usr.bin/perl/cpan/Win32API-File/File.xs index 83971d00002..91978ff3128 100644 --- a/gnu/usr.bin/perl/cpan/Win32API-File/File.xs +++ b/gnu/usr.bin/perl/cpan/Win32API-File/File.xs @@ -14,6 +14,7 @@ #endif #define WIN32_LEAN_AND_MEAN /* Tell windows.h to skip much */ +#include <wchar.h> #include <windows.h> #include <winioctl.h> diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/Fatal.pm b/gnu/usr.bin/perl/cpan/autodie/lib/Fatal.pm index 16e17434742..09abfb8536d 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/Fatal.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/Fatal.pm @@ -8,7 +8,7 @@ use strict; use warnings; use Tie::RefHash; # To cache subroutine refs use Config; -use Scalar::Util qw(set_prototype); +use Scalar::Util qw(set_prototype looks_like_number); use autodie::Util qw( fill_protos @@ -55,7 +55,7 @@ use constant ERROR_58_HINTS => q{Non-subroutine %s hints for %s are not supporte use constant MIN_IPC_SYS_SIMPLE_VER => 0.12; -our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version +our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg::Version our $Debug ||= 0; @@ -165,6 +165,9 @@ my %TAGS = ( ':2.27' => [qw(:default)], ':2.28' => [qw(:default)], ':2.29' => [qw(:default)], + ':2.30' => [qw(:default)], + ':2.31' => [qw(:default)], + ':2.32' => [qw(:default)], ); @@ -580,7 +583,12 @@ sub unimport { # Record the current sub to be reinstalled at end of scope # and then restore the original (can be undef for "CORE::" # subs) - $reinstall_subs{$symbol} = \&$sub; + + { + no strict 'refs'; ## no critic # to avoid: Can't use string (...) as a symbol ref ... + $reinstall_subs{$symbol} = \&$sub + if exists ${"${pkg}::"}{$symbol}; + } $uninstall_subs{$symbol} = $Original_user_sub{$sub}; } @@ -1023,6 +1031,26 @@ sub _one_invocation { }; } + if ($call eq 'CORE::kill') { + + return qq[ + + my \$num_things = \@_ - $Returns_num_things_changed{$call}; + my \$context = ! defined wantarray() ? 'void' : 'scalar'; + my \$signal = \$_[0]; + my \$retval = $call(@argv); + my \$sigzero = looks_like_number( \$signal ) && \$signal == 0; + + if ( ( \$sigzero && \$context eq 'void' ) + or ( ! \$sigzero && \$retval != \$num_things ) ) { + + $die; + } + + return \$retval; + ]; + } + if (exists $Returns_num_things_changed{$call}) { # Some things return the number of things changed (like diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie.pm index 5934c138ed0..8f62d670d80 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie.pm @@ -9,7 +9,7 @@ our $VERSION; # ABSTRACT: Replace functions with ones that succeed or die with lexical scope BEGIN { - our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg::Version + our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg::Version } use constant ERROR_WRONG_FATAL => q{ @@ -116,32 +116,6 @@ Exceptions produced by the C<autodie> pragma are members of the L<autodie::exception> class. The preferred way to work with these exceptions under Perl 5.10 is as follows: - use feature qw(switch); - - eval { - use autodie; - - open(my $fh, '<', $some_file); - - my @records = <$fh>; - - # Do things with @records... - - close($fh); - - }; - - given ($@) { - when (undef) { say "No error"; } - when ('open') { say "Error from open"; } - when (':io') { say "Non-open, IO error."; } - when (':all') { say "All other autodie errors." } - default { say "Not an autodie error at all." } - } - -Under Perl 5.8, the C<given/when> structure is not available, so the -following structure may be used: - eval { use autodie; @@ -268,7 +242,7 @@ C<system> and C<exec> with: =head2 print -The autodie pragma B<<does not check calls to C<print>>>. +The autodie pragma B<does not check calls to C<print>Z<>>. =head2 flock @@ -370,6 +344,14 @@ any hints available. See also L<Fatal/DIAGNOSTICS>. +=head1 Tips and Tricks + +=head2 Importing autodie into another namespace than "caller" + +It is possible to import autodie into a different namespace by using +L<Import::Into>. However, you have to pass a "caller depth" (rather +than a package name) for this to work correctly. + =head1 BUGS "Used only once" warnings can be generated when C<autodie> or C<Fatal> diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception.pm index 8743719cb84..d4c14f9f7d9 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp qw(croak); -our $VERSION = '2.29002'; +our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying functions. our $DEBUG = 0; diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception/system.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception/system.pm index e6305fd42ea..b0e270c056a 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception/system.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/exception/system.pm @@ -5,7 +5,7 @@ use warnings; use parent 'autodie::exception'; use Carp qw(croak); -our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Exceptions from autodying system(). diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/hints.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/hints.pm index be9fbceb475..c3f83ed0ece 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/hints.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/hints.pm @@ -5,7 +5,7 @@ use warnings; use constant PERL58 => ( $] < 5.009 ); -our $VERSION = '2.29001'; +our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Provide hints about user subroutines to autodie @@ -121,7 +121,7 @@ other things. You can specify different hints for how failure should be identified in scalar and list contexts. These examples apply for use in the C<AUTODIE_HINTS> subroutine and when -calling C<autodie::hints->set_hints_for()>. +calling C<< autodie::hints->set_hints_for() >>. The most common context-specific hints are: diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/skip.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/skip.pm index 9a048fe62f2..ad9706caa0f 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/skip.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/skip.pm @@ -2,7 +2,7 @@ package autodie::skip; use strict; use warnings; -our $VERSION = '2.29'; # VERSION +our $VERSION = '2.32'; # VERSION # This package exists purely so people can inherit from it, # which isn't at all how roles are supposed to work, but it's diff --git a/gnu/usr.bin/perl/cpan/autodie/t/version.t b/gnu/usr.bin/perl/cpan/autodie/t/version.t index 7accf05dc0d..5fad742110b 100755 --- a/gnu/usr.bin/perl/cpan/autodie/t/version.t +++ b/gnu/usr.bin/perl/cpan/autodie/t/version.t @@ -5,6 +5,11 @@ use Test::More; if (not $ENV{RELEASE_TESTING}) { plan( skip_all => 'Release test. Set $ENV{RELEASE_TESTING} to true to run.'); } + +if( $ENV{AUTOMATED_TESTING} ) { + plan( skip_all => 'This test requires dzil and that is not supported on github actions'); +} + plan tests => 8; # For the moment, we'd like all our versions to be the same. @@ -18,6 +23,8 @@ require autodie::hints; require autodie::exception; require autodie::exception::system; +diag(explain(\%ENV)); + ok(defined($autodie::VERSION), 'autodie has a version'); ok(defined($autodie::exception::VERSION), 'autodie::exception has a version'); ok(defined($autodie::hints::VERSION), 'autodie::hints has a version'); diff --git a/gnu/usr.bin/perl/cpan/parent/lib/parent.pm b/gnu/usr.bin/perl/cpan/parent/lib/parent.pm index 9bf99699c14..f2405efe7ee 100644 --- a/gnu/usr.bin/perl/cpan/parent/lib/parent.pm +++ b/gnu/usr.bin/perl/cpan/parent/lib/parent.pm @@ -1,7 +1,7 @@ package parent; use strict; -our $VERSION = '0.237'; +our $VERSION = '0.238'; sub import { my $class = shift; @@ -99,7 +99,15 @@ that had accumulated in it. =head1 SEE ALSO -L<base> +=over 4 + +=item L<base> + +=item L<parent::versioned> + +A fork of L<parent> that provides version checking in parent class modules. + +=back =head1 AUTHORS AND CONTRIBUTORS diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pm b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pm index b3645bc3cbb..c8016cf5233 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pm +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pm @@ -2,6 +2,6 @@ use strict; use warnings; package perlfaq; -our $VERSION = '5.20190126'; +our $VERSION = '5.20200523'; 1; diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pod index 3dd9f6c3c93..3b7345aa64a 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq.pod @@ -4,7 +4,7 @@ perlfaq - Frequently asked questions about Perl =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -89,11 +89,11 @@ Which version of Perl should I use? =item * -What are Perl 4, Perl 5, or Perl 6? +What are Perl 4, Perl 5, or Raku (Perl 6)? =item * -What is Perl 6? +What is Raku (Perl 6)? =item * diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq1.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq1.pod index 4c023f8eb41..0ec9f16161c 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq1.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq1.pod @@ -4,7 +4,7 @@ perlfaq1 - General Questions About Perl =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -123,11 +123,11 @@ current stable release of Perl. =back -=head2 What are Perl 4, Perl 5, or Perl 6? +=head2 What are Perl 4, Perl 5, or Raku (Perl 6)? -In short, Perl 4 is the parent to both Perl 5 and Perl 6. Perl 5 is the older -sibling, and though they are different languages, someone who knows one will -spot many similarities in the other. +In short, Perl 4 is the parent to both Perl 5 and Raku (formerly known as +Perl 6). Perl 5 is the older sibling, and though they are different languages, +someone who knows one will spot many similarities in the other. The number after Perl (i.e. the 5 after Perl 5) is the major release of the perl interpreter as well as the version of the language. Each @@ -138,31 +138,30 @@ The current major release of Perl is Perl 5, first released in 1994. It can run scripts from the previous major release, Perl 4 (March 1991), but has significant differences. -Perl 6 is a reinvention of Perl, it is a language in the same lineage but -not compatible. The two are complementary, not mutually exclusive. Perl 6 is -not meant to replace Perl 5, and vice versa. See L</"What is Perl 6?"> below -to find out more. +Raku is a reinvention of Perl, a language in the same lineage but +not compatible. The two are complementary, not mutually exclusive. Raku is +not meant to replace Perl, and vice versa. See L</"What is Raku (Perl 6)?"> +below to find out more. See L<perlhist> for a history of Perl revisions. -=head2 What is Perl 6? +=head2 What is Raku (Perl 6)? -Perl 6 was I<originally> described as the community's rewrite of Perl 5, -however as the language evolved, it became clear that it is a separate -language, but in the same language family as Perl 5. +Raku (formerly known as Perl 6) was I<originally> described as the community's +rewrite of Perl, however as the language evolved, it became clear that it is +a separate language, but in the same language family as Perl. -Perl 6 is not intended primarily as a replacement for Perl 5, but as its -own thing - and libraries exist to allow you to call Perl 5 code from Perl -6 programs and vice versa. +Raku is not intended primarily as a replacement for Perl, but as its +own thing - and libraries exist to allow you to call Perl code from Raku +programs and vice versa. -Contrary to popular belief, Perl 6 and Perl 5 peacefully coexist with one -another. Perl 6 has proven to be a fascinating source of ideas for those -using Perl 5 (the L<Moose> object system is a well-known example). There is +Contrary to popular belief, Raku and Perl peacefully coexist with one +another. Raku has proven to be a fascinating source of ideas for those +using Perl (the L<Moose> object system is a well-known example). There is overlap in the communities, and this overlap fosters the tradition of sharing and borrowing that have been instrumental to Perl's success. -If you want to learn more about Perl 6 read the Perl 6 developers -page at L<http://www.perl6.org/> and get involved. +For more about Raku see L<https://www.raku.org/>. "We're really serious about reinventing everything that needs reinventing." --Larry Wall diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq2.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq2.pod index c039bdfd133..447ad087eb6 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq2.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq2.pod @@ -4,7 +4,7 @@ perlfaq2 - Obtaining and Learning about Perl =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -213,10 +213,9 @@ First, ensure that you've found an actual bug. Second, ensure you've found an actual bug. If you've found a bug with the perl interpreter or one of the modules -in the standard library (those that come with Perl), you can use the -L<perlbug> utility that comes with Perl (>= 5.004). It collects -information about your installation to include with your message, then -sends the message to the right place. +in the standard library (those that come with Perl), you can submit a +bug report to the GitHub issue tracker at +L<https://github.com/Perl/perl5/issues>. To determine if a module came with your version of Perl, you can install and use the L<Module::CoreList> module. It has the information diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq3.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq3.pod index df99fd8d878..481c3c94674 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq3.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq3.pod @@ -4,7 +4,7 @@ perlfaq3 - Programming Tools =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -300,8 +300,8 @@ L<http://www.ddj.com/184404522> , and "Profiling in Perl" L<http://www.ddj.com/184404580> . Perl.com has two interesting articles on profiling: "Profiling Perl", -by Simon Cozens, L<http://www.perl.com/lpt/a/850> and "Debugging and -Profiling mod_perl Applications", by Frank Wiles, +by Simon Cozens, L<https://www.perl.com/pub/2004/06/25/profiling.html/> +and "Debugging and Profiling mod_perl Applications", by Frank Wiles, L<http://www.perl.com/pub/a/2006/02/09/debug_mod_perl.html> . Randal L. Schwartz writes about profiling in "Speeding up Your Perl @@ -340,7 +340,7 @@ Put that in your F<.exrc> file (replacing the caret characters with control characters) and away you go. In insert mode, ^T is for indenting, ^D is for undenting, and ^O is for blockdenting--as it were. A more complete example, with comments, can be found at -L<http://www.cpan.org/authors/id/TOMC/scripts/toms.exrc.gz> +L<http://www.cpan.org/authors/id/T/TO/TOMC/scripts/toms.exrc.gz> =head2 Is there an IDE or Windows Perl Editor? @@ -497,7 +497,7 @@ L<http://www.vim.org/> =item Vile -L<http://dickey.his.com/vile/vile.html> +L<http://invisible-island.net/vile/vile.html> =back @@ -558,7 +558,7 @@ are text editors for OS X that have a Perl sensitivity mode =head2 Where can I get Perl macros for vi? For a complete version of Tom Christiansen's vi configuration file, -see L<http://www.cpan.org/authors/Tom_Christiansen/scripts/toms.exrc.gz> , +see L<http://www.cpan.org/authors/id/T/TO/TOMC/scripts/toms.exrc.gz> , the standard benchmark file for vi emulators. The file runs best with nvi, the current version of vi out of Berkeley, which incidentally can be built with an embedded Perl interpreter--see L<http://www.cpan.org/src/misc/> . @@ -581,7 +581,7 @@ For CPerlMode, see L<http://www.emacswiki.org/cgi-bin/wiki/CPerlMode> The Curses module from CPAN provides a dynamically loadable object module interface to a curses library. A small demo can be found at the -directory L<http://www.cpan.org/authors/Tom_Christiansen/scripts/rep.gz> ; +directory L<http://www.cpan.org/authors/id/T/TO/TOMC/scripts/rep.gz> ; this program repeats a command and updates the screen as needed, rendering B<rep ps axu> similar to B<top>. @@ -1066,7 +1066,7 @@ guides and references in L<perlfaq9> or in the CGI MetaFAQ: L<http://www.perl.org/CGI_MetaFAQ.html> -Looking in to L<Plack> and modern Perl web frameworks is highly recommended, +Looking into L<https://plackperl.org> and modern Perl web frameworks is highly recommended, though; web programming in Perl has evolved a long way from the old days of simple CGI scripts. @@ -1098,7 +1098,8 @@ XS support files. Download the ExtUtils::Embed kit from CPAN and run `make test'. If the tests pass, read the pods again and again and again. If they -fail, see L<perlbug> and send a bug report with the output of +fail, submit a bug report to L<https://github.com/Perl/perl5/issues> +with the output of C<make test TEST_VERBOSE=1> along with C<perl -V>. =head2 When I tried to run my script, I got this message. What does it mean? diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq4.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq4.pod index 55f9f6fd138..1a20aba2e71 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq4.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq4.pod @@ -4,7 +4,7 @@ perlfaq4 - Data Manipulation =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -1422,21 +1422,7 @@ Hearing the word "in" is an I<in>dication that you probably should have used a hash, not a list or array, to store your data. Hashes are designed to answer this question quickly and efficiently. Arrays aren't. -That being said, there are several ways to approach this. In Perl 5.10 -and later, you can use the smart match operator to check that an item is -contained in an array or a hash: - - use 5.010; - - if( $item ~~ @array ) { - say "The array contains $item" - } - - if( $item ~~ %hash ) { - say "The hash contains $item" - } - -With earlier versions of Perl, you have to do a bit more work. If you +That being said, there are several ways to approach this. If you are going to make this query many times over arbitrary string values, the fastest way is probably to invert the original array and maintain a hash whose keys are the first array's values: @@ -1472,16 +1458,16 @@ of the original list or array. They only pay off if you have to test multiple values against the same array. If you are testing only once, the standard module L<List::Util> exports -the function C<first> for this purpose. It works by stopping once it +the function C<any> for this purpose. It works by stopping once it finds the element. It's written in C for speed, and its Perl equivalent looks like this subroutine: - sub first (&@) { + sub any (&@) { my $code = shift; foreach (@_) { - return $_ if &{$code}(); + return 1 if $code->(); } - undef; + return 0; } If speed is of little concern, the common idiom uses grep in scalar context @@ -1514,19 +1500,6 @@ in either A or in B but not in both. Think of it as an xor operation. =head2 How do I test whether two arrays or hashes are equal? -With Perl 5.10 and later, the smart match operator can give you the answer -with the least amount of work: - - use 5.010; - - if( @array1 ~~ @array2 ) { - say "The arrays are the same"; - } - - if( %hash1 ~~ %hash2 ) # doesn't check values! { - say "The hash keys are the same"; - } - The following code works for single-level arrays. It uses a stringwise comparison, and does not distinguish defined versus undefined empty strings. Modify if you have other needs. diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq5.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq5.pod index aa7764b969d..a7fc0eabd12 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq5.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq5.pod @@ -4,7 +4,7 @@ perlfaq5 - Files and Formats =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq6.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq6.pod index eeaad01e2b9..9a45f0e6703 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq6.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq6.pod @@ -4,7 +4,7 @@ perlfaq6 - Regular Expressions =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq7.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq7.pod index c2014646cc2..a69e0536f08 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq7.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq7.pod @@ -4,7 +4,7 @@ perlfaq7 - General Perl Language Issues =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq8.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq8.pod index d9418ed5039..8ee088a3594 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq8.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq8.pod @@ -4,7 +4,7 @@ perlfaq8 - System Interaction =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -1323,7 +1323,7 @@ settings. See the L<ExtUtils::Makemaker> documentation for more details. (contributed by brian d foy) If you know the directory already, you can add it to C<@INC> as you would -for any other directory. You might <use lib> if you know the directory +for any other directory. You might C<use lib> if you know the directory at compile time: use lib $directory; @@ -1400,10 +1400,6 @@ environment variables, run-time switches, and in-code statements: =back -The last is particularly useful because it knows about machine-dependent -architectures. The C<lib.pm> pragmatic module was first -included with the 5.002 release of Perl. - =head2 Where are modules installed? Modules are installed on a case-by-case basis (as provided by the methods diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq9.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq9.pod index 4a6799c5894..15ca2d03b8b 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq9.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlfaq9.pod @@ -4,7 +4,7 @@ perlfaq9 - Web, Email and Networking =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION @@ -78,7 +78,7 @@ Plack is like Ruby's Rack or Python's Paste for WSGI. You could build a web site using L<Plack> and your own code, but for anything other than a very basic web site, using a web framework -(that uses L<Plack>) is a better option. +(that uses L<https://plackperl.org>) is a better option. =head2 How do I remove HTML from a string? @@ -95,29 +95,30 @@ L<HTML::LinkExtor> or L<HTML::Parser>. You might even use L<HTML::SimpleLinkExtor> as an example for something specifically suited to your needs. -You can use L<URI::Find> to extract URLs from an arbitrary text document. +You can use L<URI::Find> or L<URL::Search> to extract URLs from an +arbitrary text document. =head2 How do I fetch an HTML file? (contributed by brian d foy) -Use the libwww-perl distribution. The L<LWP::Simple> module can fetch web -resources and give their content back to you as a string: +The core L<HTTP::Tiny> module can fetch web resources and give their +content back to you as a string: - use LWP::Simple qw(get); + use HTTP::Tiny; - my $html = get( "http://www.example.com/index.html" ); + my $ua = HTTP::Tiny->new; + my $html = $ua->get( "http://www.example.com/index.html" )->{content}; It can also store the resource directly in a file: - use LWP::Simple qw(getstore); + $ua->mirror( "http://www.example.com/index.html", "foo.html" ); - getstore( "http://www.example.com/index.html", "foo.html" ); - -If you need to do something more complicated, you can use -L<LWP::UserAgent> module to create your own user-agent (e.g. browser) -to get the job done. If you want to simulate an interactive web -browser, you can use the L<WWW::Mechanize> module. +If you need to do something more complicated, the L<HTTP::Tiny> object can +be customized by setting attributes, or you can use L<LWP::UserAgent> from +the libwww-perl distribution or L<Mojo::UserAgent> from the Mojolicious +distribution to make common tasks easier. If you want to simulate an +interactive web browser, you can use the L<WWW::Mechanize> module. =head2 How do I automate an HTML form submission? @@ -126,25 +127,26 @@ and forms or a web site, you can use L<WWW::Mechanize>. See its documentation for all the details. If you're submitting values using the GET method, create a URL and encode -the form using the C<query_form> method: +the form using the C<www_form_urlencode> method from L<HTTP::Tiny>: + + use HTTP::Tiny; - use LWP::Simple; - use URI::URL; + my $ua = HTTP::Tiny->new; - my $url = url('L<http://www.perl.com/cgi-bin/cpan_mod')>; - $url->query_form(module => 'DB_File', readme => 1); - $content = get($url); + my $query = $ua->www_form_urlencode([ q => 'DB_File', lucky => 1 ]); + my $url = "https://metacpan.org/search?$query"; + my $content = $ua->get($url)->{content}; -If you're using the POST method, create your own user agent and encode -the content appropriately. +If you're using the POST method, the C<post_form> method will encode the +content appropriately. - use HTTP::Request::Common qw(POST); - use LWP::UserAgent; + use HTTP::Tiny; - my $ua = LWP::UserAgent->new(); - my $req = POST 'L<http://www.perl.com/cgi-bin/cpan_mod'>, - [ module => 'DB_File', readme => 1 ]; - my $content = $ua->request($req)->as_string; + my $ua = HTTP::Tiny->new; + + my $url = 'https://metacpan.org/search'; + my $form = [ q => 'DB_File', lucky => 1 ]; + my $content = $ua->post_form($url, $form)->{content}; =head2 How do I decode or create those %-encodings on the web? X<URI> X<URI::Escape> X<RFC 2396> @@ -287,26 +289,18 @@ your policy says it is. You really are best off asking the user. =head2 How do I send email? -Use the L<Email::MIME> and L<Email::Sender::Simple> modules, like so: +Use the L<Email::Stuffer> module, like so: # first, create your message - my $message = Email::MIME->create( - header_str => [ - From => 'you@example.com', - To => 'friend@example.com', - Subject => 'Happy birthday!', - ], - attributes => { - encoding => 'quoted-printable', - charset => 'utf-8', - }, - body_str => "Happy birthday to you!\n", - ); - - use Email::Sender::Simple qw(sendmail); - sendmail($message); - -By default, L<Email::Sender::Simple> will try `sendmail` first, if it exists + my $message = Email::Stuffer->from('you@example.com') + ->to('friend@example.com') + ->subject('Happy birthday!') + ->text_body("Happy birthday to you!\n"); + + $message->send_or_die; + +By default, L<Email::Sender::Simple> (the C<send> and C<send_or_die> methods +use this under the hood) will try C<sendmail> first, if it exists in your $PATH. This generally isn't the case. If there's a remote mail server you use to send mail, consider investigating one of the Transport classes. At time of writing, the available transports include: @@ -326,14 +320,9 @@ uses TLS or SSL and can authenticate to the server via SASL. =back -Telling L<Email::Sender::Simple> to use your transport is straightforward. +Telling L<Email::Stuffer> to use your transport is straightforward. - sendmail( - $message, - { - transport => $email_sender_transport_object, - } - ); + $message->transport($email_sender_transport_object)->send_or_die; =head2 How do I use MIME to make an attachment to a mail message? @@ -342,6 +331,15 @@ objects themselves are parts and can be attached to other L<Email::MIME> objects. Consult the L<Email::MIME> documentation for more information, including all of the supported methods and examples of their use. +L<Email::Stuffer> uses L<Email::MIME> under the hood to construct +messages, and wraps the most common attachment tasks with the simple +C<attach> and C<attach_file> methods. + + Email::Stuffer->to('friend@example.com') + ->subject('The file') + ->attach_file('stuff.csv') + ->send_or_die; + =head2 How do I read email? Use the L<Email::Folder> module, like so: diff --git a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlglossary.pod b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlglossary.pod index 3fef83de0db..2e7eedad3c5 100644 --- a/gnu/usr.bin/perl/cpan/perlfaq/lib/perlglossary.pod +++ b/gnu/usr.bin/perl/cpan/perlfaq/lib/perlglossary.pod @@ -7,7 +7,7 @@ perlglossary - Perl Glossary =head1 VERSION -version 5.20190126 +version 5.20200523 =head1 DESCRIPTION diff --git a/gnu/usr.bin/perl/cpan/podlators/Makefile.PL b/gnu/usr.bin/perl/cpan/podlators/Makefile.PL index a2008fefc71..ff76df5f9f7 100644 --- a/gnu/usr.bin/perl/cpan/podlators/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/podlators/Makefile.PL @@ -4,7 +4,7 @@ # which only supports that build method, and because it is a dependency of # other build systems like Module::Build. # -# Copyright 1999-2001, 2008, 2010, 2012, 2014-2016, 2018 +# Copyright 1999-2001, 2008, 2010, 2012, 2014-2016, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it @@ -12,7 +12,7 @@ # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; @@ -89,7 +89,7 @@ my %metadata = ( LICENSE => 'perl_5', EXE_FILES => [scripts('pod2text', 'pod2man')], VERSION_FROM => 'lib/Pod/Man.pm', - MIN_PERL_VERSION => '5.006', + MIN_PERL_VERSION => '5.008', # Use *.PL files to generate the driver scripts so that we get the correct # invocation of Perl on non-UNIX platforms. @@ -111,10 +111,7 @@ my %metadata = ( realclean => { FILES => scalar(scripts('pod2text', 'pod2man')) }, # Dependencies on other modules. - PREREQ_PM => { - 'Encode' => 0, - 'Pod::Simple' => 3.06, - }, + PREREQ_PM => { 'Pod::Simple' => 3.06 }, # Older versions of ExtUtils::MakeMaker don't pick up nested test # directories by default. diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm index 71798c2533e..d7c029357a2 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Man.pm @@ -14,7 +14,7 @@ package Pod::Man; -use 5.006; +use 5.008; use strict; use warnings; @@ -24,7 +24,9 @@ use vars qw(@ISA %ESCAPES $PREAMBLE $VERSION); use Carp qw(carp croak); use Pod::Simple (); -# Conditionally import Encode and set $HAS_ENCODE if it is available. +# Conditionally import Encode and set $HAS_ENCODE if it is available. This is +# required to support building as part of Perl core, since podlators is built +# before Encode is. our $HAS_ENCODE; BEGIN { $HAS_ENCODE = eval { require Encode }; @@ -32,7 +34,7 @@ BEGIN { @ISA = qw(Pod::Simple); -$VERSION = '4.11'; +$VERSION = '4.14'; # Set the debugging level. If someone has inserted a debug function into this # class already, use that. Otherwise, use any Pod::Simple debug function @@ -245,13 +247,8 @@ sub init_quotes { sub init_page { my ($self) = @_; - # We used to try first to get the version number from a local binary, but - # we shouldn't need that any more. Get the version from the running Perl. - # Work a little magic to handle subversions correctly under both the - # pre-5.6 and the post-5.6 version numbering schemes. - my @version = ($] =~ /^(\d+)\.(\d{3})(\d{0,3})$/); - $version[2] ||= 0; - $version[2] *= 10 ** (3 - length $version[2]); + # Get the version from the running Perl. + my @version = ($] =~ /^(\d+)\.(\d{3})(\d+)$/); for (@version) { $_ += 0 } my $version = join ('.', @version); @@ -799,7 +796,7 @@ sub start_document { eval { my @options = (output => 1, details => 1); my @layers = PerlIO::get_layers (*{$$self{output_fh}}, @options); - if ($layers[-1] & PerlIO::F_UTF8 ()) { + if ($layers[-1] && ($layers[-1] & PerlIO::F_UTF8 ())) { $$self{ENCODE} = 0; } } @@ -903,8 +900,6 @@ sub devise_title { $cut = $i + 1; $cut++ if ($dirs[$i + 1] && $dirs[$i + 1] eq 'lib'); last; - } elsif ($dirs[$i] eq 'lib' && $dirs[$i + 1] && $dirs[0] eq 'ext') { - $cut = $i + 1; } } if ($cut > 0) { @@ -1883,7 +1878,9 @@ being the file to write the formatted output to. You can also call parse_lines() to parse an array of lines or parse_string_document() to parse a document already in memory. As with parse_file(), parse_lines() and parse_string_document() default to sending -their output to C<STDOUT> unless changed with the output_fh() method. +their output to C<STDOUT> unless changed with the output_fh() method. Be +aware that parse_lines() and parse_string_document() both expect raw bytes, +not decoded characters. To put the output from any parse method into a string instead of a file handle, call the output_string() method instead of output_fh(). @@ -2014,7 +2011,7 @@ are mine). =head1 COPYRIGHT AND LICENSE -Copyright 1999-2010, 2012-2018 Russ Allbery <rra@cpan.org> +Copyright 1999-2010, 2012-2019 Russ Allbery <rra@cpan.org> Substantial contributions by Sean Burke <sburke@cpan.org>. diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/ParseLink.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/ParseLink.pm index 0be5323973b..273c95847ac 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/ParseLink.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/ParseLink.pm @@ -13,7 +13,7 @@ package Pod::ParseLink; -use 5.006; +use 5.008; use strict; use warnings; @@ -23,7 +23,7 @@ use Exporter; @ISA = qw(Exporter); @EXPORT = qw(parselink); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Implementation @@ -167,11 +167,11 @@ L<perlpodspec> for more information. =head1 AUTHOR -Russ Allbery <rra@cpan.org>. +Russ Allbery <rra@cpan.org> =head1 COPYRIGHT AND LICENSE -Copyright 2001, 2008, 2009, 2014, 2018 Russ Allbery <rra@cpan.org> +Copyright 2001, 2008, 2009, 2014, 2018-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text.pm index b05730ef476..56e6e78a86c 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text.pm @@ -14,7 +14,7 @@ package Pod::Text; -use 5.006; +use 5.008; use strict; use warnings; @@ -30,7 +30,7 @@ use Pod::Simple (); # We have to export pod2text for backward compatibility. @EXPORT = qw(pod2text); -$VERSION = '4.11'; +$VERSION = '4.14'; # Ensure that $Pod::Simple::nbsp and $Pod::Simple::shy are available. Code # taken from Pod::Simple 3.32, but was only added in 3.30. @@ -39,16 +39,8 @@ if ($Pod::Simple::VERSION ge 3.30) { $NBSP = $Pod::Simple::nbsp; $SHY = $Pod::Simple::shy; } else { - if ($] ge 5.007_003) { - $NBSP = chr utf8::unicode_to_native(0xA0); - $SHY = chr utf8::unicode_to_native(0xAD); - } elsif (Pod::Simple::ASCII) { - $NBSP = "\xA0"; - $SHY = "\xAD"; - } else { - $NBSP = "\x41"; - $SHY = "\xCA"; - } + $NBSP = chr utf8::unicode_to_native(0xA0); + $SHY = chr utf8::unicode_to_native(0xAD); } ############################################################################## @@ -247,7 +239,7 @@ sub wrap { my $spaces = ' ' x $$self{MARGIN}; my $width = $$self{opt_width} - $$self{MARGIN}; while (length > $width) { - if (s/^([^\n]{0,$width})\s+// || s/^([^\n]{$width})//) { + if (s/^([^\n]{0,$width})[ \t\n]+// || s/^([^\n]{$width})//) { $output .= $spaces . $1 . "\n"; } else { last; @@ -265,14 +257,16 @@ sub reformat { local $_ = shift; # If we're trying to preserve two spaces after sentences, do some munging - # to support that. Otherwise, smash all repeated whitespace. + # to support that. Otherwise, smash all repeated whitespace. Be careful + # not to use \s here, which in Unicode input may match non-breaking spaces + # that we don't want to smash. if ($$self{opt_sentence}) { s/ +$//mg; s/\.\n/. \n/g; s/\n/ /g; s/ +/ /g; } else { - s/\s+/ /g; + s/[ \t\n]+/ /g; } return $self->wrap ($_); } @@ -333,15 +327,14 @@ sub start_document { # When UTF-8 output is set, check whether our output file handle already # has a PerlIO encoding layer set. If it does not, we'll need to encode - # our output before printing it (handled in the output() sub). Wrap the - # check in an eval to handle versions of Perl without PerlIO. + # our output before printing it (handled in the output() sub). $$self{ENCODE} = 0; if ($$self{opt_utf8}) { $$self{ENCODE} = 1; eval { my @options = (output => 1, details => 1); my $flag = (PerlIO::get_layers ($$self{output_fh}, @options))[-1]; - if ($flag & PerlIO::F_UTF8 ()) { + if ($flag && ($flag & PerlIO::F_UTF8 ())) { $$self{ENCODE} = 0; $$self{ENCODING} = 'UTF-8'; } @@ -919,7 +912,9 @@ being the file to write the formatted output to. You can also call parse_lines() to parse an array of lines or parse_string_document() to parse a document already in memory. As with parse_file(), parse_lines() and parse_string_document() default to sending -their output to C<STDOUT> unless changed with the output_fh() method. +their output to C<STDOUT> unless changed with the output_fh() method. Be +aware that parse_lines() and parse_string_document() both expect raw bytes, +not decoded characters. To put the output from any parse method into a string instead of a file handle, call the output_string() method instead of output_fh(). @@ -1006,7 +1001,7 @@ how to use Pod::Simple. =head1 COPYRIGHT AND LICENSE -Copyright 1999-2002, 2004, 2006, 2008-2009, 2012-2016, 2018 Russ Allbery +Copyright 1999-2002, 2004, 2006, 2008-2009, 2012-2016, 2018-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Color.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Color.pm index 8d956f2a5dd..5d47c5ecb3b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Color.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Color.pm @@ -12,7 +12,7 @@ package Pod::Text::Color; -use 5.006; +use 5.008; use strict; use warnings; @@ -23,7 +23,7 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Overrides @@ -97,9 +97,6 @@ sub wrap { # $shortchar matches some sequence of $char ending in codes followed by # whitespace or the end of the string. $longchar matches exactly $width # $chars, used when we have to truncate and hard wrap. - # - # $shortchar and $longchar are created in a slightly odd way because the - # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. my $code = '(?:\e\[[\d;]+m)'; my $char = "(?>$code*[^\\n])"; my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)'; @@ -185,7 +182,7 @@ Russ Allbery <rra@cpan.org>. =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2018 Russ Allbery +Copyright 1999, 2001, 2004, 2006, 2008, 2009, 2018-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Overstrike.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Overstrike.pm index 92a3a9330e0..53bc6afef23 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Overstrike.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Overstrike.pm @@ -19,7 +19,7 @@ package Pod::Text::Overstrike; -use 5.006; +use 5.008; use strict; use warnings; @@ -29,7 +29,7 @@ use Pod::Text (); @ISA = qw(Pod::Text); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Overrides @@ -185,7 +185,7 @@ created by Russ Allbery <rra@cpan.org>. Subsequently updated by Russ Allbery. Copyright 2000 by Joe Smith <Joe.Smith@inwap.com> -Copyright 2001, 2004, 2008, 2014, 2018 by Russ Allbery <rra@cpan.org> +Copyright 2001, 2004, 2008, 2014, 2018-2019 by Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Termcap.pm b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Termcap.pm index d36ba4f518a..be218f0bf04 100644 --- a/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Termcap.pm +++ b/gnu/usr.bin/perl/cpan/podlators/lib/Pod/Text/Termcap.pm @@ -12,7 +12,7 @@ package Pod::Text::Termcap; -use 5.006; +use 5.008; use strict; use warnings; @@ -24,7 +24,7 @@ use vars qw(@ISA $VERSION); @ISA = qw(Pod::Text); -$VERSION = '4.11'; +$VERSION = '4.14'; ############################################################################## # Overrides @@ -36,14 +36,6 @@ sub new { my ($self, %args) = @_; my ($ospeed, $term, $termios); - # $ENV{HOME} is usually not set on Windows. The default Term::Cap path - # may not work on Solaris. - unless (exists $ENV{TERMPATH}) { - my $home = exists $ENV{HOME} ? "$ENV{HOME}/.termcap:" : ''; - $ENV{TERMPATH} = - "${home}/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap"; - } - # Fall back on a hard-coded terminal speed if POSIX::Termios isn't # available (such as on VMS). eval { $termios = POSIX::Termios->new }; @@ -80,10 +72,12 @@ sub new { # Initialize Pod::Text. $self = $self->SUPER::new (%args); - # Fall back on the ANSI escape sequences if Term::Cap doesn't work. - $$self{BOLD} = $bold || "\e[1m"; - $$self{UNDL} = $undl || "\e[4m"; - $$self{NORM} = $norm || "\e[m"; + # If we were unable to get any of the formatting sequences, don't attempt + # that type of formatting. This will do weird things if bold or underline + # were available but normal wasn't, but hopefully that will never happen. + $$self{BOLD} = $bold || q{}; + $$self{UNDL} = $undl || q{}; + $$self{NORM} = $norm || q{}; return $self; } @@ -106,11 +100,19 @@ sub cmd_head2 { sub cmd_b { my $self = shift; return "$$self{BOLD}$_[1]$$self{NORM}" } sub cmd_i { my $self = shift; return "$$self{UNDL}$_[1]$$self{NORM}" } +# Return a regex that matches a formatting sequence. This will only be valid +# if we were able to get at least some termcap information. +sub format_regex { + my ($self) = @_; + my @codes = ($self->{BOLD}, $self->{UNDL}, $self->{NORM}); + return join(q{|}, map { $_ eq q{} ? () : "\Q$_\E" } @codes); +} + # Analyze a single line and return any formatting codes in effect at the end # of that line. sub end_format { my ($self, $line) = @_; - my $pattern = "(\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + my $pattern = "(" . $self->format_regex() . ")"; my $current; while ($line =~ /$pattern/g) { my $code = $1; @@ -147,15 +149,17 @@ sub wrap { my $spaces = ' ' x $$self{MARGIN}; my $width = $$self{opt_width} - $$self{MARGIN}; + # If we were unable to find any termcap sequences, use Pod::Text wrapping. + if ($self->{BOLD} eq q{} && $self->{UNDL} eq q{} && $self->{NORM} eq q{}) { + return $self->SUPER::wrap($_); + } + # $code matches a single special sequence. $char matches any number of # special sequences preceding a single character other than a newline. # $shortchar matches some sequence of $char ending in codes followed by # whitespace or the end of the string. $longchar matches exactly $width # $chars, used when we have to truncate and hard wrap. - # - # $shortchar and $longchar are created in a slightly odd way because the - # construct ${char}{0,$width} didn't do the right thing until Perl 5.8.x. - my $code = "(?:\Q$$self{BOLD}\E|\Q$$self{UNDL}\E|\Q$$self{NORM}\E)"; + my $code = "(?:" . $self->format_regex() . ")"; my $char = "(?>$code*[^\\n])"; my $shortchar = '^(' . $char . "{0,$width}(?>$code*)" . ')(?:\s+|\z)'; my $longchar = '^(' . $char . "{$width})"; @@ -225,34 +229,20 @@ text using the correct termcap escape sequences for the current terminal. Apart from the format codes, it in all ways functions like Pod::Text. See L<Pod::Text> for details and available options. -=head1 ENVIRONMENT - -This module sets the TERMPATH environment variable globally to: - - $HOME/.termcap:/etc/termcap:/usr/share/misc/termcap:/usr/share/lib/termcap - -if it isn't already set. (The first entry is omitted if the HOME -environment variable isn't set.) This is a (very old) workaround for -problems finding termcap information on older versions of Solaris, and is -not good module behavior. Please do not rely on this behavior; it may be -dropped in a future release. - -=head1 NOTES - -This module uses Term::Cap to retrieve the formatting escape sequences for -the current terminal, and falls back on the ECMA-48 (the same in this -regard as ANSI X3.64 and ISO 6429, the escape codes also used by DEC VT100 -terminals) if the bold, underline, and reset codes aren't set in the -termcap information. +This module uses L<Term::Cap> to find the correct terminal settings. See the +documentation of that module for how it finds terminal database information +and how to override that behavior if necessary. If unable to find control +strings for bold and underscore formatting, that formatting is skipped, +resulting in the same output as Pod::Text. =head1 AUTHOR -Russ Allbery <rra@cpan.org>. +Russ Allbery <rra@cpan.org> =head1 COPYRIGHT AND LICENSE -Copyright 1999, 2001-2002, 2004, 2006, 2008-2009, 2014-2015, 2018 Russ Allbery -<rra@cpan.org> +Copyright 1999, 2001-2002, 2004, 2006, 2008-2009, 2014-2015, 2018-2019 Russ +Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL b/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL index cc6f955350d..d6e685d2010 100644 --- a/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL +++ b/gnu/usr.bin/perl/cpan/podlators/scripts/pod2man.PL @@ -4,7 +4,7 @@ # required for proper start-up code on non-UNIX platforms, and is used inside # Perl core. -use 5.006; +use 5.008; use strict; use warnings; @@ -71,13 +71,12 @@ my $stdin; # Parse our options, trying to retain backward compatibility with pod2man but # allowing short forms as well. --lax is currently ignored. my %options; -$options{utf8} = 1; Getopt::Long::config ('bundling_override'); GetOptions (\%options, 'center|c=s', 'date|d=s', 'errors=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', 'fixedbolditalic=s', 'help|h', 'lax|l', 'lquote=s', 'name|n=s', 'nourls', 'official|o', 'quotes|q=s', 'release|r=s', 'rquote=s', 'section|s=s', 'stderr', - 'verbose|v', 'utf8|u!') + 'verbose|v', 'utf8|u') or exit 1; pod2usage (0) if $options{help}; @@ -127,7 +126,7 @@ exit $status; __END__ =for stopwords -en em --stderr stderr --no-utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris URL +en em --stderr stderr --utf8 UTF-8 overdo markup MT-LEVEL Allbery Solaris URL troff troff-specific formatters uppercased Christiansen --nourls UTC prepend lquote rquote @@ -142,7 +141,7 @@ pod2man [B<--center>=I<string>] [B<--date>=I<string>] [B<--errors>=I<style>] [B<--fixedbolditalic>=I<font>] [B<--name>=I<name>] [B<--nourls>] [B<--official>] [B<--release>=I<version>] [B<--section>=I<manext>] [B<--quotes>=I<quotes>] [B<--lquote>=I<quote>] [B<--rquote>=I<quote>] - [B<--stderr>] [B<--no-utf8>] [B<--verbose>] [I<input> [I<output>] ...] + [B<--stderr>] [B<--utf8>] [B<--verbose>] [I<input> [I<output>] ...] pod2man B<--help> @@ -345,10 +344,19 @@ to C<--errors=stderr> and is supported for backward compatibility. =item B<-u>, B<--utf8> -This option allows B<pod2man> to output literal UTF-8 characters. -On OpenBSD, it is enabled by default and can be disabled with -B<--no-utf8>, in which case non-ASCII characters are converted -either to *roff escape sequences or to C<X>. +By default, B<pod2man> produces the most conservative possible *roff +output to try to ensure that it will work with as many different *roff +implementations as possible. Many *roff implementations cannot handle +non-ASCII characters, so this means all non-ASCII characters are converted +either to a *roff escape sequence that tries to create a properly accented +character (at least for troff output) or to C<X>. + +This option says to instead output literal UTF-8 characters. If your +*roff implementation can handle it, this is the best output format to use +and avoids corruption of documents containing non-ASCII characters. +However, be warned that *roff source with literal UTF-8 characters is not +supported by many implementations and may even result in segfaults and +other bad behavior. Be aware that, when using this option, the input encoding of your POD source should be properly declared unless it's US-ASCII. Pod::Simple will @@ -409,7 +417,7 @@ B<pod2man> by Larry Wall and Tom Christiansen. =head1 COPYRIGHT AND LICENSE -Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2018 Russ Allbery +Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it diff --git a/gnu/usr.bin/perl/cpan/podlators/scripts/pod2text.PL b/gnu/usr.bin/perl/cpan/podlators/scripts/pod2text.PL index bae85741523..be06960ad76 100644 --- a/gnu/usr.bin/perl/cpan/podlators/scripts/pod2text.PL +++ b/gnu/usr.bin/perl/cpan/podlators/scripts/pod2text.PL @@ -4,7 +4,7 @@ # required for proper start-up code on non-UNIX platforms, and is used inside # Perl core. -use 5.006; +use 5.008; use strict; use warnings; @@ -346,7 +346,7 @@ Russ Allbery <rra@cpan.org>. =head1 COPYRIGHT AND LICENSE -Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2018 Russ Allbery +Copyright 1999-2001, 2004, 2006, 2008, 2010, 2012-2019 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it diff --git a/gnu/usr.bin/perl/cpan/podlators/t/docs/pod-spelling.t b/gnu/usr.bin/perl/cpan/podlators/t/docs/pod-spelling.t index 94d75035bc6..819aa693314 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/docs/pod-spelling.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/docs/pod-spelling.t @@ -6,6 +6,7 @@ # which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. # # Written by Russ Allbery <eagle@eyrie.org> +# Copyright 2019 Russ Allbery <eagle@eyrie.org> # Copyright 2013-2014 # The Board of Trustees of the Leland Stanford Junior University # @@ -29,15 +30,16 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use Test::More; use Test::RRA qw(skip_unless_author use_prereq); +use Test::More; + # Only run this test for the module author since the required stopwords are # too sensitive to the exact spell-checking program and dictionary. skip_unless_author('Spelling tests'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/docs/pod.t b/gnu/usr.bin/perl/cpan/podlators/t/docs/pod.t index 5fcfcdf77cf..e7d02316606 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/docs/pod.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/docs/pod.t @@ -6,6 +6,7 @@ # which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. # # Written by Russ Allbery <eagle@eyrie.org> +# Copyright 2019 Russ Allbery <eagle@eyrie.org> # Copyright 2012-2014 # The Board of Trustees of the Leland Stanford Junior University # @@ -29,15 +30,16 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use Test::More; use Test::RRA qw(skip_unless_automated use_prereq); +use Test::More; + # Skip this test for normal user installs, although pod2man may still fail. skip_unless_automated('POD syntax tests'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/docs/synopsis.t b/gnu/usr.bin/perl/cpan/podlators/t/docs/synopsis.t index 43a8354ba40..1a2fbf1af28 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/docs/synopsis.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/docs/synopsis.t @@ -6,6 +6,7 @@ # which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. # # Written by Russ Allbery <eagle@eyrie.org> +# Copyright 2019 Russ Allbery <eagle@eyrie.org> # Copyright 2013-2014 # The Board of Trustees of the Leland Stanford Junior University # @@ -29,15 +30,16 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; +use Test::RRA qw(skip_unless_automated use_prereq); + use File::Spec; use Test::More; -use Test::RRA qw(skip_unless_automated use_prereq); # Skip for normal user installs since this doesn't affect functionality. skip_unless_automated('Synopsis syntax tests'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/docs/urls.t b/gnu/usr.bin/perl/cpan/podlators/t/docs/urls.t deleted file mode 100644 index a654c5453c2..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/docs/urls.t +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/bin/perl -# -# Check URLs in source files. -# -# Examine all source files in a distribution for bad URL patterns and report -# on files that fail this check. Currently, this just checks that all the -# links to www.eyrie.org are https. -# -# The canonical version of this file is maintained in the rra-c-util package, -# which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. -# -# Copyright 2016 Russ Allbery <eagle@eyrie.org> -# -# Permission is hereby granted, free of charge, to any person obtaining a -# copy of this software and associated documentation files (the "Software"), -# to deal in the Software without restriction, including without limitation -# the rights to use, copy, modify, merge, publish, distribute, sublicense, -# and/or sell copies of the Software, and to permit persons to whom the -# Software is furnished to do so, subject to the following conditions: -# -# The above copyright notice and this permission notice shall be included in -# all copies or substantial portions of the Software. -# -# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL -# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING -# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER -# DEALINGS IN THE SOFTWARE. -# -# SPDX-License-Identifier: MIT - -use 5.006; -use strict; -use warnings; - -use lib 't/lib'; - -use File::Find qw(find); -use Test::More; -use Test::RRA qw(skip_unless_automated); - -# Bad patterns to search for. -my @BAD_REGEXES = (qr{ http:// \S+ [.]eyrie[.]org }xms); -my @BAD_STRINGS = qw(rra@stanford.edu); - -# File or directory names to always skip. -my %SKIP = map { $_ => 1 } qw(.git _build blib cover_db); - -# Only run this test during automated testing, since failure doesn't indicate -# any user-noticable flaw in the package itself. -skip_unless_automated('Documentation URL tests'); - -# Scan files for bad URL patterns. This is meant to be run as the wanted -# function from File::Find. -sub check_file { - my $filename = $_; - - # Ignore this check itself (or the non-Perl version of it). Ignore any - # directories or binary files. Ignore and prune any skipped files. - if ($SKIP{$filename}) { - $File::Find::prune = 1; - return; - } - return if -d $filename; - return if !-T $filename; - return if ($filename eq 'urls.t' || $filename eq 'urls-t'); - - # Scan the file. - open(my $fh, '<', $filename) or BAIL_OUT("Cannot open $File::Find::name"); - while (defined(my $line = <$fh>)) { - for my $regex (@BAD_REGEXES) { - if ($line =~ $regex) { - ok(0, "$File::Find::name contains $regex"); - close($fh) or BAIL_OUT("Cannot close $File::Find::name"); - return; - } - } - for my $string (@BAD_STRINGS) { - if (index($line, $string) != -1) { - ok(0, "$File::Find::name contains $string"); - close($fh) or BAIL_OUT("Cannot close $File::Find::name"); - return; - } - } - } - close($fh) or BAIL_OUT("Cannot close $File::Find::name"); - ok(1, $File::Find::name); - return; -} - -# Use File::Find to scan all files from the top of the directory. -find(\&check_file, q{.}); -done_testing(); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/general/basic.t b/gnu/usr.bin/perl/cpan/podlators/t/general/basic.t index 717e3762dfd..d4978bcf366 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/general/basic.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/general/basic.t @@ -12,7 +12,7 @@ # the machinery to run small POD snippets through the specific formatter being # tested should probably be used instead. # -# Copyright 2001-2002, 2004, 2006, 2009, 2012, 2014-2015, 2018 +# Copyright 2001-2002, 2004, 2006, 2009, 2012, 2014-2015, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it @@ -20,7 +20,7 @@ # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/general/filehandle.t b/gnu/usr.bin/perl/cpan/podlators/t/general/filehandle.t index 42601a05878..3c5d753a480 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/general/filehandle.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/general/filehandle.t @@ -6,14 +6,14 @@ # Pod::Man and Pod::Text had to implement it directly. Test to be sure it's # working properly. # -# Copyright 2006, 2009, 2012, 2014-2016, 2018 Russ Allbery <rra@cpan.org> +# Copyright 2006, 2009, 2012, 2014-2016, 2018-2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/general/pod-parser.t b/gnu/usr.bin/perl/cpan/podlators/t/general/pod-parser.t index 9c51aff87a4..c008499298e 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/general/pod-parser.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/general/pod-parser.t @@ -2,14 +2,14 @@ # # Tests for backward compatibility with Pod::Parser. # -# Copyright 2006, 2008-2009, 2012, 2015, 2018 by Russ Allbery <rra@cpan.org> +# Copyright 2006, 2008-2009, 2012, 2015, 2018-2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/Podlators.pm b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/Podlators.pm index 3ae940924e2..9254f26468e 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/Podlators.pm +++ b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/Podlators.pm @@ -8,7 +8,7 @@ package Test::Podlators; -use 5.006; +use 5.008; use strict; use warnings; @@ -91,7 +91,6 @@ sub _stderr_restore { # For the format, see t/data/snippets/README. # # $path - Relative path to read test data from -# $encoding - Encoding of snippet (UTF-8 if not specified) # # Returns: Reference to hash of test data with the following keys: # name - Name of the test for status reporting @@ -101,20 +100,18 @@ sub _stderr_restore { # errors - Expected errors # exception - Text of exception (with file and line stripped) sub read_snippet { - my ($path, $encoding) = @_; + my ($path) = @_; $path = File::Spec->catfile('t', 'data', 'snippets', $path); - $encoding ||= 'UTF-8'; my %data; # Read the sections and store them in the %data hash. my ($line, $section); open(my $fh, '<', $path) or BAIL_OUT("cannot open $path: $!"); while (defined($line = <$fh>)) { - $line = decode($encoding, $line); if ($line =~ m{ \A \s* \[ (\S+) \] \s* \z }xms) { $section = $1; + $data{$section} = q{}; } elsif ($section) { - $data{$section} ||= q{}; $data{$section} .= $line; } } @@ -248,11 +245,17 @@ sub slurp { # $class - Class name of the formatter, as a string # $snippet - Path to the snippet file defining the test # $options_ref - Hash of options with the following keys: -# encoding - Set to use a non-standard encoding +# encoding - Expect the output to be in this non-standard encoding sub test_snippet { my ($class, $snippet, $options_ref) = @_; - my $encoding = defined($options_ref) ? $options_ref->{encoding} : undef; - my $data_ref = read_snippet($snippet, $encoding); + my $data_ref = read_snippet($snippet); + + # Determine the encoding to expect for the output portion of the snippet. + my $encoding; + if (defined($options_ref)) { + $encoding = $options_ref->{encoding}; + } + $encoding ||= 'UTF-8'; # Create the formatter object. my $parser = $class->new(%{ $data_ref->{options} }, name => 'TEST'); @@ -277,9 +280,10 @@ sub test_snippet { $got =~ s{ \n\s+ \z }{\n}xms; # Check the output, errors, and any exception. - is($got, $data_ref->{output}, "$data_ref->{name}: output"); - if ($data_ref->{errors}) { - is($stderr, $data_ref->{errors}, "$data_ref->{name}: errors"); + my $expected = decode($encoding, $data_ref->{output}); + is($got, $expected, "$data_ref->{name}: output"); + if ($data_ref->{errors} || $stderr) { + is($stderr, $data_ref->{errors} || q{}, "$data_ref->{name}: errors"); } if ($data_ref->{exception} || $exception) { if ($exception) { @@ -299,11 +303,19 @@ sub test_snippet { # $class - Class name of the formatter, as a string # $snippet - Path to the snippet file defining the test # $options_ref - Hash of options with the following keys: +# encoding - Expect the snippet to be in this non-standard encoding # perlio_utf8 - Set to 1 to set a PerlIO UTF-8 encoding on the output file sub test_snippet_with_io { my ($class, $snippet, $options_ref) = @_; my $data_ref = read_snippet($snippet); + # Determine the encoding to expect for the output portion of the snippet. + my $encoding; + if (defined($options_ref)) { + $encoding = $options_ref->{encoding}; + } + $encoding ||= 'UTF-8'; + # Create the formatter object. my $parser = $class->new(%{ $data_ref->{options} }, name => 'TEST'); isa_ok($parser, $class, 'Parser object'); @@ -317,7 +329,7 @@ sub test_snippet_with_io { my $input_file = File::Spec->catfile('t', 'tmp', "tmp$$.pod"); open(my $input, '>', $input_file) or BAIL_OUT("cannot create $input_file: $!"); - print {$input} encode('UTF-8', $data_ref->{input}) + print {$input} $data_ref->{input} or BAIL_OUT("cannot write to $input_file: $!"); close($input) or BAIL_OUT("cannot flush output to $input_file: $!"); @@ -336,20 +348,23 @@ sub test_snippet_with_io { $parser->parse_from_file($input_file, $output); close($output) or BAIL_OUT("cannot flush output to $output_file: $!"); - # Read back in the results, checking to ensure that we didn't output the - # accent definitions if we wrote UTF-8 output. + # Read back in the results. For Pod::Man, also ensure that we didn't + # output the accent definitions if we wrote UTF-8 output. open(my $results, '<', $output_file) or BAIL_OUT("cannot open $output_file: $!"); my ($line, $saw_accents); - while (defined($line = <$results>)) { - $line = decode('UTF-8', $line); - if ($line =~ m{ Accent [ ] mark [ ] definitions }xms) { - $saw_accents = 1; + if ($class eq 'Pod::Man') { + while (defined($line = <$results>)) { + $line = decode('UTF-8', $line); + if ($line =~ m{ Accent [ ] mark [ ] definitions }xms) { + $saw_accents = 1; + } + last if $line =~ m{ \A [.]nh }xms; } - last if $line =~ m{ \A [.]nh }xms; } my $saw = do { local $/ = undef; <$results> }; $saw = decode('UTF-8', $saw); + $saw =~ s{ \n\s+ \z }{\n}xms; close($results) or BAIL_OUT("cannot close output file: $!"); # Clean up. @@ -357,12 +372,18 @@ sub test_snippet_with_io { # Check the accent definitions and the output. my $perlio = $options_ref->{perlio_utf8} ? ' (PerlIO)' : q{}; + if ($class eq 'Pod::Man') { + is( + $saw_accents, + $data_ref->{options}{utf8} ? undef : 1, + "$data_ref->{name}: accent definitions$perlio" + ); + } is( - $saw_accents, - $data_ref->{options}{utf8} ? undef : 1, - "$data_ref->{name}: accent definitions$perlio" + $saw, + decode($encoding, $data_ref->{output}), + "$data_ref->{name}: output$perlio" ); - is($saw, $data_ref->{output}, "$data_ref->{name}: output$perlio"); return; } @@ -396,15 +417,12 @@ should be explicitly imported. =over 4 -=item read_snippet(PATH[, ENCODING]) +=item read_snippet(PATH) Read one test snippet from the provided relative file name and return it. The path should be relative to F<t/data/snippets>. For the format, see F<t/data/snippets/README>. -ENCODING, if present, specifies the encoding of the snippet. If not given, -the snippet is assumed to be encoded in C<UTF-8>. - The result will be a hash with the following keys: =over 4 @@ -489,7 +507,7 @@ it, and checking the results. Results are reported with Test::More. OPTIONS, if present, is a reference to a hash of options. Currently, only one key is supported: C<encoding>, which, if set, specifies the encoding of -the snippet. +the output portion of the snippet. =item test_snippet_with_io(CLASS, SNIPPET[, OPTIONS]) @@ -509,7 +527,7 @@ Russ Allbery <rra@cpan.org> =head1 COPYRIGHT AND LICENSE -Copyright 2015, 2016, 2018 Russ Allbery <rra@cpan.org> +Copyright 2015-2016, 2018-2020 Russ Allbery <rra@cpan.org> This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA.pm b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA.pm index cbfdc42603c..1d5e4db23d4 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA.pm +++ b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA.pm @@ -10,25 +10,41 @@ package Test::RRA; -use 5.006; +use 5.008; +use base qw(Exporter); use strict; use warnings; -use Exporter; +use Carp qw(croak); use File::Temp; -use Test::More; -# For Perl 5.006 compatibility. -## no critic (ClassHierarchies::ProhibitExplicitISA) +# Abort if Test::More was loaded before Test::RRA to be sure that we get the +# benefits of the Test::More probing below. +if ($INC{'Test/More.pm'}) { + croak('Test::More loaded before Test::RRA'); +} + +# Red Hat's base perl package doesn't include Test::More (one has to install +# the perl-core package in addition). Try to detect this and skip any Perl +# tests if Test::More is not present. This relies on Test::RRA being included +# before Test::More. +eval { + require Test::More; + Test::More->import(); +}; +if ($@) { + print "1..0 # SKIP Test::More required for test\n" + or croak('Cannot write to stdout'); + exit 0; +} # Declare variables that should be set in BEGIN for robustness. -our (@EXPORT_OK, @ISA, $VERSION); +our (@EXPORT_OK, $VERSION); # Set $VERSION and everything export-related in a BEGIN block for robustness # against circular module loading (not that we load any modules, but # consistency is good). BEGIN { - @ISA = qw(Exporter); @EXPORT_OK = qw( is_file_contents skip_unless_author skip_unless_automated use_prereq ); @@ -36,7 +52,7 @@ BEGIN { # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '7.01'; + $VERSION = '8.01'; } # Compare a string to the contents of a file, similar to the standard is() @@ -61,22 +77,27 @@ sub is_file_contents { return; } - # Otherwise, we show a diff, but only if we have IPC::System::Simple. - eval { require IPC::System::Simple }; + # Otherwise, we show a diff, but only if we have IPC::System::Simple and + # diff succeeds. Otherwise, we fall back on showing the full expected and + # seen output. + eval { + require IPC::System::Simple; + + my $tmp = File::Temp->new(); + my $tmpname = $tmp->filename; + print {$tmp} $got or BAIL_OUT("Cannot write to $tmpname: $!\n"); + my @command = ('diff', '-u', $expected, $tmpname); + my $diff = IPC::System::Simple::capturex([0 .. 1], @command); + diag($diff); + }; if ($@) { - ok(0, $message); - return; + diag('Expected:'); + diag($expected); + diag('Seen:'); + diag($data); } - # They're not equal. Write out what we got so that we can run diff. - my $tmp = File::Temp->new(); - my $tmpname = $tmp->filename; - print {$tmp} $got or BAIL_OUT("Cannot write to $tmpname: $!\n"); - my @command = ('diff', '-u', $expected, $tmpname); - my $diff = IPC::System::Simple::capturex([0 .. 1], @command); - diag($diff); - - # Remove the temporary file and report failure. + # Report failure. ok(0, $message); return; } @@ -91,7 +112,7 @@ sub is_file_contents { sub skip_unless_author { my ($description) = @_; if (!$ENV{AUTHOR_TESTING}) { - plan skip_all => "$description only run for author"; + plan(skip_all => "$description only run for author"); } return; } @@ -110,7 +131,7 @@ sub skip_unless_automated { for my $env (qw(AUTOMATED_TESTING RELEASE_TESTING AUTHOR_TESTING)) { return if $ENV{$env}; } - plan skip_all => "$description normally skipped"; + plan(skip_all => "$description normally skipped"); return; } @@ -152,14 +173,14 @@ sub use_prereq { use $module $version \@imports; 1; }; - $error = $@; + $error = $@; $sigdie = $SIG{__DIE__} || undef; } # If the use failed for any reason, skip the test. if (!$result || $error) { my $name = length($version) > 0 ? "$module $version" : $module; - plan skip_all => "$name required for test"; + plan(skip_all => "$name required for test"); } # If the module set $SIG{__DIE__}, we cleared that via local. Restore it. @@ -202,6 +223,14 @@ This module collects utility functions that are useful for Perl test scripts. It assumes Russ Allbery's Perl module layout and test conventions and will only be useful for other people if they use the same conventions. +This module B<must> be loaded before Test::More or it will abort during +import. It will skip the test (by printing a skip message to standard output +and exiting with status 0, equivalent to C<plan skip_all>) during import if +Test::More is not available. This allows tests written in Perl using this +module to be skipped if run on a system with Perl but not Test::More, such as +Red Hat systems with the C<perl> package but not the C<perl-core> package +installed. + =head1 FUNCTIONS None of these functions are imported by default. The ones used by a script @@ -246,7 +275,9 @@ Russ Allbery <eagle@eyrie.org> =head1 COPYRIGHT AND LICENSE -Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior +Copyright 2016, 2018-2019 Russ Allbery <eagle@eyrie.org> + +Copyright 2013-2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/Config.pm b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/Config.pm index b2f94466dd2..80a15739410 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/Config.pm +++ b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/Config.pm @@ -9,24 +9,20 @@ package Test::RRA::Config; -use 5.006; +use 5.008; +use base qw(Exporter); use strict; use warnings; -# For Perl 5.006 compatibility. -## no critic (ClassHierarchies::ProhibitExplicitISA) - -use Exporter; use Test::More; # Declare variables that should be set in BEGIN for robustness. -our (@EXPORT_OK, @ISA, $VERSION); +our (@EXPORT_OK, $VERSION); # Set $VERSION and everything export-related in a BEGIN block for robustness # against circular module loading (not that we load any modules, but # consistency is good). BEGIN { - @ISA = qw(Exporter); @EXPORT_OK = qw( $COVERAGE_LEVEL @COVERAGE_SKIP_TESTS @CRITIC_IGNORE $LIBRARY_PATH $MINIMUM_VERSION %MINIMUM_VERSION @MODULE_VERSION_IGNORE @@ -36,7 +32,7 @@ BEGIN { # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '7.01'; + $VERSION = '8.01'; } # If C_TAP_BUILD or C_TAP_SOURCE are set in the environment, look for @@ -187,9 +183,9 @@ Russ Allbery <eagle@eyrie.org> =head1 COPYRIGHT AND LICENSE -Copyright 2015, 2016 Russ Allbery <eagle@eyrie.org> +Copyright 2015-2016, 2019 Russ Allbery <eagle@eyrie.org> -Copyright 2013, 2014 The Board of Trustees of the Leland Stanford Junior +Copyright 2013-2014 The Board of Trustees of the Leland Stanford Junior University Permission is hereby granted, free of charge, to any person obtaining a copy diff --git a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/ModuleVersion.pm b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/ModuleVersion.pm index 3b3d6742df9..fc8bfbc8de5 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/ModuleVersion.pm +++ b/gnu/usr.bin/perl/cpan/podlators/t/lib/Test/RRA/ModuleVersion.pm @@ -8,32 +8,28 @@ package Test::RRA::ModuleVersion; -use 5.006; +use 5.008; +use base qw(Exporter); use strict; use warnings; -use Exporter; use File::Find qw(find); use Test::More; use Test::RRA::Config qw(@MODULE_VERSION_IGNORE); -# For Perl 5.006 compatibility. -## no critic (ClassHierarchies::ProhibitExplicitISA) - # Declare variables that should be set in BEGIN for robustness. -our (@EXPORT_OK, @ISA, $VERSION); +our (@EXPORT_OK, $VERSION); # Set $VERSION and everything export-related in a BEGIN block for robustness # against circular module loading (not that we load any modules, but # consistency is good). BEGIN { - @ISA = qw(Exporter); @EXPORT_OK = qw(test_module_versions update_module_versions); # This version should match the corresponding rra-c-util release, but with # two digits for the minor version, including a leading zero if necessary, # so that it will sort properly. - $VERSION = '7.01'; + $VERSION = '8.01'; } # A regular expression matching the version string for a module using the @@ -129,21 +125,23 @@ sub _module_version { # Throws: Text exception on I/O failure or inability to find version sub _update_module_version { my ($file, $version) = @_; - open(my $in, q{<}, $file) or die "$0: cannot open $file: $!\n"; - open(my $out, q{>}, "$file.new") - or die "$0: cannot create $file.new: $!\n"; - # If the version starts with v, use it without quotes. Otherwise, quote - # it to prevent removal of trailing zeroes. - if ($version !~ m{ \A v }xms) { - $version = "'$version'"; + # The old-style syntax may require different quoting. If the version + # starts with v, use it without quotes. Otherwise, quote it to prevent + # removal of trailing zeroes. + my $old_version = $version; + if ($old_version !~ m{ \A v }xms) { + $old_version = "'$old_version'"; } # Scan for the version and replace it. + open(my $in, q{<}, $file) or die "$0: cannot open $file: $!\n"; + open(my $out, q{>}, "$file.new") + or die "$0: cannot create $file.new: $!\n"; SCAN: while (defined(my $line = <$in>)) { if ( $line =~ s{ $REGEX_VERSION_PACKAGE }{$1$version$3}xms - || $line =~ s{ $REGEX_VERSION_OLD }{$1$version$3}xms) + || $line =~ s{ $REGEX_VERSION_OLD }{$1$old_version$3}xms) { print {$out} $line or die "$0: cannot write to $file.new: $!\n"; last SCAN; @@ -153,8 +151,8 @@ sub _update_module_version { # Copy the rest of the input file to the output file. print {$out} <$in> or die "$0: cannot write to $file.new: $!\n"; - close($out) or die "$0: cannot flush $file.new: $!\n"; - close($in) or die "$0: error reading from $file: $!\n"; + close($out) or die "$0: cannot flush $file.new: $!\n"; + close($in) or die "$0: error reading from $file: $!\n"; # All done. Rename the new file over top of the old file. rename("$file.new", $file) @@ -267,7 +265,7 @@ Russ Allbery <eagle@eyrie.org> =head1 COPYRIGHT AND LICENSE -Copyright 2016 Russ Allbery <eagle@eyrie.org> +Copyright 2016, 2018-2019 Russ Allbery <eagle@eyrie.org> Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/devise-date.t b/gnu/usr.bin/perl/cpan/podlators/t/man/devise-date.t index 129721323c6..4729e0bf0f5 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/devise-date.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/devise-date.t @@ -3,16 +3,16 @@ # In order for MakeMaker to build in the core, nothing can use Fcntl which # includes POSIX. devise_date()'s use of strftime() was replaced. This tests # that it's identical. It also tests special handling of the POD_MAN_DATE -# environment variable. +# and SOURCE_DATE_EPOCH environment variables. # -# Copyright 2009, 2014-2015, 2018 Russ Allbery <rra@cpan.org> +# Copyright 2009, 2014-2015, 2018-2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/devise-title.t b/gnu/usr.bin/perl/cpan/podlators/t/man/devise-title.t index a7e5e7b89d2..b2e82468b47 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/devise-title.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/devise-title.t @@ -3,14 +3,14 @@ # Tests for the automatic determination of the manual page title if not # specified via options to pod2man or the Pod::Man constructor. # -# Copyright 2015-2016, 2018 Russ Allbery <rra@cpan.org> +# Copyright 2015-2016, 2018-2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/empty.t b/gnu/usr.bin/perl/cpan/podlators/t/man/empty.t index 4924fc8466a..cd0cfccc37d 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/empty.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/empty.t @@ -2,14 +2,14 @@ # # Test Pod::Man with a document that produces only errors. # -# Copyright 2013, 2016, 2018 Russ Allbery <rra@cpan.org> +# Copyright 2013, 2016, 2018-2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/heading.t b/gnu/usr.bin/perl/cpan/podlators/t/man/heading.t index 9691446b6f6..f8964025e3f 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/heading.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/heading.t @@ -2,7 +2,7 @@ # # Additional tests for Pod::Man heading generation. # -# Copyright 2002, 2004, 2006, 2008-2009, 2012, 2015, 2018 +# Copyright 2002, 2004, 2006, 2008-2009, 2012, 2015, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it @@ -10,7 +10,7 @@ # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/no-encode.t b/gnu/usr.bin/perl/cpan/podlators/t/man/no-encode.t index 15522a5d96a..199016217d2 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/no-encode.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/no-encode.t @@ -3,22 +3,25 @@ # Test for graceful degradation to non-utf8 output without Encode module. # # Copyright 2016 Niko Tyni <ntyni@iki.fi> -# Copyright 2016, 2018 Russ Allbery <rra@cpan.org> +# Copyright 2016, 2018-2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; -use Test::More tests => 6; +use Test::More tests => 5; -# Force the Encode module to be impossible to import. +# Remove the record of the Encode module being loaded if it already was (it +# may have been loaded before the test suite runs), and then make it +# impossible to load it. This should be enough to trigger the fallback code +# in Pod::Man. BEGIN { - ok(!$INC{'Encode.pm'}, 'Encode is not loaded yet'); + delete $INC{'Encode.pm'}; my $reject_encode = sub { if ($_[1] eq 'Encode.pm') { die "refusing to load Encode\n"; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/utf8-io.t b/gnu/usr.bin/perl/cpan/podlators/t/man/utf8-io.t index d1c950076b3..76e21b98f04 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/utf8-io.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/utf8-io.t @@ -1,8 +1,8 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # # Test Pod::Man UTF-8 handling, with and without PerlIO. # -# Copyright 2002, 2004, 2006, 2008-2010, 2012, 2014-2015, 2018 +# Copyright 2002, 2004, 2006, 2008-2010, 2012, 2014-2015, 2018-2020 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it @@ -10,24 +10,15 @@ # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use Test::More; +use Test::More tests => 13; use Test::Podlators qw(test_snippet_with_io); -# UTF-8 support requires Perl 5.8 or later. -BEGIN { - if ($] < 5.008) { - plan skip_all => 'Perl 5.8 required for UTF-8 support'; - } else { - plan tests => 13; - } -} - # Load the module. BEGIN { use_ok('Pod::Man'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/parselink/basic.t b/gnu/usr.bin/perl/cpan/podlators/t/parselink/basic.t index 48fbb37f137..0f39e563976 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/parselink/basic.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/parselink/basic.t @@ -1,122 +1,120 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # -# parselink.t -- Tests for Pod::ParseLink. +# Tests for Pod::ParseLink. # -# Copyright 2001, 2009, 2018 by Russ Allbery <rra@cpan.org> +# Copyright 2001, 2009, 2018, 2020 by Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -# The format of each entry in this array is the L<> text followed by the -# five-element parse returned by parselink. -our @TESTS = ( - [ 'foo', - undef, 'foo', 'foo', undef, 'pod' ], - - [ 'foo|bar', - 'foo', 'foo', 'bar', undef, 'pod' ], - - [ 'foo/bar', - undef, '"bar" in foo', 'foo', 'bar', 'pod' ], - - [ 'foo/"baz boo"', - undef, '"baz boo" in foo', 'foo', 'baz boo', 'pod' ], - - [ '/bar', - undef, '"bar"', undef, 'bar', 'pod' ], - - [ '/"baz boo"', - undef, '"baz boo"', undef, 'baz boo', 'pod' ], - - [ '/baz boo', - undef, '"baz boo"', undef, 'baz boo', 'pod' ], - - [ 'foo bar/baz boo', - undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod' ], - - [ 'foo bar / baz boo', - undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod' ], - - [ "foo\nbar\nbaz\n/\nboo", - undef, '"boo" in foo bar baz', 'foo bar baz', 'boo', 'pod' ], - - [ 'anchor|name/section', - 'anchor', 'anchor', 'name', 'section', 'pod' ], - - [ '"boo var baz"', - undef, '"boo var baz"', undef, 'boo var baz', 'pod' ], - - [ 'bar baz', - undef, '"bar baz"', undef, 'bar baz', 'pod' ], - - [ '"boo bar baz / baz boo"', - undef, '"boo bar baz / baz boo"', undef, 'boo bar baz / baz boo', - 'pod' ], - - [ 'fooZ<>bar', - undef, 'fooZ<>bar', 'fooZ<>bar', undef, 'pod' ], - - [ 'Testing I<italics>|foo/bar', - 'Testing I<italics>', 'Testing I<italics>', 'foo', 'bar', 'pod' ], - - [ 'foo/I<Italic> text', - undef, '"I<Italic> text" in foo', 'foo', 'I<Italic> text', 'pod' ], - - [ 'fooE<verbar>barZ<>/Section C<with> I<B<other> markup', - undef, '"Section C<with> I<B<other> markup" in fooE<verbar>barZ<>', - 'fooE<verbar>barZ<>', 'Section C<with> I<B<other> markup', 'pod' ], - - [ 'Nested L<http://www.perl.org/>|fooE<sol>bar', - 'Nested L<http://www.perl.org/>', 'Nested L<http://www.perl.org/>', - 'fooE<sol>bar', undef, 'pod' ], - - [ 'ls(1)', - undef, 'ls(1)', 'ls(1)', undef, 'man' ], - - [ ' perlfunc(1)/open ', - undef, '"open" in perlfunc(1)', 'perlfunc(1)', 'open', 'man' ], - - [ 'some manual page|perl(1)', - 'some manual page', 'some manual page', 'perl(1)', undef, 'man' ], - - [ 'http://www.perl.org/', - undef, 'http://www.perl.org/', 'http://www.perl.org/', undef, 'url' ], - - [ 'news:yld72axzc8.fsf@windlord.stanford.edu', - undef, 'news:yld72axzc8.fsf@windlord.stanford.edu', - 'news:yld72axzc8.fsf@windlord.stanford.edu', undef, 'url' ], - - [ 'link|http://www.perl.org/', - 'link', 'link', 'http://www.perl.org/', undef, 'url' ], - - [ '0|http://www.perl.org/', - '0', '0', 'http://www.perl.org/', undef, 'url' ], +use 5.008; +use strict; +use warnings; - [ '0|Pod::Parser', - '0', '0', 'Pod::Parser', undef, 'pod' ], -); +use Test::More tests => 28; BEGIN { - chdir 't' if -d 't'; - unshift (@INC, '../blib/lib'); - $| = 1; + use_ok('Pod::ParseLink'); } -use strict; - -use Test::More tests => 28; -BEGIN { use_ok ('Pod::ParseLink') } - -# Used for reporting test failures. -my @names = qw(text inferred name section type); +# The format of each entry in this array is the L<> text followed by the +# five-element parse returned by parselink. +our @TESTS = ( + ['foo' => (undef, 'foo', 'foo', undef, 'pod')], + ['foo|bar' => ('foo', 'foo', 'bar', undef, 'pod')], + ['foo/bar' => (undef, '"bar" in foo', 'foo', 'bar', 'pod')], + ['foo/"baz boo"' => (undef, '"baz boo" in foo', 'foo', 'baz boo', 'pod')], + ['/bar' => (undef, '"bar"', undef, 'bar', 'pod')], + ['/"baz boo"' => (undef, '"baz boo"', undef, 'baz boo', 'pod')], + ['/baz boo', => (undef, '"baz boo"', undef, 'baz boo', 'pod')], + [ + 'foo bar/baz boo' => + (undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod') + ], + [ + 'foo bar / baz boo' => + (undef, '"baz boo" in foo bar', 'foo bar', 'baz boo', 'pod') + ], + [ + "foo\nbar\nbaz\n/\nboo" => + (undef, '"boo" in foo bar baz', 'foo bar baz', 'boo', 'pod') + ], + ['anchor|name/section' => qw(anchor anchor name section pod)], + ['"boo var baz"' => (undef, '"boo var baz"', undef, 'boo var baz', 'pod')], + ['bar baz' => (undef, '"bar baz"', undef, 'bar baz', 'pod')], + [ + '"boo bar baz / baz boo"' => ( + undef, '"boo bar baz / baz boo"', + undef, 'boo bar baz / baz boo', + 'pod', + ) + ], + ['fooZ<>bar' => (undef, 'fooZ<>bar', 'fooZ<>bar', undef, 'pod')], + [ + 'Testing I<italics>|foo/bar' => + ('Testing I<italics>', 'Testing I<italics>', 'foo', 'bar', 'pod') + ], + [ + 'foo/I<Italic> text' => + (undef, '"I<Italic> text" in foo', 'foo', 'I<Italic> text', 'pod') + ], + [ + 'fooE<verbar>barZ<>/Section C<with> I<B<other> markup' => ( + undef, + '"Section C<with> I<B<other> markup" in fooE<verbar>barZ<>', + 'fooE<verbar>barZ<>', + 'Section C<with> I<B<other> markup', + 'pod', + ) + ], + [ + 'Nested L<http://www.perl.org/>|fooE<sol>bar' => ( + 'Nested L<http://www.perl.org/>', + 'Nested L<http://www.perl.org/>', + 'fooE<sol>bar', undef, 'pod', + ) + ], + ['ls(1)' => (undef, 'ls(1)', 'ls(1)', undef, 'man')], + [ + ' perlfunc(1)/open ' => + (undef, '"open" in perlfunc(1)', 'perlfunc(1)', 'open', 'man') + ], + [ + 'some manual page|perl(1)' => + ('some manual page', 'some manual page', 'perl(1)', undef, 'man') + ], + [ + 'http://www.perl.org/' => ( + undef, 'http://www.perl.org/', 'http://www.perl.org/', undef, + 'url', + ) + ], + [ + 'news:yld72axzc8.fsf@windlord.stanford.edu' => ( + undef, + 'news:yld72axzc8.fsf@windlord.stanford.edu', + 'news:yld72axzc8.fsf@windlord.stanford.edu', + undef, 'url', + ) + ], + [ + 'link|http://www.perl.org/' => + ('link', 'link', 'http://www.perl.org/', undef, 'url') + ], + [ + '0|http://www.perl.org/' => + ('0', '0', 'http://www.perl.org/', undef, 'url') + ], + ['0|Pod::Parser' => ('0', '0', 'Pod::Parser', undef, 'pod')], +); -for (@TESTS) { - my @expected = @$_; - my $link = shift @expected; - my @results = parselink ($link); - my $pretty = $link; - $pretty =~ s/\n/\\n/g; - is_deeply (\@results, \@expected, $pretty); +# Run all of the tests. +for my $test (@TESTS) { + my ($link, @expected) = @$test; + my @results = parselink($link); + my $pretty = $link; + $pretty =~ s{\n}{\\n}xmsg; + is_deeply(\@results, \@expected, $pretty); } diff --git a/gnu/usr.bin/perl/cpan/podlators/t/style/minimum-version.t b/gnu/usr.bin/perl/cpan/podlators/t/style/minimum-version.t index 7698c2babf1..861367de4ae 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/style/minimum-version.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/style/minimum-version.t @@ -6,6 +6,7 @@ # which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. # # Written by Russ Allbery <eagle@eyrie.org> +# Copyright 2019 Russ Allbery <eagle@eyrie.org> # Copyright 2013-2014 # The Board of Trustees of the Leland Stanford Junior University # @@ -29,16 +30,17 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use Test::More; use Test::RRA qw(skip_unless_automated use_prereq); use Test::RRA::Config qw($MINIMUM_VERSION); +use Test::More; + # Skip for normal user installs since this doesn't affect functionality. skip_unless_automated('Minimum version tests'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/style/module-version.t b/gnu/usr.bin/perl/cpan/podlators/t/style/module-version.t index 80368cb02e1..035b596de51 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/style/module-version.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/style/module-version.t @@ -11,16 +11,17 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use Getopt::Long qw(GetOptions); use Test::RRA qw(skip_unless_automated use_prereq); use Test::RRA::ModuleVersion qw(test_module_versions update_module_versions); +use Getopt::Long qw(GetOptions); + # If we have options, we're being run from the command line and always load # our prerequisite modules. Otherwise, check if we have necessary # prerequisites and should run as a test suite. @@ -120,7 +121,7 @@ Russ Allbery <eagle@eyrie.org> =head1 COPYRIGHT AND LICENSE -Copyright 2014-2016 Russ Allbery <eagle@eyrie.org> +Copyright 2014-2016, 2019 Russ Allbery <eagle@eyrie.org> Copyright 2013-2014 The Board of Trustees of the Leland Stanford Junior University diff --git a/gnu/usr.bin/perl/cpan/podlators/t/style/strict.t b/gnu/usr.bin/perl/cpan/podlators/t/style/strict.t index a3d2a3e942c..a87c1fabca1 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/style/strict.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/style/strict.t @@ -6,7 +6,7 @@ # which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. # # Written by Russ Allbery <eagle@eyrie.org> -# Copyright 2016 Russ Allbery <eagle@eyrie.org> +# Copyright 2016, 2018-2019 Russ Allbery <eagle@eyrie.org> # Copyright 2013-2014 # The Board of Trustees of the Leland Stanford Junior University # @@ -30,15 +30,16 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use File::Spec; use Test::RRA qw(skip_unless_automated use_prereq); +use File::Spec; + # Skip for normal user installs since this doesn't affect functionality. skip_unless_automated('Strictness tests'); @@ -46,15 +47,40 @@ skip_unless_automated('Strictness tests'); # use 5.012 or later automatically implies use strict. use_prereq('Test::Strict', '0.25'); -# Test everything in the distribution directory except the Build and -# Makefile.PL scripts generated by Module::Build. We also want to check use -# warnings. -$Test::Strict::TEST_SKIP = ['Build', 'Makefile.PL']; +# Directories to exclude from checks. +my %EXCLUDE = map { $_ => 1 } qw(.git blib); + +# Determine whether we want to check the given file or top-level directory. +# Assume that the only interesting files at the top level are directories or +# files ending in *.PL. +# +# $file - Name of the file or directory +# +# Returns: 1 if it should be checked, undef otherwise. +sub should_check { + my ($file) = @_; + return if $EXCLUDE{$file}; + return 1 if -d $file; + return 1 if $file =~ m{ [.] PL \z }xms; + return; +} + +# Test::Strict (as of 0.47) doesn't have a way of excluding whole directories +# from all_perl_files_ok and doesn't exclude .git, which results in false +# positives if there are Perl files unpacked under .git (which is often the +# case when using dgit). We therefore can't just point it at the root of the +# module distribution and instead have to manually construct a list of +# interesting files. +opendir(my $rootdir, File::Spec->curdir) + or die "$0: cannot open current directory: $!\n"; +my @files = File::Spec->no_upwards(readdir($rootdir)); +closedir($rootdir) or die "$0: cannot close current directory: $!\n"; +my @to_check = grep { should_check($_) } @files; + +# Test the files and top-level directories we found, including checking for +# use warnings. $Test::Strict::TEST_WARNINGS = 1; -all_perl_files_ok(File::Spec->curdir); +all_perl_files_ok(@to_check); # Hack to suppress "used only once" warnings. -END { - $Test::Strict::TEST_SKIP = []; - $Test::Strict::TEST_WARNINGS = 0; -} +END { $Test::Strict::TEST_WARNINGS = 0 } diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/basic.t b/gnu/usr.bin/perl/cpan/podlators/t/text/basic.t deleted file mode 100644 index 024cc0e0e7f..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/basic.t +++ /dev/null @@ -1,157 +0,0 @@ -#!/usr/bin/perl -w -# -# Additional specialized tests for Pod::Text. -# -# Copyright 2002, 2004, 2006-2009, 2012, 2018 -# Russ Allbery <rra@cpan.org> -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - -use strict; - -use Pod::Simple; -use Test::More tests => 9; -BEGIN { use_ok ('Pod::Text') } - -my $parser = Pod::Text->new; -isa_ok ($parser, 'Pod::Text', 'Parser object'); -my $n = 1; -while (<DATA>) { - next until $_ eq "###\n"; - open (TMP, "> tmp$$.pod") or die "Cannot create tmp$$.pod: $!\n"; - while (<DATA>) { - last if $_ eq "###\n"; - print TMP $_; - } - close TMP; - open (OUT, "> out$$.tmp") or die "Cannot create out$$.tmp: $!\n"; - $parser->parse_from_file ("tmp$$.pod", \*OUT); - close OUT; - open (TMP, "out$$.tmp") or die "Cannot open out$$.tmp: $!\n"; - my $output; - { - local $/; - $output = <TMP>; - } - close TMP; - 1 while unlink ("tmp$$.pod", "out$$.tmp"); - my $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($output, $expected, "Output correct for test $n"); - $n++; -} - -# Below the marker are bits of POD and corresponding expected text output. -# This is used to test specific features or problems with Pod::Text. The -# input and output are separated by lines containing only ###. - -__DATA__ - -### -=head1 PERIODS - -This C<.> should be quoted. -### -PERIODS - This "." should be quoted. - -### - -### -=head1 CE<lt>E<gt> WITH SPACES - -What does C<< this. >> end up looking like? -### -C<> WITH SPACES - What does "this." end up looking like? - -### - -### -=head1 Test of SE<lt>E<gt> - -This is some S< > whitespace. -### -Test of S<> - This is some whitespace. - -### - -### -=head1 Test of =for - -=for comment -This won't be seen. - -Yes. - -=for text -This should be seen. - -=for TEXT As should this. - -=for man -But this shouldn't. - -Some more text. -### -Test of =for - Yes. - -This should be seen. -As should this. - Some more text. - -### - -### -=pod - -text - - line1 - - line3 -### - text - - line1 - - line3 - -### - -### -=head1 LINK TO URL - -This is a L<link|http://www.example.com/> to a URL. -### -LINK TO URL - This is a link <http://www.example.com/> to a URL. - -### - -### -=head1 RT LINK - -L<[perl #12345]|https://rt.cpan.org/12345> -### -RT LINK - [perl #12345] <https://rt.cpan.org/12345> - -### diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/color.t b/gnu/usr.bin/perl/cpan/podlators/t/text/color.t index b7edd48a27b..aa75beeb057 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/color.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/color.t @@ -2,13 +2,13 @@ # # Test Pod::Text::Color behavior with various snippets. # -# Copyright 2002, 2004, 2006, 2009, 2012-2013, 2018 +# Copyright 2002, 2004, 2006, 2009, 2012-2013, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/empty.t b/gnu/usr.bin/perl/cpan/podlators/t/text/empty.t deleted file mode 100644 index e03a03c4a38..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/empty.t +++ /dev/null @@ -1,54 +0,0 @@ -#!/usr/bin/perl -w -# -# Test Pod::Text with a document that produces only errors. -# -# Copyright 2013, 2018 Russ Allbery <rra@cpan.org> -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - -use strict; - -use Test::More tests => 8; -BEGIN { use_ok ('Pod::Text') } - -# Set up Pod::Text to output to a string. -my $parser = Pod::Text->new; -isa_ok ($parser, 'Pod::Text'); -my $output; -$parser->output_string (\$output); - -# Try a POD document where the only command is invalid. Be sure that we don't -# get any warnings as well as any errors. -local $SIG{__WARN__} = sub { die $_[0] }; -ok (eval { $parser->parse_string_document("=\xa0") }, - 'Parsed invalid document'); -is ($@, '', '...with no errors'); -SKIP: { - skip 'Pod::Simple does not produce errors for invalid commands', 1 - if $output eq q{}; - like ($output, qr{POD ERRORS}, - '...and output contains a POD ERRORS section'); -} - -# Try with a document containing only =cut. -ok (eval { $parser->parse_string_document("=cut") }, - 'Parsed invalid document'); -is ($@, '', '...with no errors'); -SKIP: { - skip 'Pod::Simple does not produce errors for invalid commands', 1 - if $output eq q{}; - like ($output, qr{POD ERRORS}, - '...and output contains a POD ERRORS section'); -} diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/encoding.t b/gnu/usr.bin/perl/cpan/podlators/t/text/encoding.t deleted file mode 100644 index 7a6b6f2801b..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/encoding.t +++ /dev/null @@ -1,158 +0,0 @@ -#!/usr/bin/perl -w -# -# Test Pod::Text with various weird encoding combinations. -# -# Copyright 2002, 2004, 2006-2009, 2012, 2015, 2018 -# Russ Allbery <rra@cpan.org> -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - -use strict; - -use Test::More; - -# UTF-8 support requires Perl 5.8 or later. -BEGIN { - if ($] < 5.008) { - plan skip_all => 'Perl 5.8 required for encoding support'; - } else { - plan tests => 7; - } -} -BEGIN { use_ok ('Pod::Text') } - -eval { binmode (\*DATA, ':raw') }; -eval { binmode (\*STDOUT, ':raw') }; -my $builder = Test::More->builder; -eval { binmode ($builder->output, ':raw') }; -eval { binmode ($builder->failure_output, ':raw') }; - -my $n = 1; -while (<DATA>) { - my %opts; - next until $_ eq "###\n"; - my $parser = Pod::Text->new (%opts); - isa_ok ($parser, 'Pod::Text', 'Parser object'); - open (TMP, "> tmp$$.pod") or die "Cannot create tmp$$.pod: $!\n"; - eval { binmode (\*TMP, ':raw') }; - while (<DATA>) { - last if $_ eq "###\n"; - print TMP $_; - } - close TMP; - open (OUT, "> out$$.tmp") or die "Cannot create out$$.tmp: $!\n"; - eval { binmode (\*OUT, ':raw') }; - $parser->parse_from_file ("tmp$$.pod", \*OUT); - close OUT; - open (TMP, "out$$.tmp") or die "Cannot open out$$.tmp: $!\n"; - eval { binmode (\*TMP, ':raw') }; - my $output; - { - local $/; - $output = <TMP>; - } - close TMP; - 1 while unlink ("tmp$$.pod", "out$$.tmp"); - my $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($output, $expected, "Output correct for test $n"); - $n++; -} - -# Below the marker are bits of POD and corresponding expected text output. -# This is used to test specific features or problems with Pod::Text. The -# input and output are separated by lines containing only ###. - -__DATA__ - -### -=head1 Test of SE<lt>E<gt> - -This is S<some whitespace>. -### -Test of S<> - This is some whitespace. - -### - -### -=encoding utf-8 - -=head1 I can eat glass - -=over 4 - -=item Esperanto - -Mi povas manÄi vitron, Äi ne damaÄas min. - -=item Braille - -â â â â â â â â â â â â â â â â â â â â â â â â â â â â â â â â ¥â â â â â - -=item Hindi - -मà¥à¤ à¤à¤¾à¤à¤ à¤à¤¾ सà¤à¤¤à¤¾ हà¥à¤ à¤à¤° मà¥à¤à¥ à¤à¤¸à¤¸à¥ à¤à¥à¤ à¤à¥à¤ नहà¥à¤ पहà¥à¤à¤à¤¤à¥. - -=back - -See L<http://www.columbia.edu/kermit/utf8.html> -### -I can eat glass - Esperanto - Mi povas manÄi vitron, Äi ne damaÄas min. - - Braille - â â â â â â â â â â â â â â â â â â â â â â â - â â â â â â â â â ¥â â â â â - - Hindi - मà¥à¤ à¤à¤¾à¤à¤ à¤à¤¾ सà¤à¤¤à¤¾ हà¥à¤ à¤à¤° - मà¥à¤à¥ à¤à¤¸à¤¸à¥ à¤à¥à¤ à¤à¥à¤ नहà¥à¤ - पहà¥à¤à¤à¤¤à¥. - - See <http://www.columbia.edu/kermit/utf8.html> - -### - -### -=pod - -=head1 NAME - -This is the first ascii text - -=encoding utf8 - -=over 4 - -=item ⇒This is the first non-ascii text⇐ - -This is the second ascii text - -=back - -=cut -### -NAME - This is the first ascii text - - ⇒This is the first non-ascii text⇐ - This is the second ascii text - -### diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/options.t b/gnu/usr.bin/perl/cpan/podlators/t/text/options.t deleted file mode 100644 index d191cf00f97..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/options.t +++ /dev/null @@ -1,368 +0,0 @@ -#!/usr/bin/perl -w -# -# Additional tests for Pod::Text options. -# -# Copyright 2002, 2004, 2006, 2008-2009, 2012-2013, 2015, 2018 -# Russ Allbery <rra@cpan.org> -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - -use strict; - -use Test::More tests => 37; -BEGIN { use_ok ('Pod::Text') } - -# Redirect stderr to a file. -sub stderr_save { - open (OLDERR, '>&STDERR') or die "Can't dup STDERR: $!\n"; - open (STDERR, "> out$$.err") or die "Can't redirect STDERR: $!\n"; -} - -# Restore stderr. -sub stderr_restore { - close STDERR; - open (STDERR, '>&OLDERR') or die "Can't dup STDERR: $!\n"; - close OLDERR; -} - -my $n = 1; -while (<DATA>) { - my %options; - next until $_ eq "###\n"; - while (<DATA>) { - last if $_ eq "###\n"; - my ($option, $value) = split; - $options{$option} = $value; - } - open (TMP, "> tmp$$.pod") or die "Cannot create tmp$$.pod: $!\n"; - while (<DATA>) { - last if $_ eq "###\n"; - print TMP $_; - } - close TMP; - my $parser = Pod::Text->new (%options); - isa_ok ($parser, 'Pod::Text', 'Parser object'); - open (OUT, "> out$$.tmp") or die "Cannot create out$$.tmp: $!\n"; - stderr_save; - eval { $parser->parse_from_file ("tmp$$.pod", \*OUT) }; - my $exception = $@; - stderr_restore; - close OUT; - open (TMP, "out$$.tmp") or die "Cannot open out$$.tmp: $!\n"; - my $output; - { - local $/; - $output = <TMP>; - } - close TMP; - 1 while unlink ("tmp$$.pod", "out$$.tmp"); - my $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($output, $expected, "Output correct for test $n"); - open (ERR, "out$$.err") or die "Cannot open out$$.err: $!\n"; - my $errors; - { - local $/; - $errors = <ERR>; - } - close ERR; - $errors =~ s/\Qtmp$$.pod/tmp.pod/g; - 1 while unlink ("out$$.err"); - if ($exception) { - $exception =~ s/ at .*//; - $errors .= "EXCEPTION: $exception"; - } - $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($errors, $expected, "Errors correct for test $n"); - $n++; -} - -# Below the marker are bits of POD and corresponding expected text output. -# This is used to test specific features or problems with Pod::Text. The -# options, input, output, and errors are separated by lines containing only -# ###. - -__DATA__ - -### -alt 1 -### -=head1 SAMPLE - -=over 4 - -=item F - -Paragraph. - -=item Bar - -=item B - -Paragraph. - -=item Longer - -Paragraph. - -=back - -### - -==== SAMPLE ==== - -: F Paragraph. - -: Bar -: B Paragraph. - -: Longer - Paragraph. - -### -### - -### -margin 4 -### -=head1 SAMPLE - -This is some body text that is long enough to be a paragraph that wraps, -thereby testing margins with wrapped paragraphs. - - This is some verbatim text. - -=over 6 - -=item Test - -This is a test of an indented paragraph. - -This is another indented paragraph. - -=back -### - SAMPLE - This is some body text that is long enough to be a paragraph that - wraps, thereby testing margins with wrapped paragraphs. - - This is some verbatim text. - - Test This is a test of an indented paragraph. - - This is another indented paragraph. - -### -### - -### -code 1 -### -This is some random text. -This is more random text. - -This is some random text. -This is more random text. - -=head1 SAMPLE - -This is POD. - -=cut - -This is more random text. -### -This is some random text. -This is more random text. - -This is some random text. -This is more random text. - -SAMPLE - This is POD. - - -This is more random text. -### -### - -### -sentence 1 -### -=head1 EXAMPLE - -Whitespace around C<< this. >> must be ignored per perlpodspec. >> -needs to eat all of the space in front of it. - -=cut -### -EXAMPLE - Whitespace around "this." must be ignored per perlpodspec. >> needs to - eat all of the space in front of it. - -### -### - -### -### -=over 4 - -=item Foo - -Bar. - -=head1 NEXT -### - Foo Bar. - -NEXT -POD ERRORS - Hey! The above document had some coding errors, which are explained - below: - - Around line 7: - You forgot a '=back' before '=head1' - -### -### - -### -stderr 1 -### -=over 4 - -=item Foo - -Bar. - -=head1 NEXT -### - Foo Bar. - -NEXT -### -tmp.pod around line 7: You forgot a '=back' before '=head1' -### - -### -nourls 1 -### -=head1 URL suppression - -L<anchor|http://www.example.com/> -### -URL suppression - anchor - -### -### - -### -errors stderr -### -=over 4 - -=item Foo - -Bar. - -=head1 NEXT -### - Foo Bar. - -NEXT -### -tmp.pod around line 7: You forgot a '=back' before '=head1' -### - -### -errors die -### -=over 4 - -=item Foo - -Bar. - -=head1 NEXT -### - Foo Bar. - -NEXT -### -tmp.pod around line 7: You forgot a '=back' before '=head1' -EXCEPTION: POD document had syntax errors -### - -### -errors pod -### -=over 4 - -=item Foo - -Bar. - -=head1 NEXT -### - Foo Bar. - -NEXT -POD ERRORS - Hey! The above document had some coding errors, which are explained - below: - - Around line 7: - You forgot a '=back' before '=head1' - -### -### - -### -errors none -### -=over 4 - -=item Foo - -Bar. - -=head1 NEXT -### - Foo Bar. - -NEXT -### -### - -### -quotes <<<>>> -### -=head1 FOO C<BAR> BAZ - -Foo C<bar> baz. -### -FOO <<<BAR>>> BAZ - Foo <<<bar>>> baz. - -### -### diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/overstrike.t b/gnu/usr.bin/perl/cpan/podlators/t/text/overstrike.t index 7433264cb3c..7cdaa538b2d 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/overstrike.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/overstrike.t @@ -1,8 +1,8 @@ -#!/usr/bin/perl -w +#!/usr/bin/perl # -# Additional specialized tests for Pod::Text::Overstrike. +# Test Pod::Text::Overstrike with various snippets. # -# Copyright 2002, 2004, 2006, 2009, 2012-2013, 2018 +# Copyright 2002, 2004, 2006, 2009, 2012-2013, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it @@ -10,97 +10,23 @@ # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - +use 5.008; use strict; +use warnings; -use Test::More tests => 4; -BEGIN { use_ok ('Pod::Text::Overstrike') } - -my $parser = Pod::Text::Overstrike->new; -isa_ok ($parser, 'Pod::Text::Overstrike', 'Parser module'); -my $n = 1; -while (<DATA>) { - next until $_ eq "###\n"; - open (TMP, "> tmp$$.pod") or die "Cannot create tmp$$.pod: $!\n"; - while (<DATA>) { - last if $_ eq "###\n"; - print TMP $_; - } - close TMP; - open (OUT, "> out$$.tmp") or die "Cannot create out$$.tmp: $!\n"; - $parser->parse_from_file ("tmp$$.pod", \*OUT); - close OUT; - open (TMP, "out$$.tmp") or die "Cannot open out$$.tmp: $!\n"; - my $output; - { - local $/; - $output = <TMP>; - } - close TMP; - 1 while unlink ("tmp$$.pod", "out$$.tmp"); - my $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($output, $expected, "Output correct for test $n"); - $n++; -} - -# Below the marker are bits of POD and corresponding expected output. This is -# used to test specific features or problems with Pod::Text::Termcap. The -# input and output are separated by lines containing only ###. - -__DATA__ - -### -=head1 WRAPPING - -B<I<Do>> I<B<not>> B<I<include>> B<I<formatting codes when>> B<I<wrapping>>. -### -WWRRAAPPPPIINNGG - DDoo _n_o_t iinncclluuddee ffoorrmmaattttiinngg ccooddeess wwhheenn wwrraappppiinngg. - -### - -### -=head1 TAG WIDTH - -=over 10 +use lib 't/lib'; -=item 12345678 +use Test::More tests => 5; +use Test::Podlators qw(test_snippet); -A - -=item B<12345678> - -B - -=item 1Z<> - -C - -=item B<1> - -D - -=back -### -TTAAGG WWIIDDTTHH - 12345678 A - - 1122334455667788 B - - 1 C +BEGIN { + use_ok('Pod::Text::Overstrike'); +} - 11 D +# List of snippets run by this test. +my @snippets = qw(tag-width wrapping); -### +# Run all the tests. +for my $snippet (@snippets) { + test_snippet('Pod::Text::Overstrike', "overstrike/$snippet"); +} diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/perlio.t b/gnu/usr.bin/perl/cpan/podlators/t/text/perlio.t deleted file mode 100644 index 1b6523d328a..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/perlio.t +++ /dev/null @@ -1,129 +0,0 @@ -#!/usr/bin/perl -w -# -# Test Pod::Text with a PerlIO UTF-8 encoding layer. -# -# Copyright 2002, 2004, 2006-2010, 2012, 2014, 2018 -# Russ Allbery <rra@cpan.org> -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - -use strict; - -use Test::More; - -# UTF-8 support requires Perl 5.8 or later. -BEGIN { - if ($] < 5.008) { - plan skip_all => 'Perl 5.8 required for UTF-8 support'; - } else { - plan tests => 4; - } -} -BEGIN { use_ok ('Pod::Text') } - -# Force UTF-8 on all relevant file handles. Hide this in a string eval so -# that older versions of Perl don't croak and minimum-version tests still -# pass. -eval 'binmode (\*DATA, ":encoding(utf-8)")'; -eval 'binmode (\*STDOUT, ":encoding(utf-8)")'; -my $builder = Test::More->builder; -eval 'binmode ($builder->output, ":encoding(utf-8)")'; -eval 'binmode ($builder->failure_output, ":encoding(utf-8)")'; - -my $parser = Pod::Text->new (utf8 => 1); -isa_ok ($parser, 'Pod::Text', 'Parser object'); -my $n = 1; -while (<DATA>) { - next until $_ eq "###\n"; - open (TMP, "> tmp$$.pod") or die "Cannot create tmp$$.pod: $!\n"; - eval 'binmode (\*TMP, ":encoding(utf-8)")'; - print TMP "=encoding UTF-8\n\n"; - while (<DATA>) { - last if $_ eq "###\n"; - print TMP $_; - } - close TMP; - open (OUT, "> out$$.tmp") or die "Cannot create out$$.tmp: $!\n"; - eval 'binmode (\*OUT, ":encoding(utf-8)")'; - $parser->parse_from_file ("tmp$$.pod", \*OUT); - close OUT; - open (TMP, "out$$.tmp") or die "Cannot open out$$.tmp: $!\n"; - eval 'binmode (\*TMP, ":encoding(utf-8)")'; - my $output; - { - local $/; - $output = <TMP>; - } - close TMP; - 1 while unlink ("tmp$$.pod", "out$$.tmp"); - my $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($output, $expected, "Output correct for test $n"); - $n++; -} - -# Below the marker are bits of POD and corresponding expected text output. -# This is used to test specific features or problems with Pod::Text. The -# input and output are separated by lines containing only ###. - -__DATA__ - -### -=head1 Test of SE<lt>E<gt> - -This is S<some whitespace>. -### -Test of S<> - This is some whitespace. - -### - -### -=head1 I can eat glass - -=over 4 - -=item Esperanto - -Mi povas manĝi vitron, ĝi ne damaĝas min. - -=item Braille - -⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑ - -=item Hindi - -मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती. - -=back - -See L<http://www.columbia.edu/kermit/utf8.html> -### -I can eat glass - Esperanto - Mi povas manĝi vitron, ĝi ne damaĝas min. - - Braille - ⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑ - - Hindi - मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती. - - See <http://www.columbia.edu/kermit/utf8.html> - -### diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/termcap.t b/gnu/usr.bin/perl/cpan/podlators/t/text/termcap.t index 4a9893a9daa..598e0b56203 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/termcap.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/termcap.t @@ -2,19 +2,21 @@ # # Test Pod::Text::Termcap behavior with various snippets. # -# Copyright 2002, 2004, 2006, 2009, 2012-2014, 2018 +# Copyright 2002, 2004, 2006, 2009, 2012-2014, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; -use Test::More tests => 11; +use Test::More tests => 15; use Test::Podlators qw(test_snippet); # Load the module. @@ -28,6 +30,10 @@ $ENV{TERM} = 'xterm'; $ENV{TERMPATH} = File::Spec->catfile('t', 'data', 'termcap'); $ENV{TERMCAP} = 'xterm:co=#80:do=^J:md=\E[1m:us=\E[4m:me=\E[m'; +# Check the regex that matches a single formatting character. +my $parser = Pod::Text::Termcap->new(); +is($parser->format_regex(), "\\\e\\[1m|\\\e\\[4m|\\\e\\[m", 'Character regex'); + # List of snippets run by this test. my @snippets = qw(escape-wrapping tag-width tag-wrapping width wrapping); @@ -35,3 +41,15 @@ my @snippets = qw(escape-wrapping tag-width tag-wrapping width wrapping); for my $snippet (@snippets) { test_snippet('Pod::Text::Termcap', "termcap/$snippet"); } + +# Now test with an unknown terminal type. +$ENV{TERM} = 'unknown'; +$ENV{TERMCAP} = 'unknown:co=#80:do=^J'; +test_snippet('Pod::Text::Termcap', 'termcap/term-unknown'); + +# Test the character regex with a fake terminal type that only provides bold +# and normal, not underline. +$ENV{TERM} = 'fake-test-terminal'; +$ENV{TERMCAP} = 'fake-test-terminal:md=\E[1m:me=\E[m'; +$parser = Pod::Text::Termcap->new(); +is($parser->format_regex(), "\\\e\\[1m|\\\e\\[m", 'Limited character regex'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/utf8.t b/gnu/usr.bin/perl/cpan/podlators/t/text/utf8.t deleted file mode 100644 index a04010ea101..00000000000 --- a/gnu/usr.bin/perl/cpan/podlators/t/text/utf8.t +++ /dev/null @@ -1,128 +0,0 @@ -#!/usr/bin/perl -w -# -# Test Pod::Text with UTF-8 input. -# -# Copyright 2002, 2004, 2006-2009, 2012, 2014, 2018 -# Russ Allbery <rra@cpan.org> -# -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. -# -# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl - -BEGIN { - chdir 't' if -d 't'; - if ($ENV{PERL_CORE}) { - @INC = '../lib'; - } - unshift (@INC, '../blib/lib'); - $| = 1; -} - -use strict; - -use Test::More; - -# UTF-8 support requires Perl 5.8 or later. -BEGIN { - if ($] < 5.008) { - plan skip_all => 'Perl 5.8 required for UTF-8 support'; - } else { - plan tests => 4; - } -} -BEGIN { use_ok ('Pod::Text') } - -# Force UTF-8 on all relevant file handles. Hide this in a string eval so -# that older versions of Perl don't croak and minimum-version tests still -# pass. -eval 'binmode (\*DATA, ":encoding(utf-8)")'; -eval 'binmode (\*STDOUT, ":encoding(utf-8)")'; -my $builder = Test::More->builder; -eval 'binmode ($builder->output, ":encoding(utf-8)")'; -eval 'binmode ($builder->failure_output, ":encoding(utf-8)")'; - -my $parser = Pod::Text->new; -isa_ok ($parser, 'Pod::Text', 'Parser object'); -my $n = 1; -while (<DATA>) { - next until $_ eq "###\n"; - open (TMP, "> tmp$$.pod") or die "Cannot create tmp$$.pod: $!\n"; - eval 'binmode (\*TMP, ":encoding(utf-8)")'; - print TMP "=encoding UTF-8\n\n"; - while (<DATA>) { - last if $_ eq "###\n"; - print TMP $_; - } - close TMP; - open (OUT, "> out$$.tmp") or die "Cannot create out$$.tmp: $!\n"; - $parser->parse_from_file ("tmp$$.pod", \*OUT); - close OUT; - open (TMP, "out$$.tmp") or die "Cannot open out$$.tmp: $!\n"; - eval 'binmode (\*TMP, ":encoding(utf-8)")'; - my $output; - { - local $/; - $output = <TMP>; - } - close TMP; - 1 while unlink ("tmp$$.pod", "out$$.tmp"); - my $expected = ''; - while (<DATA>) { - last if $_ eq "###\n"; - $expected .= $_; - } - is ($output, $expected, "Output correct for test $n"); - $n++; -} - -# Below the marker are bits of POD and corresponding expected text output. -# This is used to test specific features or problems with Pod::Text. The -# input and output are separated by lines containing only ###. - -__DATA__ - -### -=head1 Test of SE<lt>E<gt> - -This is S<some whitespace>. -### -Test of S<> - This is some whitespace. - -### - -### -=head1 I can eat glass - -=over 4 - -=item Esperanto - -Mi povas manĝi vitron, ĝi ne damaĝas min. - -=item Braille - -⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑ - -=item Hindi - -मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती. - -=back - -See L<http://www.columbia.edu/kermit/utf8.html> -### -I can eat glass - Esperanto - Mi povas manĝi vitron, ĝi ne damaĝas min. - - Braille - ⠊⠀⠉⠁⠝⠀⠑⠁⠞⠀⠛⠇⠁⠎⠎⠀⠁⠝⠙⠀⠊⠞⠀⠙⠕⠑⠎⠝⠞⠀⠓⠥⠗⠞⠀⠍⠑ - - Hindi - मैं काँच खा सकता हूँ और मुझे उससे कोई चोट नहीं पहुंचती. - - See <http://www.columbia.edu/kermit/utf8.html> - -### |