From: afresh1 Date: Tue, 14 May 2024 19:36:00 +0000 (+0000) Subject: Import perl-5.38.2 X-Git-Url: http://artulab.com/gitweb/?a=commitdiff_plain;h=f2a19305cfc49ea4d1a5feb55cd6c283c6f1e031;p=openbsd Import perl-5.38.2 ok gkoehler@ Commit and we'll fix fallout bluhm@ Right away, please deraadt@ --- diff --git a/gnu/usr.bin/perl/Cross/README.new b/gnu/usr.bin/perl/Cross/README.new index b5200013039..aa5689bb1b7 100644 --- a/gnu/usr.bin/perl/Cross/README.new +++ b/gnu/usr.bin/perl/Cross/README.new @@ -1,3 +1,5 @@ +# vim: syntax=pod + You're reading ./Cross/README.new, describing Perl cross-compilation process. NOTE: this file will replace ./Cross/README, after the cross-compilation scheme is stabilized. diff --git a/gnu/usr.bin/perl/PACKAGING b/gnu/usr.bin/perl/PACKAGING index a603f6c5e36..46f1833c7a2 100644 --- a/gnu/usr.bin/perl/PACKAGING +++ b/gnu/usr.bin/perl/PACKAGING @@ -1,3 +1,5 @@ +# vim: syntax=pod + If you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specifically designed to be readable as is. diff --git a/gnu/usr.bin/perl/Porting/acknowledgements.pl b/gnu/usr.bin/perl/Porting/acknowledgements.pl index c0c70860118..e2bd107807c 100644 --- a/gnu/usr.bin/perl/Porting/acknowledgements.pl +++ b/gnu/usr.bin/perl/Porting/acknowledgements.pl @@ -163,5 +163,5 @@ sub commify { # returns a list of the authors sub authors { return - qx(git log --pretty=fuller $since_until | $^X Porting/checkAUTHORS.pl --who -); + qx($^X Porting/updateAUTHORS.pl --who $since_until); } diff --git a/gnu/usr.bin/perl/Porting/config_h.pl b/gnu/usr.bin/perl/Porting/config_h.pl index 935834990d6..7c828cf70c7 100755 --- a/gnu/usr.bin/perl/Porting/config_h.pl +++ b/gnu/usr.bin/perl/Porting/config_h.pl @@ -78,6 +78,8 @@ unless ($ch[0] =~ m/THIS IS A GENERATED FILE/) { push @ch, ";;\nesac\n"; } +s/^(\s*)#(\s*)define\t\s*/${1}#${2}define /gm for @ch; + open $ch, ">", $cSH or die "Cannot write $cSH: $!\n"; print $ch @ch; close $ch; diff --git a/gnu/usr.bin/perl/Porting/core-team.json b/gnu/usr.bin/perl/Porting/core-team.json index 56f443b37c2..c97189aa9c6 100644 --- a/gnu/usr.bin/perl/Porting/core-team.json +++ b/gnu/usr.bin/perl/Porting/core-team.json @@ -3,7 +3,9 @@ "ams@toroid.org", "doughera@lafayette.edu", "jan@jandubois.com", - "jesse@fsck.com" + "jesse@fsck.com", + "jmac@jmac.org", + "xdg@xdg.me" ], "active": [ "book@cpan.org", @@ -11,13 +13,14 @@ "cpan@corion.net", "craigberry@mac.com", "davem@iabyn.com", + "demerphq@gmail.com", "ether@cpan.org", "exodist7@gmail.com", "fawaka@gmail.com", "hv@crypt.org", "ilmari@ilmari.org", "jkeenan@cpan.org", - "jmac@jmac.org", + "haarg@haarg.org", "khw@cpan.org", "leonerd@leonerd.org.uk", "neilb@neilb.org", @@ -29,7 +32,6 @@ "stuart@perlfoundation.org", "toddr@cpanel.net", "tony@develop-help.com", - "wolfsage@gmail.com", - "xdg@xdg.me" + "wolfsage@gmail.com" ] } diff --git a/gnu/usr.bin/perl/Porting/exclude_contrib.txt b/gnu/usr.bin/perl/Porting/exclude_contrib.txt new file mode 100644 index 00000000000..24b39f611e3 --- /dev/null +++ b/gnu/usr.bin/perl/Porting/exclude_contrib.txt @@ -0,0 +1,23 @@ +########################################################################## +# This file is managed by `Porting/updateAUTHORS.pl` +# +# It contains the base 64 SHA-256 of the name and email details of the +# contributors who have requested that their gracious contributions go +# unnoted in our AUTHORS file, and who choose not to be listed in our +# .mailmap files either. +# +# For example the user details +# +# Joe +# +# would be excluded via entry +# +# UkM6tKuf79Ra0HH7wQj6YUXumpjWy6Qd3aB5+HoNoGM +# +# To update this file you should use one of the --exclude options to +# `Porting/updateAUTHORS.pl`, but if you *must* manually edit it then make +# sure you run the tool afterwards to ensure it is correctly formatted and +# sorted. +########################################################################## +dXO3142iRNcbpIKO2qxc1o3lNX8+oOCoyG5si+Sb2Ck +QvzD7VskxHgLvOy3GdB9zvcqWIH9uM347jNLQS8QfFs diff --git a/gnu/usr.bin/perl/Porting/manifest_lib.pl b/gnu/usr.bin/perl/Porting/manifest_lib.pl index 95d49be9cd3..c062c944102 100644 --- a/gnu/usr.bin/perl/Porting/manifest_lib.pl +++ b/gnu/usr.bin/perl/Porting/manifest_lib.pl @@ -1,6 +1,8 @@ #!/usr/bin/perl use strict; +use warnings; +use Text::Tabs qw(expand unexpand); =head1 NAME @@ -27,16 +29,77 @@ listed sorted appropriately. # and so that lib/Foo/Bar.pm sorts before lib/Foo/Bar/Alpha.pm # and so that configure and Configure sort together. sub sort_manifest { - return + my @lines = @_; + + # first we ensure that the descriptions for the files + # are lined up reasonably. + my %pfx_len; + my @line_tuples; + foreach my $idx (0 .. $#lines) { + my $line = $lines[$idx]; + # clean up tab/space issues + $line =~ s/\t[ ]+/\t/; + if ($line =~ s/^(\S+)([ ]\s+)(\S+.*)/$1\t/) { + my $descr = $2; + $descr =~ s/\t+/ /g; + $line .= $descr; + } + $line =~ s/\s+\z//; + $line =~ /^(\S+)(?:\t+([^\t]*))?\z/ + or do { + $line =~ s/\t/\\t/g; + die "Malformed content in MANIFEST at line $idx: '$line'\n", + "Note: tabs have been encoded as \\t in this message.\n"; + }; + my ($file, $descr) = ($1, $2); + my $pfx; + if ($file =~ m!^((?:[^/]+/){1,2})!) { + $pfx = $1; + } else { + $pfx = ""; + } + #print "'$pfx': $file\n"; + push @line_tuples, [$pfx, $file, $descr]; + $pfx_len{$pfx} //= 40; + + # ensure we have at least one "space" (really tab) + my $flen = 1 + length $file; + $pfx_len{$pfx} = $flen + if $pfx_len{$pfx} < $flen; + } + + # round up to the next tab stop + $_ % 8 and $_ += (8 - ($_ % 8)) for values %pfx_len; + + my @pretty_lines; + foreach my $tuple (@line_tuples) { + my ($pfx, $file, $descr) = @$tuple; + my $str = sprintf "%*s", -$pfx_len{$pfx}, $file; + ($str) = unexpand($str); + # I do not understand why this is necessary. Bug in unexpand()? + # See https://github.com/ap/Text-Tabs/issues/5 + $str =~ s/[ ]+/\t/; + if ($descr) { + $str =~ s/\t?\z/\t/; + $str .= $descr; + } + $str =~ s/\s+\z//; + push @pretty_lines, $str; + } + + @pretty_lines = # case insensitive sorting of directory components independently. map { $_->[0] } # extract the full line sort { + $a->[2] cmp $b->[2] || # sort by the first directory $a->[1] cmp $b->[1] || # sort in order of munged filename $a->[0] cmp $b->[0] # then by the exact text in full line } map { # split out the filename and the description my ($f) = split /\s+/, $_, 2; + # extract out the first directory + my $d = $f=~m!^(\w+/)! ? lc $1 : ""; # lc the filename so Configure and configure sort together in the list my $m= lc $f; # $m for munged # replace slashes by nulls, this makes short directory names sort before @@ -46,9 +109,11 @@ sub sort_manifest { # this puts any foo/blah.ext before any files in foo/blah/ $m =~ s{(? \$continue, + "s|separate" => \$separate, + "h|help" => \&usage) + or die "Unknown options\n"; + +$|++; + +-f "Configure" + or die "Expected to be run from a perl checkout"; + +my $github_ci = $ENV{'GITHUB_SHA'} ? 1 : 0; + +my $manifest = maniread(); +my @failures = (); + +my @config; +my $install_path; +if ($separate) { + # require EU::MM 6.31 or later + my $install_base = tempdir( CLEANUP => 1 ); + push @config, "INSTALL_BASE=$install_base"; + $ENV{PERL5LIB} .= $Config{path_sep} if $ENV{PERL5LIB}; + $ENV{PERL5LIB} .= join $Config{path_sep}, + "$install_base/lib/perl5/$Config{archname}", + "$install_base/lib/perl5"; +} + +my %dist_config = ( + # these are defined by the modules as distributed on CPAN + # I don't know why their Makefile.PLs aren't in core + "threads" => [ "DEFINE=-DHAS_PPPORT_H" ], + "threads-shared" => [ "DEFINE=-DHAS_PPPORT_H" ], + ); + +my $start = getcwd() + or die "Cannot fetch current directory: $!\n"; + +# get ppport.h +my $pppdir = test_dist("Devel-PPPort"); + +if (@failures) { + if ($github_ci) { + # GitHub may show STDERR before STDOUT.. despite autoflush + # being enabled.. Make sure it detects the 'endgroup' before + # the `die` statement. + print STDERR "::endgroup::\n"; + } + die "Devel-PPPort failed, aborting other tests.\n"; +} + +my $pppfile = "$pppdir/ppport.h"; + +-f $pppfile + or die "No ppport.h found in $pppdir\n"; + +# Devel-PPPort is manually processed before anything else to ensure we +# have an up to date ppport.h +my @dists = @ARGV; +if (@dists) { + for my $dist (@dists) { + -d "dist/$dist" or die "dist/$dist not a directory\n"; + } +} +else { + opendir my $distdir, "dist" + or die "Cannot opendir 'dist': $!\n"; + @dists = sort { lc $a cmp lc $b } grep { /^\w/ && $_ ne "Devel-PPPort" } readdir $distdir; + closedir $distdir; +} + +# These may end up being included if their problems are resolved +{ + # https://github.com/Perl/version.pm claims CPAN is upstream + @dists = grep { $_ ne "version" } @dists; + + # Safe is tied pretty heavily to core + # in any case it didn't seem simple to fix + @dists = grep { $_ ne "Safe" } @dists; +} + +for my $dist (@dists) { + test_dist($dist); +} + +if (@failures) { + if ($github_ci) { + # GitHub may show STDERR before STDOUT.. despite autoflush + # being enabled.. Make sure it detects the 'endgroup' before + # the `die` statement. + print STDERR "::endgroup::\n"; + } + my $msg = join("\n", map { "\t'$_->[0]' failed at $_->[1]" } @failures); + die "Following dists had failures:\n$msg\n"; +} + +sub test_dist { + my ($name) = @_; + + print "::group::Testing $name\n" if $github_ci; + print "*** Testing $name ***\n"; + my $dir = tempdir( CLEANUP => 1); + run("cp", "-a", "dist/$name/.", "$dir/.") + or die "Cannot copy dist files to working directory\n"; + chdir $dir + or die "Cannot chdir to dist working directory '$dir': $!\n"; + if ($pppfile) { + run("cp", $pppfile, ".") + or die "Cannot copy $pppfile to .\n"; + } + if ($name eq "IO" || $name eq "threads" || $name eq "threads-shared") { + write_testpl(); + } + if ($name eq "threads" || $name eq "threads-shared") { + write_threads_h(); + } + if ($name eq "threads-shared") { + write_shared_h(); + } + unless (-f "Makefile.PL") { + print " Creating Makefile.PL for $name\n"; + my $key = "ABSTRACT_FROM"; + my @parts = split /-/, $name; + my $last = $parts[-1]; + my $module = join "::", @parts; + my $fromname; + for my $check ("$last.pm", join("/", "lib", @parts) . ".pm") { + if (-f $check) { + $fromname = $check; + last; + } + } + $fromname + or die "Cannot find ABSTRACT_FROM for $name\n"; + my $value = $fromname; + open my $fh, ">", "Makefile.PL" + or die "Cannot create Makefile.PL: $!\n"; + # adapted from make_ext.pl + printf $fh <<'EOM', $module, $fromname, $key, $value; +use strict; +use ExtUtils::MakeMaker; + +# This is what the .PL extracts to. Not the ultimate file that is installed. +# (ie Win32 runs pl2bat after this) + +# Doing this here avoids all sort of quoting issues that would come from +# attempting to write out perl source with literals to generate the arrays and +# hash. +my @temps = 'Makefile.PL'; +foreach (glob('scripts/pod*.PL')) { + # The various pod*.PL extractors change directory. Doing that with relative + # paths in @INC breaks. It seems the lesser of two evils to copy (to avoid) + # the chdir doing anything, than to attempt to convert lib paths to + # absolute, and potentially run into problems with quoting special + # characters in the path to our build dir (such as spaces) + require File::Copy; + + my $temp = $_; + $temp =~ s!scripts/!!; + File::Copy::copy($_, $temp) or die "Can't copy $temp to $_: $!"; + push @temps, $temp; +} + +my $script_ext = $^O eq 'VMS' ? '.com' : ''; +my %%pod_scripts; +foreach (glob('pod*.PL')) { + my $script = $_; + s/.PL$/$script_ext/i; + $pod_scripts{$script} = $_; +} +my @exe_files = values %%pod_scripts; + +WriteMakefile( + NAME => '%s', + VERSION_FROM => '%s', + %-13s => '%s', + realclean => { FILES => "@temps" }, + (%%pod_scripts ? ( + PL_FILES => \%%pod_scripts, + EXE_FILES => \@exe_files, + clean => { FILES => "@exe_files" }, + ) : ()), +); + +EOM + close $fh; + } + + my $verbose = $github_ci && $ENV{'RUNNER_DEBUG'} ? 1 : 0; + my $failed = ""; + my @my_config = @config; + if (my $cfg = $dist_config{$name}) { + push @my_config, @$cfg; + } + if (!run($^X, "Makefile.PL", @my_config)) { + $failed = "Makefile.PL"; + die "$name: Makefile.PL failed\n" unless $continue; + } + elsif (!run("make", "test", "TEST_VERBOSE=$verbose")) { + $failed = "make test"; + die "$name: make test failed\n" unless $continue; + } + elsif (!run("make", "install")) { + $failed = "make install"; + die "$name: make install failed\n" unless $continue; + } + + chdir $start + or die "Cannot return to $start: $!\n"; + + if ($github_ci) { + print "::endgroup::\n"; + } + if ($continue && $failed) { + print "::error ::$name failed at $failed\n" if $github_ci; + push @failures, [ $name, $failed ]; + } + + $dir; +} + +# IO, threads and threads-shared use the blead t/test.pl when tested in core +# and bundle their own test.pl when distributed on CPAN. +# The test.pl source below is from the IO distribution but so far seems sufficient +# for threads and threads-shared. +sub write_testpl { + _write_from_data("t/test.pl"); +} + +# threads and threads-shared bundle this file, which isn't needed in core +sub write_threads_h { + _write_from_data("threads.h"); +} + +# threads-shared bundles this file, which isn't needed in core +sub write_shared_h { + _write_from_data("shared.h"); +} + +# file data read from +my %file_data; + +sub _write_from_data { + my ($want_name) = @_; + + unless (keys %file_data) { + my $name; + while () { + if (/^-- (\S+) --/) { + $name = $1; + } + else { + $file_data{$name} .= $_; + } + } + close DATA; + } + + my $data = $file_data{$want_name} or die "No data found for $want_name"; + open my $fh, ">", $want_name + or die "Cannot create $want_name: $!\n"; + print $fh $data; + close $fh + or die "Cannot close $want_name: $!\n"; +} + +sub run { + my (@cmd) = @_; + + print "\$ @cmd\n"; + my $result = system(@cmd); + if ($result < 0) { + print "Failed: $!\n"; + } + elsif ($result) { + printf "Failed: %d (%#x)\n", $result, $?; + } + return $result == 0; +} + +sub usage { + print < 255) { + $y .= sprintf "\\x{%x}", $c; + } elsif ($backslash_escape{$c}) { + $y .= $backslash_escape{$c}; + } else { + my $z = chr $c; # Maybe we can get away with a literal... + $z = sprintf "\\%03o", $c if $z =~ /[[:^print:]]/; + $y .= $z; + } + } + $x = $y; + } + return $x unless wantarray; + push @result, $x; + } + return @result; +} + +sub is ($$@) { + my ($got, $expected, $name, @mess) = @_; + + my $pass; + if( !defined $got || !defined $expected ) { + # undef only matches undef + $pass = !defined $got && !defined $expected; + } + else { + $pass = $got eq $expected; + } + + unless ($pass) { + unshift(@mess, "# got "._q($got)."\n", + "# expected "._q($expected)."\n"); + } + _ok($pass, _where(), $name, @mess); +} + +sub isnt ($$@) { + my ($got, $isnt, $name, @mess) = @_; + + my $pass; + if( !defined $got || !defined $isnt ) { + # undef only matches undef + $pass = defined $got || defined $isnt; + } + else { + $pass = $got ne $isnt; + } + + unless( $pass ) { + unshift(@mess, "# it should not be "._q($got)."\n", + "# but it is.\n"); + } + _ok($pass, _where(), $name, @mess); +} + +sub cmp_ok ($$$@) { + my($got, $type, $expected, $name, @mess) = @_; + + my $pass; + { + local $^W = 0; + local($@,$!); # don't interfere with $@ + # eval() sometimes resets $! + $pass = eval "\$got $type \$expected"; + } + unless ($pass) { + # It seems Irix long doubles can have 2147483648 and 2147483648 + # that stringify to the same thing but are acutally numerically + # different. Display the numbers if $type isn't a string operator, + # and the numbers are stringwise the same. + # (all string operators have alphabetic names, so tr/a-z// is true) + # This will also show numbers for some uneeded cases, but will + # definately be helpful for things such as == and <= that fail + if ($got eq $expected and $type !~ tr/a-z//) { + unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; + } + unshift(@mess, "# got "._q($got)."\n", + "# expected $type "._q($expected)."\n"); + } + _ok($pass, _where(), $name, @mess); +} + +# Check that $got is within $range of $expected +# if $range is 0, then check it's exact +# else if $expected is 0, then $range is an absolute value +# otherwise $range is a fractional error. +# Here $range must be numeric, >= 0 +# Non numeric ranges might be a useful future extension. (eg %) +sub within ($$$@) { + my ($got, $expected, $range, $name, @mess) = @_; + my $pass; + if (!defined $got or !defined $expected or !defined $range) { + # This is a fail, but doesn't need extra diagnostics + } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { + # This is a fail + unshift @mess, "# got, expected and range must be numeric\n"; + } elsif ($range < 0) { + # This is also a fail + unshift @mess, "# range must not be negative\n"; + } elsif ($range == 0) { + # Within 0 is == + $pass = $got == $expected; + } elsif ($expected == 0) { + # If expected is 0, treat range as absolute + $pass = ($got <= $range) && ($got >= - $range); + } else { + my $diff = $got - $expected; + $pass = abs ($diff / $expected) < $range; + } + unless ($pass) { + if ($got eq $expected) { + unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; + } + unshift@mess, "# got "._q($got)."\n", + "# expected "._q($expected)." (within "._q($range).")\n"; + } + _ok($pass, _where(), $name, @mess); +} + +# Note: this isn't quite as fancy as Test::More::like(). + +sub like ($$@) { like_yn (0,@_) }; # 0 for - +sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- + +sub like_yn ($$$@) { + my ($flip, $got, $expected, $name, @mess) = @_; + my $pass; + $pass = $got =~ /$expected/ if !$flip; + $pass = $got !~ /$expected/ if $flip; + unless ($pass) { + unshift(@mess, "# got '$got'\n", + $flip + ? "# expected !~ /$expected/\n" : "# expected /$expected/\n"); + } + local $Level = $Level + 1; + _ok($pass, _where(), $name, @mess); +} + +sub pass { + _ok(1, '', @_); +} + +sub fail { + _ok(0, _where(), @_); +} + +sub curr_test { + $test = shift if @_; + return $test; +} + +sub next_test { + my $retval = $test; + $test = $test + 1; # don't use ++ + $retval; +} + +# Note: can't pass multipart messages since we try to +# be compatible with Test::More::skip(). +sub skip { + my $why = shift; + my $n = @_ ? shift : 1; + for (1..$n) { + _print "ok $test # skip $why\n"; + $test = $test + 1; + } + local $^W = 0; + last SKIP; +} + +sub todo_skip { + my $why = shift; + my $n = @_ ? shift : 1; + + for (1..$n) { + _print "not ok $test # TODO & SKIP $why\n"; + $test = $test + 1; + } + local $^W = 0; + last TODO; +} + +sub eq_array { + my ($ra, $rb) = @_; + return 0 unless $#$ra == $#$rb; + for my $i (0..$#$ra) { + next if !defined $ra->[$i] && !defined $rb->[$i]; + return 0 if !defined $ra->[$i]; + return 0 if !defined $rb->[$i]; + return 0 unless $ra->[$i] eq $rb->[$i]; + } + return 1; +} + +sub eq_hash { + my ($orig, $suspect) = @_; + my $fail; + while (my ($key, $value) = each %$suspect) { + # Force a hash recompute if this perl's internals can cache the hash key. + $key = "" . $key; + if (exists $orig->{$key}) { + if ($orig->{$key} ne $value) { + _print "# key ", _qq($key), " was ", _qq($orig->{$key}), + " now ", _qq($value), "\n"; + $fail = 1; + } + } else { + _print "# key ", _qq($key), " is ", _qq($value), + ", not in original.\n"; + $fail = 1; + } + } + foreach (keys %$orig) { + # Force a hash recompute if this perl's internals can cache the hash key. + $_ = "" . $_; + next if (exists $suspect->{$_}); + _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; + $fail = 1; + } + !$fail; +} + +sub require_ok ($) { + my ($require) = @_; + eval < [ command-line switches ] +# nolib => 1 # don't use -I../lib (included by default) +# prog => one-liner (avoid quotes) +# progs => [ multi-liner (avoid quotes) ] +# progfile => perl script +# stdin => string to feed the stdin +# stderr => redirect stderr to stdout +# args => [ command-line arguments to the perl program ] +# verbose => print the command line + +my $is_mswin = $^O eq 'MSWin32'; +my $is_netware = $^O eq 'NetWare'; +my $is_macos = $^O eq 'MacOS'; +my $is_vms = $^O eq 'VMS'; +my $is_cygwin = $^O eq 'cygwin'; + +sub _quote_args { + my ($runperl, $args) = @_; + + foreach (@$args) { + # In VMS protect with doublequotes because otherwise + # DCL will lowercase -- unless already doublequoted. + $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; + $$runperl .= ' ' . $_; + } +} + +sub _create_runperl { # Create the string to qx in runperl(). + my %args = @_; + my $runperl = which_perl(); + if ($runperl =~ m/\s/) { + $runperl = qq{"$runperl"}; + } + #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind + if ($ENV{PERL_RUNPERL_DEBUG}) { + $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; + } + unless ($args{nolib}) { + if ($is_macos) { + $runperl .= ' -I::lib'; + # Use UNIX style error messages instead of MPW style. + $runperl .= ' -MMac::err=unix' if $args{stderr}; + } + else { + $runperl .= ' "-I../lib"'; # doublequotes because of VMS + } + } + if ($args{switches}) { + local $Level = 2; + die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() + unless ref $args{switches} eq "ARRAY"; + _quote_args(\$runperl, $args{switches}); + } + if (defined $args{prog}) { + die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() + if defined $args{progs}; + $args{progs} = [$args{prog}] + } + if (defined $args{progs}) { + die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() + unless ref $args{progs} eq "ARRAY"; + foreach my $prog (@{$args{progs}}) { + if ($is_mswin || $is_netware || $is_vms) { + $runperl .= qq ( -e "$prog" ); + } + else { + $runperl .= qq ( -e '$prog' ); + } + } + } elsif (defined $args{progfile}) { + $runperl .= qq( "$args{progfile}"); + } else { + # You probaby didn't want to be sucking in from the upstream stdin + die "test.pl:runperl(): none of prog, progs, progfile, args, " + . " switches or stdin specified" + unless defined $args{args} or defined $args{switches} + or defined $args{stdin}; + } + if (defined $args{stdin}) { + # so we don't try to put literal newlines and crs onto the + # command line. + $args{stdin} =~ s/\n/\\n/g; + $args{stdin} =~ s/\r/\\r/g; + + if ($is_mswin || $is_netware || $is_vms) { + $runperl = qq{$Perl -e "print qq(} . + $args{stdin} . q{)" | } . $runperl; + } + elsif ($is_macos) { + # MacOS can only do two processes under MPW at once; + # the test itself is one; we can't do two more, so + # write to temp file + my $stdin = qq{$Perl -e 'print qq(} . $args{stdin} . qq{)' > teststdin; }; + if ($args{verbose}) { + my $stdindisplay = $stdin; + $stdindisplay =~ s/\n/\n\#/g; + _print_stderr "# $stdindisplay\n"; + } + `$stdin`; + $runperl .= q{ < teststdin }; + } + else { + $runperl = qq{$Perl -e 'print qq(} . + $args{stdin} . q{)' | } . $runperl; + } + } + if (defined $args{args}) { + _quote_args(\$runperl, $args{args}); + } + $runperl .= ' 2>&1' if $args{stderr} && !$is_macos; + $runperl .= " \xB3 Dev:Null" if !$args{stderr} && $is_macos; + if ($args{verbose}) { + my $runperldisplay = $runperl; + $runperldisplay =~ s/\n/\n\#/g; + _print_stderr "# $runperldisplay\n"; + } + return $runperl; +} + +sub runperl { + die "test.pl:runperl() does not take a hashref" + if ref $_[0] and ref $_[0] eq 'HASH'; + my $runperl = &_create_runperl; + my $result; + + my $tainted = ${^TAINT}; + my %args = @_; + exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; + + if ($tainted) { + # We will assume that if you're running under -T, you really mean to + # run a fresh perl, so we'll brute force launder everything for you + my $sep; + + if (! eval 'require Config; 1') { + warn "test.pl had problems loading Config: $@"; + $sep = ':'; + } else { + $sep = $Config::Config{path_sep}; + } + + my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); + local @ENV{@keys} = (); + # Untaint, plus take out . and empty string: + local $ENV{'DCL$PATH'} = $1 if $is_vms && ($ENV{'DCL$PATH'} =~ /(.*)/s); + $ENV{PATH} =~ /(.*)/s; + local $ENV{PATH} = + join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and + ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } + split quotemeta ($sep), $1; + $ENV{PATH} .= "$sep/bin" if $is_cygwin; # Must have /bin under Cygwin + + $runperl =~ /(.*)/s; + $runperl = $1; + + $result = `$runperl`; + } else { + $result = `$runperl`; + } + $result =~ s/\n\n/\n/ if $is_vms; # XXX pipes sometimes double these + return $result; +} + +*run_perl = \&runperl; # Nice alias. + +sub DIE { + _print_stderr "# @_\n"; + exit 1; +} + +# A somewhat safer version of the sometimes wrong $^X. +sub which_perl { + unless (defined $Perl) { + $Perl = $^X; + + # VMS should have 'perl' aliased properly + return $Perl if $^O eq 'VMS'; + + my $exe; + if (! eval 'require Config; 1') { + warn "test.pl had problems loading Config: $@"; + $exe = ''; + } else { + $exe = $Config::Config{_exe}; + } + $exe = '' unless defined $exe; + + # This doesn't absolutize the path: beware of future chdirs(). + # We could do File::Spec->abs2rel() but that does getcwd()s, + # which is a bit heavyweight to do here. + + if ($Perl =~ /^perl\Q$exe\E$/i) { + my $perl = "perl$exe"; + if (! eval 'require File::Spec; 1') { + warn "test.pl had problems loading File::Spec: $@"; + $Perl = "./$perl"; + } else { + $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); + } + } + + # Build up the name of the executable file from the name of + # the command. + + if ($Perl !~ /\Q$exe\E$/i) { + $Perl .= $exe; + } + + warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; + + # For subcommands to use. + $ENV{PERLEXE} = $Perl; + } + return $Perl; +} + +sub unlink_all { + foreach my $file (@_) { + 1 while unlink $file; + _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; + } +} + +my %tmpfiles; +END { unlink_all keys %tmpfiles } + +# A regexp that matches the tempfile names +$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?'; + +# Avoid ++, avoid ranges, avoid split // +my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); +sub tempfile { + my $count = 0; + do { + my $temp = $count; + my $try = "tmp$$"; + do { + $try .= $letters[$temp % 26]; + $temp = int ($temp / 26); + } while $temp; + # Need to note all the file names we allocated, as a second request may + # come before the first is created. + if (!-e $try && !$tmpfiles{$try}) { + # We have a winner + $tmpfiles{$try}++; + return $try; + } + $count = $count + 1; + } while $count < 26 * 26; + die "Can't find temporary file name starting 'tmp$$'"; +} + +# This is the temporary file for _fresh_perl +my $tmpfile = tempfile(); + +# +# _fresh_perl +# +# The $resolve must be a subref that tests the first argument +# for success, or returns the definition of success (e.g. the +# expected scalar) if given no arguments. +# + +sub _fresh_perl { + my($prog, $resolve, $runperl_args, $name) = @_; + + $runperl_args ||= {}; + $runperl_args->{progfile} = $tmpfile; + $runperl_args->{stderr} = 1; + + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + + # VMS adjustments + if( $^O eq 'VMS' ) { + $prog =~ s#/dev/null#NL:#; + + # VMS file locking + $prog =~ s{if \(-e _ and -f _ and -r _\)} + {if (-e _ and -f _)} + } + + print TEST $prog; + close TEST or die "Cannot close $tmpfile: $!"; + + my $results = runperl(%$runperl_args); + my $status = $?; + + # Clean up the results into something a bit more predictable. + $results =~ s/\n+$//; + $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; + $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; + + # bison says 'parse error' instead of 'syntax error', + # various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + + if ($^O eq 'VMS') { + # some tests will trigger VMS messages that won't be expected + $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; + + # pipes double these sometimes + $results =~ s/\n\n/\n/g; + } + + my $pass = $resolve->($results); + unless ($pass) { + _diag "# PROG: \n$prog\n"; + _diag "# EXPECTED:\n", $resolve->(), "\n"; + _diag "# GOT:\n$results\n"; + _diag "# STATUS: $status\n"; + } + + # Use the first line of the program as a name if none was given + unless( $name ) { + ($first_line, $name) = $prog =~ /^((.{1,50}).*)/; + $name .= '...' if length $first_line > length $name; + } + + _ok($pass, _where(), "fresh_perl - $name"); +} + +# +# fresh_perl_is +# +# Combination of run_perl() and is(). +# + +sub fresh_perl_is { + my($prog, $expected, $runperl_args, $name) = @_; + local $Level = 2; + _fresh_perl($prog, + sub { @_ ? $_[0] eq $expected : $expected }, + $runperl_args, $name); +} + +# +# fresh_perl_like +# +# Combination of run_perl() and like(). +# + +sub fresh_perl_like { + my($prog, $expected, $runperl_args, $name) = @_; + local $Level = 2; + _fresh_perl($prog, + sub { @_ ? + $_[0] =~ (ref $expected ? $expected : /$expected/) : + $expected }, + $runperl_args, $name); +} + +sub can_ok ($@) { + my($proto, @methods) = @_; + my $class = ref $proto || $proto; + + unless( @methods ) { + return _ok( 0, _where(), "$class->can(...)" ); + } + + my @nok = (); + foreach my $method (@methods) { + local($!, $@); # don't interfere with caller's $@ + # eval sometimes resets $! + eval { $proto->can($method) } || push @nok, $method; + } + + my $name; + $name = @methods == 1 ? "$class->can('$methods[0]')" + : "$class->can(...)"; + + _ok( !@nok, _where(), $name ); +} + +sub isa_ok ($$;$) { + my($object, $class, $obj_name) = @_; + + my $diag; + $obj_name = 'The object' unless defined $obj_name; + my $name = "$obj_name isa $class"; + if( !defined $object ) { + $diag = "$obj_name isn't defined"; + } + elsif( !ref $object ) { + $diag = "$obj_name isn't a reference"; + } + else { + # We can't use UNIVERSAL::isa because we want to honor isa() overrides + local($@, $!); # eval sometimes resets $! + my $rslt = eval { $object->isa($class) }; + if( $@ ) { + if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { + if( !UNIVERSAL::isa($object, $class) ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } else { + die <isa on your object and got some weird error. +This should never happen. Please contact the author immediately. +Here's the error. +$@ +WHOA + } + } + elsif( !$rslt ) { + my $ref = ref $object; + $diag = "$obj_name isn't a '$class' it's a '$ref'"; + } + } + + _ok( !$diag, _where(), $name ); +} + +# Set a watchdog to timeout the entire test file +# NOTE: If the test file uses 'threads', then call the watchdog() function +# _AFTER_ the 'threads' module is loaded. +sub watchdog ($) +{ + my $timeout = shift; + my $timeout_msg = 'Test process timed out - terminating'; + + my $pid_to_kill = $$; # PID for this process + + # Don't use a watchdog process if 'threads' is loaded - + # use a watchdog thread instead + if (! $threads::threads) { + + # On Windows and VMS, try launching a watchdog process + # using system(1, ...) (see perlport.pod) + if (($^O eq 'MSWin32') || ($^O eq 'VMS')) { + # On Windows, try to get the 'real' PID + if ($^O eq 'MSWin32') { + eval { require Win32; }; + if (defined(&Win32::GetCurrentProcessId)) { + $pid_to_kill = Win32::GetCurrentProcessId(); + } + } + + # If we still have a fake PID, we can't use this method at all + return if ($pid_to_kill <= 0); + + # Launch watchdog process + my $watchdog; + eval { + local $SIG{'__WARN__'} = sub { + _diag("Watchdog warning: $_[0]"); + }; + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + $watchdog = system(1, which_perl(), '-e', + "sleep($timeout);" . + "warn('# $timeout_msg\n');" . + "kill($sig, $pid_to_kill);"); + }; + if ($@ || ($watchdog <= 0)) { + _diag('Failed to start watchdog'); + _diag($@) if $@; + undef($watchdog); + return; + } + + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + # Try using fork() to generate a watchdog process + my $watchdog; + eval { $watchdog = fork() }; + if (defined($watchdog)) { + if ($watchdog) { # Parent process + # Add END block to parent to terminate and + # clean up watchdog process + eval "END { local \$! = 0; local \$? = 0; + wait() if kill('KILL', $watchdog); };"; + return; + } + + ### Watchdog process code + + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 + sleep(2); + + # Kill test process if still running + if (kill(0, $pid_to_kill)) { + _diag($timeout_msg); + kill('KILL', $pid_to_kill); + } + + # Don't execute END block (added at beginning of this file) + $NO_ENDING = 1; + + # Terminate ourself (i.e., the watchdog) + POSIX::_exit(1) if (defined(&POSIX::_exit)); + exit(1); + } + + # fork() failed - fall through and try using a thread + } + + # Use a watchdog thread because either 'threads' is loaded, + # or fork() failed + if (eval 'require threads; 1') { + threads->create(sub { + # Load POSIX if available + eval { require POSIX; }; + + # Execute the timeout + my $time_left = $timeout; + do { + $time_left -= sleep($time_left); + } while ($time_left > 0); + + # Kill the parent (and ourself) + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + })->detach(); + return; + } + + # If everything above fails, then just use an alarm timeout + if (eval { alarm($timeout); 1; }) { + # Load POSIX if available + eval { require POSIX; }; + + # Alarm handler will do the actual 'killing' + $SIG{'ALRM'} = sub { + select(STDERR); $| = 1; + _diag($timeout_msg); + POSIX::_exit(1) if (defined(&POSIX::_exit)); + my $sig = $^O eq 'VMS' ? 'TERM' : 'KILL'; + kill($sig, $pid_to_kill); + }; + } +} + +1; +-- threads.h -- +#ifndef _THREADS_H_ +#define _THREADS_H_ + +/* Needed for 5.8.0 */ +#ifndef CLONEf_JOIN_IN +# define CLONEf_JOIN_IN 8 +#endif +#ifndef SAVEBOOL +# define SAVEBOOL(a) +#endif + +/* Added in 5.11.x */ +#ifndef G_WANT +# define G_WANT (128|1) +#endif + +/* Added in 5.24.x */ +#ifndef PERL_TSA_RELEASE +# define PERL_TSA_RELEASE(x) +#endif +#ifndef PERL_TSA_EXCLUDES +# define PERL_TSA_EXCLUDES(x) +#endif +#ifndef CLANG_DIAG_IGNORE +# define CLANG_DIAG_IGNORE(x) +#endif +#ifndef CLANG_DIAG_RESTORE +# define CLANG_DIAG_RESTORE +#endif + +/* Added in 5.38 */ +#ifndef PERL_SRAND_OVERRIDE_NEXT_PARENT +# define PERL_SRAND_OVERRIDE_NEXT_PARENT() +#endif + +#endif +-- shared.h -- +#ifndef _SHARED_H_ +#define _SHARED_H_ + +#include "ppport.h" + +#ifndef HvNAME_get +# define HvNAME_get(hv) (0 + ((XPVHV*)SvANY(hv))->xhv_name) +#endif + +#endif diff --git a/gnu/usr.bin/perl/Porting/updateAUTHORS.pl b/gnu/usr.bin/perl/Porting/updateAUTHORS.pl index 6eb64bb64f1..a61fe7ec989 100755 --- a/gnu/usr.bin/perl/Porting/updateAUTHORS.pl +++ b/gnu/usr.bin/perl/Porting/updateAUTHORS.pl @@ -1,11 +1,15 @@ #!/usr/bin/env perl -package Porting::updateAUTHORS; +package App::Porting::updateAUTHORS; use strict; use warnings; use Getopt::Long qw(GetOptions); use Pod::Usage qw(pod2usage); use Data::Dumper; -use Encode qw(encode_utf8 decode_utf8 decode); +use Encode qw(encode_utf8 decode_utf8); +use lib "./"; +use Porting::updateAUTHORS; +use Test::More; +use Text::Wrap qw(wrap); # The style of this file is determined by: # @@ -13,649 +17,735 @@ use Encode qw(encode_utf8 decode_utf8 decode); # -isbc -nolc -otr -kis -ci=4 -se -sot -sct -nsbl -pt=2 -fs \ # -fsb='#start-no-tidy' -fse='#end-no-tidy' -# Info and config for passing to git log. -# %an: author name -# %aN: author name (respecting .mailmap, see git-shortlog(1) or git-blame(1)) -# %ae: author email -# %aE: author email (respecting .mailmap, see git-shortlog(1) or git-blame(1)) -# %cn: committer name -# %cN: committer name (respecting .mailmap, see git-shortlog(1) or git-blame(1)) -# %ce: committer email -# %cE: committer email (respecting .mailmap, see git-shortlog(1) or git-blame(1)) -# %H: commit hash -# %h: abbreviated commit hash -# %s: subject -# %x00: print a byte from a hex code - -my %field_spec= ( - "an" => "author_name", - "aN" => "author_name_mm", - "ae" => "author_email", - "aE" => "author_email_mm", - "cn" => "committer_name", - "cN" => "committer_name_mm", - "ce" => "committer_email", - "cE" => "committer_email_mm", - "H" => "commit_hash", - "h" => "abbrev_hash", - "s" => "commit_subject", +my @OPTSPEC= qw( + help|? + man + authors_file=s + mailmap_file=s + + validate|tap + verbose+ + exclude_missing|exclude + exclude_contrib=s@ + exclude_me + dump_opts + + show_rank|rank + show_applied|thanks_applied|applied + show_stats|stats + show_who|who + show_files|files + show_file_changes|activity + show_file_chainsaw|chainsaw + + as_percentage|percentage + as_cumulative|cumulative + as_list|old_style + + in_reverse|reverse + with_rank_numbers|numbered|num + + from_commit|from=s + to_commit|to=s + + numstat + no_update + + change_name_for_name|change_name=s% + change_name_for_email=s% + change_email_for_name=s% + change_email_for_email|change_email=s% ); -my @field_codes= sort keys %field_spec; -my @field_names= map { $field_spec{$_} } @field_codes; -my $tformat= join "%x00", map { "%" . $_ } @field_codes; - -sub _make_name_author_info { - my ($author_info, $commit_info, $name_key)= @_; - (my $email_key= $name_key) =~ s/name/email/; - my $email= $commit_info->{$email_key}; - my $name= $commit_info->{$name_key}; - - my $line= $author_info->{"email2line"}{$email} - // $author_info->{"name2line"}{$name}; - - $line //= sprintf "%-31s<%s>", - $commit_info->{$name_key}, $commit_info->{$email_key}; - return $line; -} - -sub _make_name_simple { - my ($commit_info, $key)= @_; - my $name_key= $key . "_name"; - my $email_key= $key . "_email"; - return sprintf "%s <%s>", $commit_info->{$name_key}, - lc($commit_info->{$email_key}); -} +my %implies_numstat= ( + show_files => 1, + show_file_changes => 1, + show_file_chainsaw => 1, +); -sub read_commit_log { - my ($author_info, $mailmap_info)= @_; - $author_info ||= {}; - open my $fh, qq(git log --pretty='tformat:$tformat' |); +sub main { + local $Data::Dumper::Sortkeys= 1; + my %opts= ( + authors_file => "AUTHORS", + mailmap_file => ".mailmap", + exclude_file => "Porting/exclude_contrib.txt", + from => "", + to => "", + exclude_contrib => [], + ); - while (defined(my $line= <$fh>)) { - chomp $line; - $line= decode_utf8($line); - my $commit_info= {}; - @{$commit_info}{@field_names}= split /\0/, $line, 0 + @field_names; + ## Parse options and print usage if there is a syntax error, + ## or if usage was explicitly requested. + GetOptions( + \%opts, + map { + # support hyphens as well as underbars, + # underbars must be first. Only handles two + # part words right now. + ref $_ ? $_ : s/\b([a-z]+)_([a-z]+)\b/${1}_${2}|${1}-${2}/gr + } @OPTSPEC, + ) or pod2usage(2); + $opts{commit_range}= join " ", @ARGV; + if (!$opts{commit_range}) { + if ($opts{from_commit}) { + $opts{to_commit} ||= "HEAD"; + $opts{$_} =~ s/\.+\z// for qw(from_commit to_commit); + $opts{commit_range}= "$opts{from_commit}..$opts{to_commit}"; + } + } + pod2usage(1) if $opts{help}; + pod2usage(-verbose => 2) if $opts{man}; - my $author_name_mm= _make_name_author_info($author_info, $commit_info, - "author_name_mm"); + foreach my $opt (keys %opts) { + $opts{numstat}++ if $implies_numstat{$opt}; + $opts{no_update}++ if $opt =~ /^show_/ or $opt eq "validate"; + } - my $committer_name_mm= - _make_name_author_info($author_info, $commit_info, - "committer_name_mm"); + if (delete $opts{exclude_me}) { + my ($author_full)= + Porting::updateAUTHORS->current_author_name_email("full"); + my ($committer_full)= + Porting::updateAUTHORS->current_committer_name_email("full"); + + push @{ $opts{exclude_contrib} }, $author_full + if $author_full; + push @{ $opts{exclude_contrib} }, $committer_full + if $committer_full + and (!$author_full + or $committer_full ne $author_full); + } - my $author_name_real= _make_name_simple($commit_info, "author"); + my $self= Porting::updateAUTHORS->new(%opts); - my $committer_name_real= _make_name_simple($commit_info, "committer"); + my $changed= $self->read_and_update(); - _check_name_mailmap( - $mailmap_info, $author_name_mm, $author_name_real, - $commit_info, "author name" - ); - _check_name_mailmap($mailmap_info, $committer_name_mm, - $committer_name_real, $commit_info, "committer name"); + if ($self->{validate}) { + for my $file_type (qw(authors_file mailmap_file exclude_file)) { + my $file= $self->{$file_type}; + my $changes= $self->changed_file($file); + ok(!$changes, "Is $file_type '$file' up to date?") + or diag $self->_diff_diag($file); + } + my $dupe_info= $self->dupe_info(); + ok(!$dupe_info, "No dupes in AUTHORS") + or diag $dupe_info; + + ok( + !$self->{missing_author}{$_}, + sprintf "%s is listed in AUTHORS", + _clean_name($_)) for sort keys %{ $self->{missing_author} || {} }; + + SKIP: { + # What is tested in this block: + # - check if there uncommitted changes in the git-tree + # - if so: is the (configured) author a known contributor? + + skip "AUTOMATED_TESTING is set" if ($ENV{AUTOMATED_TESTING}); + + # Test::Smoke leaves some files in the build dir which causes + # this code to (correctly) conclude that there are uncommitted + # files which then proceeds to check the author name/email. + # + # On several smokers: + # - there is *no* git config; + # - a different name/address is configured then the one listed + # in AUTHORS; + # which causes the test to fail. + # + # Unfortunately Test::Smoke doesn't set the AUTOMATED_TESTING + # env-var.. Therefor check if mktest.out exist, it's one of the + # first files Test::Smoke creates in the build directory. + skip "Test::Smoke running" if (-e "./mktest.out"); + + my $uncommitted_files= $self->git_status_porcelain; + if ($uncommitted_files) { + my ($author_name, $author_email)= + $self->current_author_name_email(); + my ($committer_name, $committer_email)= + $self->current_committer_name_email(); + + ok($author_name && $author_email, + "git knows your author name and email."); + ok( + $committer_name && $committer_email, + "git knows your committer name and email." + ); + + my $author_known= + $self->known_contributor($author_name, $author_email); + my $committer_known= + $self->known_contributor($committer_name, $committer_email); + if ( + is( + $author_known && $committer_known, + 1, "Uncommitted changes are by a known contributor?" + )) + { + diag + "Testing uncommtted changes! Remember to commit before you push!" + if $ENV{TEST_VERBOSE}; + } + else { + diag error_advice_for_uncommitted_changes( + $author_name, $author_email, + $committer_name, $committer_email, + $uncommitted_files + ); + } + } + else { + # this will always pass... but it adds test output that is helpful + ok(!$uncommitted_files, + "git status --porcelain should be empty"); + } + } - $author_info->{"lines"}{$author_name_mm}++; - $author_info->{"lines"}{$committer_name_mm}++; + diag "\nFiles need updating! You probably just need to run\n\n", + " Porting/updateAUTHORS.pl\n\n", "and commit the results." + if $self->changed_count; + done_testing(); + return 0; } - return $author_info; -} - -sub read_authors { - my ($authors_file)= @_; - $authors_file ||= "AUTHORS"; - - my @authors_preamble; - open my $in_fh, "<", $authors_file - or die "Failed to open for read '$authors_file': $!"; - while (defined(my $line= <$in_fh>)) { - chomp $line; - push @authors_preamble, $line; - if ($line =~ /^--/) { - last; - } + elsif ($self->{show_rank}) { + $self->report_stats("who_stats", "author"); + return 0; } - my %author_info; - while (defined(my $line= <$in_fh>)) { - chomp $line; - $line= decode_utf8($line); - my ($name, $email); - my $copy= $line; - $copy =~ s/\s+\z//; - if ($copy =~ s/<([^<>]*)>//) { - $email= $1; - } - elsif ($copy =~ s/\s+(\@\w+)\z//) { - $email= $1; - } - $copy =~ s/\s+\z//; - $name= $copy; - $email //= "unknown"; - $email= lc($email); - - $author_info{"lines"}{$line}++; - $author_info{"email2line"}{$email}= $line - if $email and $email ne "unknown"; - $author_info{"name2line"}{$name}= $line - if $name and $name ne "unknown"; - $author_info{"email2name"}{ lc($email) }= $name - if $email - and $name - and $email ne "unknown"; - $author_info{"name2email"}{$name}= $email - if $name and $name ne "unknown"; + elsif ($self->{show_applied}) { + $self->report_stats("who_stats", "applied"); + return 0; } - close $in_fh - or die "Failed to close '$authors_file': $!"; - return (\%author_info, \@authors_preamble); -} - -sub update_authors { - my ($author_info, $authors_preamble, $authors_file)= @_; - $authors_file ||= "AUTHORS"; - my $authors_file_new= $authors_file . ".new"; - open my $out_fh, ">", $authors_file_new - or die "Failed to open for write '$authors_file_new': $!"; - binmode $out_fh; - foreach my $line (@$authors_preamble) { - print $out_fh encode_utf8($line), "\n" - or die "Failed to print to '$authors_file_new': $!"; + elsif ($self->{show_stats}) { + my @fields= ("author", "applied", "committer"); + push @fields, + ("num_files", "lines_added", "lines_removed", "lines_delta") + if $self->{numstat}; + $self->report_stats("who_stats", @fields); + return 0; } - foreach my $author (_sorted_hash_keys($author_info->{"lines"})) { - next if $author =~ /^unknown/; - if ($author =~ s/\s*\z//) { - next if $author =~ /^\w+$/; - } - print $out_fh encode_utf8($author), "\n" - or die "Failed to print to '$authors_file_new': $!"; + elsif ($self->{show_files}) { + $self->report_stats( + "file_stats", "commits", "lines_added", "lines_removed", + "lines_delta", "binary_change" + ); + return 0; } - close $out_fh - or die "Failed to close '$authors_file_new': $!"; - rename $authors_file_new, $authors_file - or die "Failed to rename '$authors_file_new' to '$authors_file':$!"; - return 1; # ok -} - -sub read_mailmap { - my ($mailmap_file)= @_; - $mailmap_file ||= ".mailmap"; - - open my $in, "<", $mailmap_file - or die "Failed to read '$mailmap_file': $!"; - my %mailmap_hash; - my @mailmap_preamble; - my $line_num= 0; - while (defined(my $line= <$in>)) { - ++$line_num; - next unless $line =~ /\S/; - chomp($line); - $line= decode_utf8($line); - if ($line =~ /^#/) { - if (!keys %mailmap_hash) { - push @mailmap_preamble, $line; - } - else { - die encode_utf8 "Not expecting comments after header ", - "finished at line $line_num!\nLine: $line\n"; - } - } - else { - $mailmap_hash{$line}= $line_num; - } + elsif ($self->{show_file_changes}) { + $self->report_stats( + "file_stats", "lines_delta", "lines_added", "lines_removed", + "commits" + ); + return 0; } - close $in; - return \%mailmap_hash, \@mailmap_preamble; -} - -# this can be used to extract data from the checkAUTHORS data -sub merge_mailmap_with_AUTHORS_and_checkAUTHORS_data { - my ($mailmap_hash, $author_info)= @_; - require 'Porting/checkAUTHORS.pl' or die "No authors?"; - my ($map, $preferred_email_or_github)= - Porting::checkAUTHORS::generate_known_author_map(); - - foreach my $old (sort keys %$preferred_email_or_github) { - my $new= $preferred_email_or_github->{$old}; - next if $old !~ /\@/ or $new !~ /\@/ or $new eq $old; - my $name= $author_info->{"email2name"}{$new}; - if ($name) { - my $line= "$name <$new> <$old>"; - $mailmap_hash->{$line}++; - } + elsif ($self->{show_file_chainsaw}) { + $self->{in_reverse}= !$self->{in_reverse}; + $self->report_stats( + "file_stats", "lines_delta", "lines_added", "lines_removed", + "commits" + ); + return 0; } - return 1; # ok -} - -sub _sorted_hash_keys { - my ($hash)= @_; - my @sorted= sort { lc($a) cmp lc($b) || $a cmp $b } keys %$hash; - return @sorted; -} - -sub update_mailmap { - my ($mailmap_hash, $mailmap_preamble, $mailmap_file)= @_; - $mailmap_file ||= ".mailmap"; - - my $mailmap_file_new= $mailmap_file . "_new"; - open my $out, ">", $mailmap_file_new - or die "Failed to write '$mailmap_file_new':$!"; - binmode $out; - foreach my $line (@$mailmap_preamble, _sorted_hash_keys($mailmap_hash),) { - print $out encode_utf8($line), "\n" - or die "Failed to print to '$mailmap_file': $!"; + elsif ($self->{show_who}) { + $self->print_who(); + return 0; } - close $out; - rename $mailmap_file_new, $mailmap_file - or die "Failed to rename '$mailmap_file_new' to '$mailmap_file':$!"; - return 1; # ok + return $changed; # 0 means nothing changed } -sub parse_mailmap_hash { - my ($mailmap_hash)= @_; - my @recs; - foreach my $line (sort keys %$mailmap_hash) { - my $line_num= $mailmap_hash->{$line}; - $line =~ /^ \s* (?: ( [^<>]*? ) \s+ )? <([^<>]*)> - (?: \s+ (?: ( [^<>]*? ) \s+ )? <([^<>]*)> )? \s* \z /x - or die encode_utf8 "Failed to parse line num $line_num: '$line'"; - if (!$1 or !$2) { - die encode_utf8 "Both preferred name and email are mandatory ", - "in line num $line_num: '$line'"; - } +exit(main()) unless caller; - # [ preferred_name, preferred_email, other_name, other_email ] - push @recs, [ $1, $2, $3, $4, $line_num ]; +sub error_advice_for_uncommitted_changes { + my ( + $author_name, $author_email, $committer_name, + $committer_email, $uncommitted_files + )= @_; + $_ //= "" + for $author_name, $author_email, $committer_name, $committer_email; + my $extra= ""; + my @git_env_keys= + map { /^GIT_(AUTHOR|COMMITTER)_(NAME|EMAIL)\z/ ? "$_='$ENV{$_}'" : () } + sort keys %ENV; + if (@git_env_keys) { + $extra .= "\n" . wrap "", "", + "Its seems that your environment has " + . join(", ", @git_env_keys) + . " defined. This may cause this test to fail.\n\n"; } - return \@recs; -} -sub _safe_set_key { - my ($hash, $root_key, $key, $val, $pretty_name)= @_; - $hash->{$root_key}{$key} //= $val; - my $prev= $hash->{$root_key}{$key}; - if ($prev ne $val) { - die encode_utf8 "Collision on mapping $root_key: " - . " '$key' maps to '$prev' and '$val'\n"; - } -} + my $quote= $^O =~ /Win/ ? '"' : "'"; + my @config= map decode_utf8($_), + `git config --get-regexp $quote^(user|author|committer).(name|email)$quote`; + if (@config) { -my $O2P= "other2preferred"; -my $O2PN= "other2preferred_name"; -my $O2PE= "other2preferred_email"; -my $P2O= "preferred2other"; -my $N2P= "name2preferred"; -my $E2P= "email2preferred"; - -my $blurb= ""; # FIXME - replace with a nice message - -sub _check_name_mailmap { - my ($mailmap_info, $auth_name, $raw_name, $commit_info, $descr)= @_; - my $name= $auth_name; - $name =~ s/<([^<>]+)>/<\L$1\E>/ - or $name =~ s/(\s)(\@\w+)\z/$1<\L$2\E>/ - or $name .= " "; - - $name =~ s/\s+/ /g; - - if (!$mailmap_info->{$P2O}{$name}) { - warn encode_utf8 sprintf "Unknown %s '%s' in commit %s '%s'\n%s", - $descr, - $name, $commit_info->{"abbrev_hash"}, - $commit_info->{"commit_subject"}, - $blurb; - $mailmap_info->{add}{"$name $raw_name"}++; - return 0; + $extra .= + "\nYou have configured the following relevant git config settings:\n\n" + . join("", + map { sprintf " %-16s = %s", split /\s+/, $_, 2 } @config) + . "\n"; } - elsif (!$mailmap_info->{$P2O}{$name}{$raw_name}) { - $mailmap_info->{add}{"$name $raw_name"}++; + else { + $extra .= + "\nYou do not have any git user config set up, consider using\n\n" + . " git config user.name 'Your Name'\n" + . " git config user.email 'your\@email.com'\n\n"; } - return 1; -} -sub check_fix_mailmap_hash { - my ($mailmap_hash, $authors_info)= @_; - my $parsed= parse_mailmap_hash($mailmap_hash); - my @fixed; - my %seen_map; - my %pref_groups; - - # first pass through the data, do any conversions, eg, LC - # the email address, decode any MIME-Header style email addresses. - # We also correct any preferred name entries so they match what - # we already have in AUTHORS, and check that there aren't collisions - # or other issues in the data. - foreach my $rec (@$parsed) { - my ($pname, $pemail, $oname, $oemail, $line_num)= @$rec; - $pemail= lc($pemail); - $oemail= lc($oemail) if defined $oemail; - if ($pname =~ /=\?UTF-8\?/) { - $pname= decode("MIME-Header", $pname); - } - my $auth_email= $authors_info->{"name2email"}{$pname}; - if ($auth_email) { - ## this name exists in authors, so use its email data for pemail - $pemail= $auth_email; - } - my $auth_name= $authors_info->{"email2name"}{$pemail}; - if ($auth_name) { - ## this email exists in authors, so use its name data for pname - $pname= $auth_name; - } + my $props= ""; + if ( $author_name ne $committer_name + or $author_email ne $committer_email) + { + $props .= < - # where there is a corresponding - # Joe Joe X - foreach my $pref (_sorted_hash_keys(\%pref_groups)) { - my $entries= $pref_groups{$pref}; - foreach my $email (_sorted_hash_keys($entries)) { - my @names= _sorted_hash_keys($entries->{$email}); - if ($names[0] eq "" and @names > 1) { - shift @names; - } - foreach my $name (@names) { - push @fixed, $entries->{$email}{$name}; - } - } } + else { + $props .= <" : "<$oemail>"; - } - if ($other and $other ne "") { - _safe_set_key($mailmap_info, $O2P, $other, $preferred); - _safe_set_key($mailmap_info, $O2PN, $other, $pname); - _safe_set_key($mailmap_info, $O2PE, $other, $pemail); - } - $mailmap_info->{$P2O}{$preferred}{$other}++; - if ($pname ne "unknown") { - _safe_set_key($mailmap_info, $N2P, $pname, $preferred); - } - if ($pemail ne "unknown") { - _safe_set_key($mailmap_info, $E2P, $pemail, $preferred); - } - my $line= $preferred; - $line .= " $other" if $other; - $new_mailmap_hash->{$line}= $line_num; + Name = $author_name + Email = $author_email +EOF_PROPS } - return ($new_mailmap_hash, $mailmap_info); -} -sub add_new_mailmap_entries { - my ($mailmap_hash, $mailmap_info, $mailmap_file)= @_; + return encode_utf8 <<"EOF_MESAGE"; - my $mailmap_add= $mailmap_info->{add} - or return 0; +There are uncommitted changes in the working directory +$uncommitted_files +and your git credentials are new to us. We think that git thinks your +credentials are as follows (git may use defaults we don't guess +properly): +$props$extra +To resolve this you can perform one or more of these steps: - my $num= 0; - for my $new (sort keys %$mailmap_add) { - !$mailmap_hash->{$new}++ or next; - warn encode_utf8 "Updating '$mailmap_file' with: $new\n"; - $num++; - } - return $num; -} + 1. Remove the uncommitted changes, including untracked files that + show up in -sub read_and_update { - my ($authors_file, $mailmap_file)= @_; + git status - # read the authors file and extract the info it contains - my ($author_info, $authors_preamble)= read_authors($authors_file); + if you wish to REMOVE UNTRACKED FILES and DELETE ANY CHANGES + you can - # read the mailmap file. - my ($orig_mailmap_hash, $mailmap_preamble)= read_mailmap($mailmap_file); + git clean -dfx + git checkout -f - # check and possibly fix the mailmap data, and build a set of precomputed - # datasets to work with it. - my ($mailmap_hash, $mailmap_info)= - check_fix_mailmap_hash($orig_mailmap_hash, $author_info); + BE WARNED: THIS MAY LOSE DATA. - # update the mailmap based on any check or fixes we just did, - # we always write even if we did not do any changes. - update_mailmap($mailmap_hash, $mailmap_preamble, $mailmap_file); + 2. You are already configured in git and you just need to add + yourself to AUTHORS and other infra: commit the changes in the + working directory, including any untracked files that you plan to + add (the rest should be removed), and then run - # read the commits names using git log, and compares and checks - # them against the data we have in authors. - read_commit_log($author_info, $mailmap_info); + Porting/updateAUTHORS.pl - # update the authors file with any changes, we always write, - # but we may not change anything - update_authors($author_info, $authors_preamble, $authors_file); + to update the AUTHORS and .mailmap files automatically. Inspect + the changes it makes and then commit them once you are + satisfied. This is your option to decide who you will be known + as in the future! - # check if we discovered new email data from the commits that - # we need to write back to disk. - add_new_mailmap_entries($mailmap_hash, $mailmap_info, $mailmap_file) - and update_mailmap($mailmap_hash, $mailmap_preamble, - $mailmap_file, $mailmap_info); + 3. You are already a contributor to the project but you are committing + changes on behalf of someone who is new. Run - return undef; -} + Porting/updateAUTHORS.pl -sub main { - local $Data::Dumper::Sortkeys= 1; - my $authors_file= "AUTHORS"; - my $mailmap_file= ".mailmap"; - my $show_man= 0; - my $show_help= 0; + to update the AUTHORS and .mailmap files automatically. Inspect + the changes it makes and then commit them once you are satisfied. + Make sure the conributor is ok with the decisions you make before + you merge. - ## Parse options and print usage if there is a syntax error, - ## or if usage was explicitly requested. - GetOptions( - 'help|?' => \$show_help, - 'man' => \$show_man, - 'authors_file|authors-file=s' => \$authors_file, - 'mailmap_file|mailmap-file=s' => \$mailmap_file, - ) or pod2usage(2); - pod2usage(1) if $show_help; - pod2usage(-verbose => 2) if $show_man; + 3. You are already an author but your git config is broken or + different from what you expect, or you are a new author but you + havent configured your git details properly, in which case you + can use something like the following commands: - read_and_update($authors_file, $mailmap_file); - return 0; # 0 for no error - intended for exit(); -} + git config user.name "Some Name" + git config user.email "somewhere\@provider" -exit(main()) unless caller; + If you are known to the project already this is all you need to + do. If you are not then you should perform option 2 or 4 as well + afterwards. + + 4. You do not want to be listed in AUTHORS: commit the changes, + including any untracked unignored files, and then run + + Porting/updateAUTHORS.pl --exclude + and commit the changes it creates. This test should pass once + those commits are created. Thank you for your contributions. +EOF_MESAGE +} 1; __END__ =head1 NAME -Porting/updateAUTHORS.pl - Automatically update AUTHORS and .mailmap -based on commit data. +F - Automatically update F and F<.mailmap> +and F based on commit data. =head1 SYNOPSIS -Porting/updateAUTHORS.pl +Porting/updateAUTHORS.pl [OPTIONS] [GIT_REF_RANGE] + +By default scans the commit history specified (or the entire history from the +current commit) and then updates F and F<.mailmap> so all contributors +are properly listed. Options: --help brief help message --man full documentation - --authors-file=FILE override default location of AUTHORS - --mailmap-file=FILE override default location of .mailmap + --verbose be verbose + + Commit Range: + --from=GIT_REF Select commits to use + --to=GIT_REF Select commits to use, defaults to HEAD + + File Locations: + --authors-file=FILE override default of 'AUTHORS' + --mailmap-file=FILE override default of '.mailmap' + + Action Modifiers + --no-update Do not update. + --validate output TAP about status and change nothing + --exclude-missing Add new names to the exclude file so they never + appear in AUTHORS or .mailmap. + + Details Changes + Update canonical name or email in AUTHORS and .mailmap properly. + --exclude-contrib NAME_AND_EMAIL + --exclude-me + --change-name OLD_NAME=NEW_NAME + --change-name-for-email OLD_ADDR=NEW_NAME + --change-email-for-name OLD_NAME=NEW_ADDR + --change-email OLD_ADDR=NEW_EMAIL + + Reports About People + --stats detailed report of authors and what they did + --who Sorted, wrapped list of who did what + --thanks-applied report who applied stuff for others + --rank report authors by number of commits created + + Reports About Files + --files detailed report files that were modified + --activity simple report of files that grew the most + --chainsaw simple report of files that shrank the most + + Report Modifiers + --percentage show percentages not counts + --cumulative show cumulative numbers not individual + --reverse show reports in reverse order + --numstat show additional file based data in some reports + (not needed for most reports) + --as-list show reports with names with common values + folded into a list like checkAUTHORS.pl used to + --numbered add rank numbers to reports where they are missing =head1 OPTIONS =over 4 -=item --help +=item C<--help> Print a brief help message and exits. -=item --man +=item C<--man> Prints the manual page and exits. -=item --authors-file=FILE +=item C<--verbose> + +Be verbose about what is happening. Can be repeated more than once. + +=item C<--no-update> + +Do not update files on disk even if they need to be changed. + +=item C<--validate> + +=item C<--tap> + +Instead of modifying files, test to see which would be modified and +output TAP test output about the validation. + +=item C<--authors-file=FILE> + +=item C<--authors_file=FILE> + +Override the default location of the authors file, which is by default +the F file in the current directory. + +=item C<--mailmap-file=FILE> + +=item C<--mailmap_file=FILE> + +Override the default location of the mailmap file, which is by default +the F<.mailmap> file in the current directory. + +=item C<--exclude-file=FILE> + +=item C<--exclude_file=FILE> + +Override the default location of the exclude file, which is by default +the F file reachable from the current +directory. + +=item C<--exclude-contrib=NAME_AND_EMAIL> + +=item C<--exclude_contrib=NAME_AND_EMAIL> + +Exclude a specific name/email combination from our contributor datasets. +Can be repeated multiple times on the command line to remove multiple +items at once. If the contributor details correspond to a canonical +identity of a contributor (one that is in the AUTHORS file or on the +left in the .mailmap file) then ALL records, including those linked to +that identity in .mailmap will be marked for exclusion. This is similar +to C<--exclude-missing> but it only affects the specifically named +users. Note that the format for NAME_AND_EMAIL is similar to that of the +.mailmap file, email addresses and C< @github > style identifiers should +be wrapped in angle brackets like this: C<< <@github> >>, users with no +email in the AUTHORS file should use C<< >>. + +For example: + + Porting/updateAUTHORS.pl --exclude-contrib="Joe B " + +Would remove all references to "Joe B" from F and F<.mailmap> +and add the required entires to F such that +the contributor would never be automatically added back, and would be +automatically removed should someone read them manually. + +=item C<--exclude-missing> + +=item C<--exclude_missing> + +=item C<--exclude> -=item --authors_file=FILE +Normally when the tool is run it *adds* missing data only. If this +option is set then the reverse will happen, any author data missing will +be marked as intentionally missing in such a way that future "normal" +runs of the script ignore the author(s) that were excluded. -Override the default location of the authors file, which is "AUTHORS" in -the current directory. +The exclude data is stored in F as a SHA256 +digest (in base 64) of the user name and email being excluded so that +the list itself doesnt contain the contributor details in plain text. -=item --mailmap-file=FILE +The general idea is that if you want to remove someone from F +and F<.mailmap> you delete their details manually, and then run this +tool with the C<--exclude> option. It is probably a good idea to run it +first without any arguments to make sure you dont exclude something or +someone you did not intend to. -=item --mailmap_file=FILE +=item C<--stats> -Override the default location of the mailmap file, which is ".mailmap" -in the current directory. +Show detailed stats about committers and the work they did in a tabular +form. If the C<--numstat> option is provided this report will provide +additional data about the files a developer worked on. May be slow the +first time it is used as git unpacks the relevant data. + +=item C<--who> + +Show a list of which committers and authors contributed to the project +in the selected range of commits. The list will contain the name only, +and will sorted according to unicode collation rules. This list is +suitable in release notes and similar contexts. + +=item C<--thanks-applied> + +Show a report of which committers applied work on behalf of +someone else, including counts. Modified by the C<--as-list> and +C<--display-rank>. + +=item C<--rank> + +Shows a report of which commits did the most work. Modified by the +C<--as-list> and C<--display-rank> options. + +=item C<--files> + +Show detailed stats about the files that have been modified in the +selected range of commits. Implies C<--numstat>. May be slow the first +time it is used as git unpacks the relevant data. + +=item C<--activity> + +Show simple stats about which files had the most additions. Implies +C<--numstat>. May be slow the first time it is used as git unpacks the +relevant data. + + +=item C<--chainsaw> + +Show simple stats about whcih files had the most removals. Implies +C<--numstat>. May be slow the first time it is used as git unpacks the +relevant data. + +=item C<--percentage> + +Show numeric data as percentages of the total, not counts. + +=item C<--cumulative> + +Show numeric data as cumulative counts in the reports. + +=item C<--reverse> + +Show the reports in reverse order to normal. + +=item C<--numstat> + +Gather additional data about the files that were changed, not just the +authors who did the changes. This option currently is only necessary for +the C<--stats> option, which will display additional data when this +option is also provided. + +=item C<--as-list> + +Show the reports with name data rolled up together into a list like the +older checkAUTHORS.pl script would have. + +=item C<--numbered> + +Show an additional column with the rank number of a row in the report in +reports that do not normally show the rank number. + +=item C<--change-name OLD_NAME=NEW_NAME> + +=item C<--change-name-for-email OLD_EMAIL=NEW_NAME> + +=item C<--change-email OLD_EMAIL=NEW_EMAIL> + +=item C<--change-email-for-name OLD_NAME=NEW_EMAIL> + +Change email or name based on OLD_NAME or OLD_EMAIL. + +Eg, + + --change-name-for-email somebody@gmail.com="Bob Rob" + +would cause the preferred name for the person with the preferred email +C to change to "Bob Rob" in our records. If that +persons name was "Daniel Dude" then we might have done this as well: + + --change-name "Bob Rob"="Daniel Dude" =back =head1 DESCRIPTION -This program will automatically manage updates to the AUTHORS file and -.mailmap file based on the data in our commits and the data in the files -themselves. It uses no other sources of data. Expects to be run from -the root a git repo of perl. +This program will automatically manage updates to the F file +and F<.mailmap> file based on the data in our commits and the data in +the files themselves. It uses no other sources of data. Expects to be +run from the root directory of a git repo of perl. In simple, execute the script and it will either die with a helpful -message or it will update the files as necessary, possibly not at all if -there is no need to do so. Note it will actually rewrite the files at -least once, but it may not actually make any changes to their content. -Thus to use the script is currently required that the files are -modifiable. - -Review the changes it makes to make sure they are sane. If they are -commit. If they are not then update the AUTHORS or .mailmap files as is -appropriate and run the tool again. Typically you shouldn't need to do -either unless you are changing the default name or email for a user. For -instance if a person currently listed in the AUTHORS file whishes to -change their preferred name or email then change it in the AUTHORS file -and run the script again. I am not sure when you might need to directly -modify .mailmap, usually modifying the AUTHORS file should suffice. - -=head1 FUNCTIONS - -Note that the file can also be used as a package. If you require the -file then you can access the functions located within the package -C. These are as follows: +message or it will update the files as necessary, possibly not at all +if there is no need to do so. If the C<--validate> option is provided +the content will not be updated and instead the tool will act as a +test script validating that the F and F<.mailmap> files are +up to date. -=over 4 +By default the script operates on the *entire* history of Perl +development that is reachable from HEAD. This can be overriden by using +the C<--from> and C<--to> options, or providing a git commit range as an +argument after the options just like you might do with C. -=item add_new_mailmap_entries($mailmap_hash, $mailmap_info, $mailmap_file) +The script can also be used to produce various reports and other content +about the commits it has analyzed. -If any additions were identified while reading the commits this will -inject them into the mailmap_hash so they can be written out. Returns a -count of additions found. +=head2 ADDING A NEW CONTRIBUTOR -=item check_fix_mailmap_hash($mailmap_hash, $authors_info) +Commit your changes. Run the tool with no arguments. It will add +anything that is missing. Check the changes and then commit them. -Analyzes the data contained the in the .mailmap file and applies any -automated fixes which are required and which it can automatically -perform. Returns a hash of adjusted entries and a hash with additional -metadata about the mailmap entries. +=head2 CHANGING A CONTRIBUTORS CANONICAL NAME OR EMAIL -=item main() +Use the C<--change-name-for-name> and related options. This will do +things "properly" and update all the files. -This implements the command line version of this module, handle command -line options, etc. +=head2 A CONTRIBUTOR WANTS TO BE FORGOTTEN -=item merge_mailmap_with_AUTHORS_and_checkAUTHORS_data +There are several ways to do this: -This is a utility function that combines data from this tool with data -contained in F it is not used directly, but was -used to cleanup and generate the current version of the .mailmap file. +=over 2 -=item parse_mailmap_hash($mailmap_hash) +=item Manual Exclusion -Takes a mailmap_hash and parses it and returns it as an array of array -records with the contents: +Manually modify F and F<.mailmap> so the user detals are +removed and then run this tool with the C<--exclude> option. This should +result in various SHA-256 digests (in base64) being added to +F. Commit the changes afterwards. - [ $preferred_name, $preferred_email, - $other_name, $other_email, - $line_num ] +=item Exclude Yourself -=item read_and_update($authors_file, $mailmap_file) +Use the C<--exclude-me> option to the tool, review and commit the results. +This will use roughly the same rules that git would to figure out what your +name and email are. -Wraps the other functions in this library and implements the logic and -intent of this tool. Takes two arguments, the authors file name, and the -mailmap file name. Returns nothing but may modify the AUTHORS file -or the .mailmap file. Requires that both files are editable. +=item Exclude Someone Else -=item read_commit_log($authors_info, $mailmap_info) +Use the C<--exclude-contrib> option and specify their name and email. +For example -Read the commit log and find any new names it contains. + --exclude-contrib="Their Name " -=item read_authors($authors_file) +Should exclude the person with this name from our files. -Read the AUTHORS file and return data about it. +=back -=item read_mailmap($mailmap_file) +Note that excluding a person by canonical details (that is the details +in the F file) will result in their .mailmap'ed names being +excluded as well. Excluding a persons secondary account details will +simply block that specific email from being listed, and is likely not +what you want to do most of the time. -Read the .mailmap file and return data about it. +=head2 AFTER RUNNING THE TOOL -=item update_authors($authors_info, $authors_preamble, $authors_file) +Review the changes to make sure they are sane. If they are ok (and +they should be most of the time) commit. If they are not then update +the F or F<.mailmap> files as is appropriate and run the +tool again. -Write out an updated AUTHORS file. This is done atomically -using a rename, we will not leave a half modified file in -the repo. +Do not panic that your email details get added to F<.mailmap>, this is +by design so that your chosen name and email are displayed on GitHub and +in casual use of C and other C tooling. -=item update_mailmap($mm_hash, $mm_preamble, $mailmap_file, $mm_info) +=head1 RECIPES -Write out an updated .mailmap file. This is done atomically -using a rename, we will not leave a half modified file in -the repo. + perl Porting/updateAUTHORS.pl --who --from=v5.31.6 --to=v5.31.7 + perl Porting/updateAUTHORS.pl --who v5.31.6..v5.31.7 + perl Porting/updateAUTHORS.pl --rank --percentage --from=v5.31.6 + perl Porting/updateAUTHORS.pl --thanks-applied --from=v5.31.6 + perl Porting/updateAUTHORS.pl --tap --from=v5.31.6 + perl Porting/updateAUTHORS.pl --files --from=v5.31.6 + perl Porting/updateAUTHORS.pl --activity --from=v5.31.6 + perl Porting/updateAUTHORS.pl --chainsaw v5.31.6..HEAD + perl Porting/updateAUTHORS.pl --change-name "Old Name"="New Name" + perl Porting/updateAUTHORS.pl --change-name-for-email "x@y.com"="Name" + perl Porting/updateAUTHORS.pl --change-email-for-name "Name"="p@q.com" -=back +=head1 RELATED FILES + +F, F<.mailmap>, F =head1 TODO More documentation and testing. -=head1 SEE ALSO - -F - =head1 AUTHOR Yves Orton +=head1 THANKS + +Loosely based on the older F script which this tool +replaced. Thanks to the contributors of that tool. See the Perl change log. + =cut diff --git a/gnu/usr.bin/perl/Porting/updateAUTHORS.pm b/gnu/usr.bin/perl/Porting/updateAUTHORS.pm new file mode 100644 index 00000000000..266c547a0c8 --- /dev/null +++ b/gnu/usr.bin/perl/Porting/updateAUTHORS.pm @@ -0,0 +1,1377 @@ +package Porting::updateAUTHORS; +use strict; +use warnings; +use Data::Dumper; +use Encode qw(encode_utf8 decode_utf8 decode); +use Digest::SHA qw(sha256_base64); +use Text::Wrap qw(wrap); +use Unicode::Collate; +use feature 'fc'; +$Text::Wrap::columns= 80; + +# The style of this file is determined by: +# +# perltidy -w -ple -bbb -bbc -bbs -nolq -l=80 -noll -nola -nwls='=' \ +# -isbc -nolc -otr -kis -ci=4 -se -sot -sct -nsbl -pt=2 -fs \ +# -fsb='#start-no-tidy' -fse='#end-no-tidy' + +# Info and config for passing to git log. +# %an: author name +# %aN: author name (respecting .mailmap, see git-shortlog(1) or git-blame(1)) +# %ae: author email +# %aE: author email (respecting .mailmap, see git-shortlog(1) or git-blame(1)) +# %cn: committer name +# %cN: committer name (respecting .mailmap, see git-shortlog(1) or git-blame(1)) +# %ce: committer email +# %cE: committer email (respecting .mailmap, see git-shortlog(1) or git-blame(1)) +# %H: commit hash +# %h: abbreviated commit hash +# %s: subject +# %x00: print a byte from a hex code + +my %field_spec= ( + "an" => "author_name", + "aN" => "author_name_mm", + "ae" => "author_email", + "aE" => "author_email_mm", + "cn" => "committer_name", + "cN" => "committer_name_mm", + "ce" => "committer_email", + "cE" => "committer_email_mm", + "H" => "commit_hash", + "h" => "abbrev_hash", + "s" => "commit_subject", +); + +my $Collate= Unicode::Collate->new(level => 1, indentical => 1); +my @field_codes= sort keys %field_spec; +my @field_names= map { $field_spec{$_} } @field_codes; +my $tformat= "=" . join "%x09", map { "%" . $_ } @field_codes; + +sub _make_name_author_info { + my ($self, $commit_info, $name_key)= @_; + my $author_info= $self->{author_info}; + (my $email_key= $name_key) =~ s/name/email/; + my $email= $commit_info->{$email_key}; + my $name= $commit_info->{$name_key}; + + my $line= $author_info->{"email2line"}{$email} + // $author_info->{"name2line"}{ lc($name) }; + + $line //= sprintf "%-31s<%s>", + $commit_info->{$name_key}, $commit_info->{$email_key}; + $commit_info->{ $name_key . "_canon" }= $line; + return $line; +} + +sub _make_name_simple { + my ($self, $commit_info, $key)= @_; + my $name_key= $key . "_name"; + my $email_key= $key . "_email"; + return sprintf "%s <%s>", $commit_info->{$name_key}, + lc($commit_info->{$email_key}); +} + +sub __fold_trim_ws { + my ($munged)= @_; + $munged =~ s/\s+/ /g; + $munged =~ s/\A\s+//; + $munged =~ s/\s+\z//; + return $munged; +} + +sub _register_author { + my ($self, $name, $type)= @_; + + return if $self->_logical_exclude_author($name); + + my $digest= $self->_keeper_digest($name) + or return; + + $self->{who_stats}{$name}{$type}++; + + $self->{author_info}{"lines"}{$name} + and return; + + my $munged= __fold_trim_ws($name); + if ($self->{exclude_missing}) { + $self->_exclude_contrib($name, $digest); + } + else { + $self->{author_info}{"lines"}{$name}++; + + my $munged= __fold_trim_ws($name); + warn encode_utf8 sprintf + "New %s '%s' (%s) will be added to AUTHORS file.\n", + $type, $munged, $digest + if $self->{verbose}; + } +} + +sub git_conf_get { + my ($self, $setting)= @_; + chomp(my $value= `git config --get $setting`); + return decode_utf8 $value; +} + +sub current_git_user_name { + my ($self)= @_; + return $self->git_conf_get("user.name"); +} + +sub current_git_user_email { + my ($self)= @_; + return $self->git_conf_get("user.email"); +} + +sub current_git_name_email { + my ($self, $type)= @_; + my $name= + $ENV{"GIT_\U$type\E_NAME"} + || $self->git_conf_get("\L$type\E.name") + || $self->current_git_user_name(); + my $email= + $ENV{"GIT_\U$type\E_EMAIL"} + || $self->git_conf_get("\L$type\E.email") + || $self->current_git_user_email(); + return $name, $email; +} + +sub format_name_email { + my ($self, $name, $email)= @_; + return sprintf "%s <%s>", $name, $email; +} + +sub current_committer_name_email { + my ($self, $full)= @_; + my ($n, $e)= $self->current_git_name_email("committer"); + return $full ? $self->format_name_email($n, $e) : ($n, $e); +} + +sub current_author_name_email { + my ($self, $full)= @_; + my ($n, $e)= $self->current_git_name_email("author"); + return $full ? $self->format_name_email($n, $e) : ($n, $e); +} + +sub git_status_porcelain { + my ($self)= @_; + my $status= `git status --porcelain`; + return $status // ""; +} + +sub finalize_commit_info { + my ($self, $commit_info)= @_; + my $author= $commit_info->{author_name_mm_canon}; + my $author_stats= $self->{who_stats}{$author} ||= {}; + + my $file_info= $commit_info->{files} ||= {}; + foreach my $file (keys %{$file_info}) { + if (!$self->{file_stats}{$file}) { + $self->{summary_stats}{num_files}++; + } + my $fs= $self->{file_stats}{$file} ||= {}; + my $afs= $author_stats->{file_stats}{$file} ||= {}; + my $added= $file_info->{$file}{lines_added}; + my $removed= $file_info->{$file}{lines_removed}; + my $delta= $file_info->{$file}{lines_delta}; + defined $_ and $_ eq "-" and undef $_ for $added, $removed; + + if (defined $added) { + for my $h ($author_stats, $fs, $afs) { + $h->{lines_delta} += $delta; + $h->{lines_added} += $added; + $h->{lines_removed} += $removed; + } + } + else { + $author_stats->{binary_change}++; + $fs->{binary_change}++; + $afs->{binary_change}++; + } + $afs->{commits}++ + or $author_stats->{num_files}++; + + $fs->{commits}++ + or $self->{summary_stats}{num_files}++; + + $fs->{who}{$author}++ + or $self->{summary_stats}{authors}++; + } +} + +sub read_commit_log { + my ($self)= @_; + my $author_info= $self->{author_info} ||= {}; + my $mailmap_info= $self->{mailmap_info} ||= {}; + + my $commits_read= 0; + my @args= ("--pretty='format:$tformat'"); + push @args, "--numstat" if $self->{numstat}; + push @args, "'$self->{commit_range}'" if $self->{commit_range}; + + my $last_commit_info; + my $cmd= qq(git -c diff.algorithm=myers log @args); + $cmd =~ s/'/"/g if $^O =~ /Win/; + open my $fh, "-|", $cmd + or die "Failed to open git log pipe: $!"; + binmode($fh); + while (defined(my $line= <$fh>)) { + chomp $line; + $line= decode_utf8($line); + if ($line =~ s/^=//) { + $self->finalize_commit_info($last_commit_info) + if $last_commit_info; + } + elsif ($line =~ /\S/) { + my ($added, $removed, $file)= split /\s+/, $line; + if ($added ne "-") { + $last_commit_info->{files}{$file}= { + lines_added => $added, + lines_removed => $removed, + lines_delta => $added - $removed, + }; + } + else { + $last_commit_info->{files}{$file}{binary_changes}++; + } + next; + } + else { + # whitspace only or empty line + next; + } + $commits_read++; + my $commit_info= {}; + $last_commit_info= $commit_info; + @{$commit_info}{@field_names}= split /\t/, $line, 0 + @field_names; + + my $author_name_mm_canon= + $self->_make_name_author_info($commit_info, "author_name_mm"); + + my $committer_name_mm_canon= + $self->_make_name_author_info($commit_info, "committer_name_mm"); + + my $author_name_real= $self->_make_name_simple($commit_info, "author"); + + my $committer_name_real= + $self->_make_name_simple($commit_info, "committer"); + + my ($author_good, $committer_good); + + if ( $self->_keeper_digest($author_name_mm_canon) + && $self->_keeper_digest($author_name_real)) + { + $self->_check_name_mailmap($author_name_mm_canon, $author_name_real, + $commit_info, "author name"); + $self->_register_author($author_name_mm_canon, "author"); + $author_good= 1; + } + + if ( $self->_keeper_digest($committer_name_mm_canon) + && $self->_keeper_digest($committer_name_real)) + { + $self->_check_name_mailmap($committer_name_mm_canon, + $committer_name_real, $commit_info, "committer name"); + $self->_register_author($committer_name_mm_canon, "committer"); + $committer_good= 1; + } + if ( $author_good + and $committer_good + and $committer_name_mm_canon ne $author_name_mm_canon) + { + $self->{who_stats}{$committer_name_mm_canon}{applied}++; + } + } + $self->finalize_commit_info($last_commit_info) if $last_commit_info; + if (!$commits_read) { + if ($self->{commit_range}) { + die "No commits in range '$self->{commit_range}'\n"; + } + else { + die "Panic! There are no commits!\n"; + } + } + return $author_info; +} + +sub dupe_info { + my ($self)= @_; + my $msg= ""; + foreach my $type (sort keys %{ $self->{dupe} || {} }) { + $msg .= "Duplicate \u$type in $self->{authors_file}:\n"; + foreach my $key (sort keys %{ $self->{dupe}{$type} }) { + $msg .= " \u$type '$key'\n"; + foreach my $line (sort keys %{ $self->{dupe}{$type}{$key} }) { + $msg .= " $line\n"; + } + } + } + return $msg; +} + +sub read_authors_file { + my ($self)= @_; + my $authors_file= $self->{authors_file}; + + my @authors_preamble; + open my $in_fh, "<", $authors_file + or die "Failed to open for read '$authors_file': $!"; + my $raw_text= ""; + my $found_sep= 0; + while (defined(my $line= <$in_fh>)) { + $raw_text .= $line; + $line= decode_utf8($line); + chomp $line; + push @authors_preamble, $line; + if ($line =~ /^--/) { + $found_sep= 1; + last; + } + } + if (!$found_sep) { + die sprintf <<'EOFMT', $authors_file; +Possibly corrupted authors file '%s'. + +There should be a big '#' comment block at the start of the file +followed by "--" followed by a list of names and email/contact +details. We couldn't find the separator. Where did it go? + +Cowardly refusing to continue until this is fixed. +EOFMT + } + my %author_info; + while (defined(my $line= <$in_fh>)) { + $raw_text .= $line; + $line= decode_utf8($line); + chomp $line; + my ($name, $email); + my $copy= $line; + $copy =~ s/\s+\z//; + if ($copy =~ s/<([^<>]*)>//) { + $email= $1; + } + elsif ($copy =~ s/\s+(\@\w+)\z//) { + $email= $1; + } + $copy =~ s/\s+\z//; + $name= $copy; + $email //= "unknown"; + my $orig_name= $name; + my $orig_email= $email; + if (my $new_name= $self->{change_name_for_name}{$orig_name}) { + $name= $new_name; + } + if (my $new_name= $self->{change_name_for_email}{$orig_email}) { + $name= $new_name; + } + if (my $new_email= $self->{change_email_for_name}{$orig_name}) { + $email= $new_email; + } + if (my $new_email= $self->{change_email_for_email}{$orig_email}) { + $email= $new_email; + } + $line= sprintf "%-31s%s", $name, $email =~ /^\@/ ? $email : "<$email>"; + $line =~ s/\s+\z//; + $email= lc($email); + + $line =~ s/\s+\z//; + $author_info{"lines"}{$line}++; + if ($email and $email ne "unknown") { + if (my $other= $author_info{"email2line"}{$email}) { + $self->{dupe}{email}{$email}{$other}= 1; + $self->{dupe}{email}{$email}{$line}= 1; + } + else { + $author_info{"email2line"}{$email}= $line; + } + } + if ($name and $name ne "unknown") { + if (my $other= $author_info{"name2line"}{ lc($name) }) { + $self->{dupe}{name}{$name}{$other}= 1; + $self->{dupe}{name}{$name}{$line}= 1; + } + else { + $author_info{"name2line"}{ lc($name) }= $line; + } + } + $author_info{"email2name"}{$email} //= $name + if $email + and $name + and $email ne "unknown"; + $author_info{"name2email"}{$name} //= $email + if $name and $name ne "unknown"; + $author_info{"clean_full"}{ __fold_trim_ws($line) }= $line; + } + close $in_fh + or die "Failed to close '$authors_file': $!"; + + $self->{author_info}= \%author_info; + $self->{authors_preamble}= \@authors_preamble; + $self->{authors_raw_text}= $raw_text; + return (\%author_info, \@authors_preamble, $raw_text); +} + +sub update_authors_file { + my ($self)= @_; + + my $author_info= $self->{author_info}; + my $authors_preamble= $self->{authors_preamble}; + my $authors_file= $self->{authors_file}; + my $old_raw_text= $self->{authors_raw_text}; + + my $authors_file_new= $authors_file . ".new"; + my $new_raw_text= ""; + { + open my $out_fh, ">", \$new_raw_text + or die "Failed to open scalar buffer for write: $!"; + foreach my $line (@$authors_preamble) { + print $out_fh encode_utf8($line), "\n" + or die "Failed to print to scalar buffer handle: $!"; + } + foreach my $author (__sorted_hash_keys($author_info->{"lines"})) { + next if $self->_logical_exclude_author($author); + my $author_mm= $self->_author_to_mailmap($author); + if (!$self->_keeper_digest($author_mm)) { + next; + } + print $out_fh encode_utf8($author), "\n" + or die "Failed to print to scalar buffer handle: $!"; + } + close $out_fh + or die "Failed to close scalar buffer handle: $!"; + } + if ($new_raw_text ne $old_raw_text) { + $self->{changed_count}++; + $self->_log_file_changes_quick_and_dirty_diff($authors_file, + $old_raw_text, $new_raw_text); + + if ($self->{no_update}) { + return 1; + } + + warn "Updating '$authors_file'\n" if $self->{verbose}; + + open my $out_fh, ">", $authors_file_new + or die "Failed to open for write '$authors_file_new': $!"; + binmode $out_fh; + print $out_fh $new_raw_text; + close $out_fh + or die "Failed to close '$authors_file_new': $!"; + rename $authors_file_new, $authors_file + or die + "Failed to rename '$authors_file_new' to '$authors_file': $!"; + return 1; + } + else { + return 0; + } +} + +sub read_mailmap_file { + my ($self)= @_; + my $mailmap_file= $self->{mailmap_file}; + + open my $in, "<", $mailmap_file + or die "Failed to read '$mailmap_file': $!"; + my %mailmap_hash; + my @mailmap_preamble; + my $line_num= 0; + my $raw_text= ""; + while (defined(my $line= <$in>)) { + $raw_text .= $line; + $line= decode_utf8($line); + ++$line_num; + next unless $line =~ /\S/; + chomp($line); + if ($line =~ /^#/) { + if (!keys %mailmap_hash) { + push @mailmap_preamble, $line; + } + else { + die encode_utf8 "Not expecting comments after header ", + "finished at line $line_num!\nLine: $line\n"; + } + } + else { + $mailmap_hash{$line}= $line_num; + } + } + close $in + or die "Failed to close '$mailmap_file' after reading: $!"; + if (!@mailmap_preamble) { + die sprintf <<'EOFMT', $mailmap_file; +Possibly corrupted mailmap file '%s'. + +This file should have a preamble of '#' comments in it. + +Where did they go? + +Cowardly refusing to continue until this is fixed. +EOFMT + } + $self->{orig_mailmap_hash}= \%mailmap_hash; + $self->{mailmap_preamble}= \@mailmap_preamble; + $self->{mailmap_raw_text}= $raw_text; + return (\%mailmap_hash, \@mailmap_preamble, $raw_text); +} + +sub __sorted_hash_keys { + my ($hash)= @_; + return __sort_names(keys %$hash); +} + +sub __sort_names { + my @sorted= sort { fc($a) cmp fc($b) || $a cmp $b } @_; + return @sorted; +} + +# Returns 0 if the file needed to be changed, Return 1 if it does not. +sub update_mailmap_file { + my ($self)= @_; + my $mailmap_hash= $self->{new_mailmap_hash}; + my $mailmap_preamble= $self->{mailmap_preamble}; + my $mailmap_file= $self->{mailmap_file}; + my $old_raw_text= $self->{mailmap_raw_text}; + + my $new_raw_text= ""; + { + open my $out, ">", \$new_raw_text + or die "Failed to open scalar buffer for write: $!"; + foreach + my $line (@$mailmap_preamble, __sorted_hash_keys($mailmap_hash),) + { + next if $line =~ m!\A(.*) \1\z!; + print $out encode_utf8($line), "\n" + or die "Failed to print to scalar buffer handle: $!"; + } + close $out + or die "Failed to close scalar buffer handle: $!"; + } + if ($new_raw_text ne $old_raw_text) { + $self->{changed_count}++; + $self->_log_file_changes_quick_and_dirty_diff($mailmap_file, + $old_raw_text, $new_raw_text); + + if ($self->{no_update}) { + return 1; + } + + warn "Updating '$mailmap_file'\n" + if $self->{verbose}; + + my $mailmap_file_new= $mailmap_file . ".new"; + open my $out, ">", $mailmap_file_new + or die "Failed to write '$mailmap_file_new': $!"; + binmode $out + or die "Failed to binmode '$mailmap_file_new': $!"; + print $out $new_raw_text + or die "Failed to print to '$mailmap_file_new': $!"; + close $out + or die "Failed to close '$mailmap_file_new' after writing: $!"; + rename $mailmap_file_new, $mailmap_file + or die + "Failed to rename '$mailmap_file_new' to '$mailmap_file': $!"; + return 1; + } + else { + return 0; + } +} + +sub parse_orig_mailmap_hash { + my ($self)= @_; + my $mailmap_hash= $self->{orig_mailmap_hash}; + + my @recs; + foreach my $line (__sorted_hash_keys($mailmap_hash)) { + my $line_num= $mailmap_hash->{$line}; + $line =~ /^ \s* (?: ( [^<>]*? ) \s+ )? <([^<>]*)> + (?: \s+ (?: ( [^<>]*? ) \s+ )? <([^<>]*)> )? \s* \z /x + or die encode_utf8 + "Failed to parse '$self->{mailmap_file}' line num $line_num: '$line'\n"; + if (!$1 or !$2) { + die encode_utf8 "Both preferred name and email are mandatory ", + "in line num $line_num: '$line'"; + } + my ($name, $email, $other_name, $other_email)= ($1, $2, $3, $4); + my ($orig_name, $orig_email)= ($1, $2); + if (my $new_name= $self->{change_name_for_name}{$orig_name}) { + $name= $new_name; + } + if (my $new_name= $self->{change_name_for_email}{$orig_email}) { + $name= $new_name; + } + if (my $new_email= $self->{change_email_for_name}{$orig_name}) { + $email= $new_email; + } + if (my $new_email= $self->{change_email_for_email}{$orig_email}) { + $email= $new_email; + } + + push @recs, [ $name, $email, $other_name, $other_email, $line_num ]; + } + return \@recs; +} + +sub _safe_set_key { + my ($self, $hash, $root_key, $key, $val, $pretty_name)= @_; + $hash->{$root_key}{$key} //= $val; + my $prev= $hash->{$root_key}{$key}; + if ($prev ne $val) { + die encode_utf8 "Collision on mapping $root_key: " + . " '$key' maps to '$prev' and '$val'\n"; + } +} + +my $O2P= "other2preferred"; +my $O2PN= "other2preferred_name"; +my $O2PE= "other2preferred_email"; +my $P2O= "preferred2other"; +my $N2P= "name2preferred"; +my $E2P= "email2preferred"; + +my $blurb= ""; # FIXME - replace with a nice message + +sub known_contributor { + my ($self, $name, $email)= @_; + if (!$name or !$email) { return 0 } + my $combined= "$name <$email>"; + return (( + $self->{mailmap_info}{$O2P}{$combined} + && $self->_keeper_digest($combined) + ) ? 1 : 0 + ); +} + +sub _check_name_mailmap { + my ($self, $auth_name, $raw_name, $commit_info, $descr)= @_; + my $mailmap_info= $self->{mailmap_info}; + + my $name= $self->_author_to_mailmap($auth_name); + + my $digest= $self->_keeper_digest($name) + or return 1; # known but ignore + + my $name_info= $mailmap_info->{$P2O}{$name}; + + if (!$name_info || !$name_info->{$raw_name}) { + if ($self->{exclude_missing}) { + $self->_exclude_contrib($name, $digest); + } + else { + $mailmap_info->{add}{"$name $raw_name"}++; + + warn encode_utf8 sprintf + "Unknown %s '%s' in commit %s '%s'\n%s", + $descr, + $name, + $commit_info->{"abbrev_hash"}, + $commit_info->{"commit_subject"}, $blurb + if $self->{verbose}; + } + return 0; + } + return 1; +} + +sub _author_to_mailmap { + my ($self, $name)= @_; + $name =~ s/<([^<>]+)>/<\L$1\E>/ + or $name =~ s/(\s)(\@\w+)\z/$1<\L$2\E>/ + or $name .= " "; + + $name= __fold_trim_ws($name); + return $name; +} + +sub check_fix_mailmap_hash { + my ($self)= @_; + my $orig_mailmap_hash= $self->{orig_mailmap_hash}; + my $author_info= $self->{author_info}; + foreach my $key (keys %{ $author_info->{clean_full} }) { + $key .= " " + unless $key =~ /\s+(?:<[^>]+>|\@\w+)\z/; + $key =~ s/\s+(\@\w+)\z/ <$1>/; + $orig_mailmap_hash->{"$key $key"} //= -1; + } + my $parsed= $self->parse_orig_mailmap_hash(); + my @fixed; + my %seen_map; + my %pref_groups; + + my $remove_no_names_with_overlaps= 0; + + # first pass through the data, do any conversions, eg, LC + # the email address, decode any MIME-Header style email addresses. + # We also correct any preferred name entries so they match what + # we already have in AUTHORS, and check that there aren't collisions + # or other issues in the data. + foreach my $rec (@$parsed) { + my ($pname, $pemail, $oname, $oemail, $line_num)= @$rec; + $pemail= lc($pemail); + $oemail= lc($oemail) if defined $oemail; + if ($pname =~ /=\?UTF-8\?/) { + $pname= decode("MIME-Header", $pname); + } + my $auth_email= $author_info->{"name2email"}{$pname}; + if ($auth_email) { + ## this name exists in authors, so use its email data for pemail + $pemail= $auth_email; + } + my $auth_name= $author_info->{"email2name"}{$pemail}; + if ($auth_name) { + ## this email exists in authors, so use its name data for pname + $pname= $auth_name; + } + + # neither name nor email exist in authors. + if ($pname ne "unknown") { + if (my $email= $seen_map{"name"}{$pname}) { + ## we have seen this pname before, check the pemail + ## is consistent + if ($email ne $pemail) { + warn encode_utf8 "Inconsistent emails for name '$pname'" + . " at line num $line_num: keeping '$email'," + . " ignoring '$pemail'\n"; + $pemail= $email; + } + } + else { + $seen_map{"name"}{$pname}= $pemail; + } + } + if ($pemail ne "unknown") { + if (my $name= $seen_map{"email"}{$pemail}) { + ## we have seen this preferred_email before, check the preferred_name + ## is consistent + if ($name ne $pname) { + warn encode_utf8 "Inconsistent name for email '$pemail'" + . " at line num $line_num: keeping '$name', ignoring" + . " '$pname'\n"; + $pname= $name; + } + } + else { + $seen_map{"email"}{$pemail}= $pname; + } + } + + my $rec= [ $pname, $pemail, $oname, $oemail, $line_num ]; + if ($remove_no_names_with_overlaps) { + + # Build an index of "preferred name/email" to other-email, other name + # we use this later to remove redundant entries missing a name. + $pref_groups{"$pname $pemail"}{$oemail}{ $oname || "" }= $rec; + } + else { + push @fixed, $rec; + } + } + + if ($remove_no_names_with_overlaps) { + + # this removes entries like + # Joe + # where there is a corresponding + # Joe Joe X + foreach my $pref (__sorted_hash_keys(\%pref_groups)) { + my $entries= $pref_groups{$pref}; + foreach my $email (__sorted_hash_keys($entries)) { + my @names= __sorted_hash_keys($entries->{$email}); + if (0 and $names[0] eq "" and @names > 1) { + shift @names; + } + foreach my $name (@names) { + push @fixed, $entries->{$email}{$name}; + } + } + } + } + + # final pass through the dataset, build up a database + # we will use later for checks and updates, and reconstruct + # the canonical entries. + my $new_mailmap_hash= {}; + my $mailmap_info= {}; + foreach my $rec (@fixed) { + my ($pname, $pemail, $oname, $oemail, $line_num)= @$rec; + my $preferred= "$pname <$pemail>"; + my $other; + if (defined $oemail) { + $other= $oname ? "$oname <$oemail>" : "<$oemail>"; + } + if (!$self->_keeper_digest($preferred)) { + $self->_exclude_contrib($other); + next; + } + elsif (!$self->_keeper_digest($other)) { + next; + } + if ($other and $other ne "") { + $self->_safe_set_key($mailmap_info, $O2P, $other, $preferred); + $self->_safe_set_key($mailmap_info, $O2PN, $other, $pname); + $self->_safe_set_key($mailmap_info, $O2PE, $other, $pemail); + } + $mailmap_info->{$P2O}{$preferred}{$other}++; + if ($pname ne "unknown") { + $self->_safe_set_key($mailmap_info, $N2P, $pname, $preferred); + } + if ($pemail ne "unknown") { + $self->_safe_set_key($mailmap_info, $E2P, $pemail, $preferred); + } + my $line= $preferred; + $line .= " $other" if $other; + $new_mailmap_hash->{$line}= $line_num; + } + $self->{new_mailmap_hash}= $new_mailmap_hash; + $self->{mailmap_info}= $mailmap_info; + return ($new_mailmap_hash, $mailmap_info); +} + +sub add_new_mailmap_entries { + my ($self)= @_; + my $mailmap_hash= $self->{new_mailmap_hash}; + my $mailmap_info= $self->{mailmap_info}; + my $mailmap_file= $self->{mailmap_file}; + + my $mailmap_add= $mailmap_info->{add} + or return 0; + + my $num= 0; + for my $new (__sorted_hash_keys($mailmap_add)) { + !$mailmap_hash->{$new}++ or next; + warn encode_utf8 "Updating '$mailmap_file' with: $new\n" + if $self->{verbose}; + $num++; + } + return $num; +} + +sub read_and_update { + my ($self)= @_; + my ($authors_file, $mailmap_file)= + %{$self}{qw(authors_file mailmap_file)}; + + # read the authors file and extract the info it contains + $self->read_authors_file(); + + # read the mailmap file. + $self->read_mailmap_file(); + + # check and possibly fix the mailmap data, and build a set of precomputed + # datasets to work with it. + $self->check_fix_mailmap_hash(); + + # update the mailmap based on any check or fixes we just did. + $self->update_mailmap_file(); + + # read the commits names using git log, and compares and checks + # them against the data we have in authors. + $self->read_commit_log(); + + # update the authors file with any changes + $self->update_authors_file(); + + # check if we discovered new email data from the commits that + # we need to write back to disk. + $self->add_new_mailmap_entries() + and $self->update_mailmap_file(); + + $self->update_exclude_file(); + + return $self->changed_count(); +} + +sub read_exclude_file { + my ($self)= @_; + my $exclude_file= $self->{exclude_file}; + my $exclude_digest= $self->{exclude_digest} ||= {}; + + open my $in_fh, "<", $exclude_file + or do { + warn "Failed to open '$exclude_file': $!"; + return; + }; + my $head= ""; + my $orig= ""; + my $seen_data= 0; + while (defined(my $line= <$in_fh>)) { + $orig .= $line; + if ($line =~ /^\s*#/ || $line !~ /\S/) { + $head .= $line unless $seen_data; + next; + } + else { + $seen_data= 1; + } + chomp($line); + $line =~ s/\A\s+//; + $line =~ s/\s*(?:#.*)?\z//; + $exclude_digest->{$line}++ if length($line); + } + close $in_fh + or die "Failed to close '$exclude_file' after reading: $!"; + if (!$head) { + die sprintf <<'EOFMT', $exclude_file; +Possibly corrupted exclude file '%s'. + +This file should have a header of '#' comments in it. + +Where did they go? + +Cowardly refusing to continue until this is fixed. +EOFMT + } + $self->{exclude_file_text_head}= $head; + $self->{exclude_file_text_orig}= $orig; + + return $exclude_digest; +} + +sub update_exclude_file { + my ($self)= @_; + my $exclude_file= $self->{exclude_file}; + my $exclude_text= $self->{exclude_file_text_head}; + foreach my $digest (__sorted_hash_keys($self->{exclude_digest})) { + $exclude_text .= "$digest\n"; + } + if ($exclude_text ne $self->{exclude_file_text_orig}) { + $self->{changed_count}++; + $self->_log_file_changes_quick_and_dirty_diff($exclude_file, + $self->{exclude_file_text_orig}, + $exclude_text); + + if ($self->{no_update}) { + return 1; + } + + warn "Updating '$exclude_file'\n" if $self->{verbose}; + + my $tmp_file= "$exclude_file.new"; + open my $out_fh, ">", $tmp_file + or die "Cant open '$tmp_file' for write $!"; + print $out_fh $exclude_text + or die "Failed to print to '$tmp_file': $!"; + close $out_fh + or die "Failed to close '$tmp_file' after writing: $!"; + rename $tmp_file, $exclude_file + or die "Failed to rename '$tmp_file' to '$exclude_file': $!"; + + return 1; + } + else { + return 0; + } +} + +sub changed_count { + my ($self)= @_; + return $self->{changed_count}; +} + +sub changed_file { + my ($self, $name)= @_; + return $self->{changed_file}{$name}; +} + +sub unchanged_file { + my ($self, $name)= @_; + return $self->changed_file($name) ? 0 : 1; +} + +sub new { + my ($class, %self)= @_; + $self{changed_count}= 0; + for my $name (qw(authors_file mailmap_file exclude_file)) { + $self{$name} + or die "Property '$name' is mandatory in constructor"; + } + + my $self= bless \%self, $class; + + if (my $ary= $self->{exclude_contrib}) { + $self->_exclude_contrib($_) for @$ary; + } + + $self->read_exclude_file(); + + die Dumper(\%self) if $self{dump_opts}; + + return $self; +} + +sub __digest { + my $thing= $_[0]; + utf8::encode($thing); + return sha256_base64($thing); +} + +# if this name is a "keeper" then return its digest +# (if we know the digest and it is marked for exclusion +# then we return 0) +sub _keeper_digest { + my ($self, $real_name)= @_; + my $digest; + $digest= $self->{digest_cache}{$real_name}; + + if (!$digest) { + my $name= __fold_trim_ws($real_name); + + $digest= ($self->{digest_cache}{$name} //= __digest($name)); + $self->{digest_cache}{$real_name}= $digest; + } + + return $self->{exclude_digest}{$digest} ? 0 : $digest; +} + +# should we exclude this author from the AUTHORS file +# simply because of the form of their details? +sub _logical_exclude_author { + my ($self, $author)= @_; + + # don't know the persona + return 1 if $author =~ /^unknown/; + + # Someone at with a single word name. + # Eg, we wont list "Bob " + if ($author =~ s/\s*\z//) { + return 1 if $author =~ /^\w+$/; + } + return 0; +} + +# exclude this contributor by name, if digest isnt provided +# then it is computed using _digest. +sub _exclude_contrib { + my ($self, $name, $digest)= @_; + + # if we would exclude them anyway due to the logical + # naming rules then we do not need to add them to the exclude + # file. + return if $self->_logical_exclude_author($name); + $name= __fold_trim_ws($name); + $digest //= __digest($name); + $self->{exclude_digest}{$digest}++ + or warn "Excluding '$name' with '$digest'\n"; +} + +sub _log_file_changes_quick_and_dirty_diff { + my ($self, $file, $old_raw_text, $new_raw_text)= @_; + + my %old; + $old{$_}++ for split /\n/, $old_raw_text; + my %new; + $new{$_}++ for split /\n/, $new_raw_text; + foreach my $key (keys %new) { + delete $new{$key} if delete $old{$key}; + } + $self->{changed_file}{$file}{add}= \%new if keys %new; + $self->{changed_file}{$file}{del}= \%old if keys %old; + return $self->{changed_file}{$file}; +} + +sub _diff_diag { + my ($self, $want_file)= @_; + my $diag_str= ""; + foreach my $file (sort keys %{ $self->{changed_file} || {} }) { + next if $want_file and $file ne $want_file; + $diag_str .= " File '$file' changes:\n"; + foreach my $action (sort keys %{ $self->{changed_file}{$file} }) { + foreach + my $line (sort keys %{ $self->{changed_file}{$file}{$action} }) + { + $diag_str .= " would $action: $line\n"; + } + } + } + return $diag_str; +} + +my %pretty_name= ( + "author" => "Authored", + "committer" => "Committed", + "applied" => "Applied", + "name" => "Name", + "pos" => "Pos", + "num_files" => "NFiles", + "lines_added" => "L++", + "lines_removed" => "L--", + "lines_delta" => "L+-", + "binary_changed" => "Bin+-", +); + +sub report_stats { + my ($self, $stats_key, @types)= @_; + my @extra= "name"; + my @rows; + my @total; + foreach my $name (__sorted_hash_keys($self->{$stats_key})) { + my @data= map { $self->{$stats_key}{$name}{$_} // 0 } @types; + $total[$_] += $data[$_] for 0 .. $#data; + push @data, $name; + push @rows, \@data if $data[0]; + } + @rows= sort { + my $cmp= 0; + for (0 .. $#$a - 1) { + $cmp= $b->[$_] <=> $a->[$_]; + last if $cmp; + } + $cmp ||= $Collate->cmp($a->[-1], $b->[-1]); + $cmp + } @rows; + @rows= reverse @rows if $self->{in_reverse}; + + if ($self->{as_cumulative}) { + my $sum= []; + for my $row (@rows) { + do { + $sum->[$_] += $row->[$_]; + $row->[$_]= $sum->[$_]; + } + for 0 .. $#types; + } + } + + if ($self->{as_percentage}) { + for my $row (@rows) { + $row->[$_]= sprintf "%.2f", ($row->[$_] / $total[$_]) * 100 + for 0 .. $#types; + } + } + + foreach my $row (@rows) { + my $name= $row->[-1]; + $name =~ s/\s+<.*\z//; + $name =~ s/\s+\@.*\z//; + $row->[-1]= $name; + } + my @col_names= map { $pretty_name{$_} // $_ } @types; + if ($self->{as_percentage}) { + $_= "%$_" for @col_names; + } + push @col_names, map { $pretty_name{$_} // $_ } @extra; + + if ($self->{as_list} && @types == 1) { + $self->_report_list(\@rows, \@types, \@extra, \@col_names); + } + else { + $self->_report_table(\@rows, \@types, \@extra, \@col_names); + } +} + +sub _report_table { + my ($self, $rows, $types, $extra, $col_names)= @_; + my $pos= 1; + unshift @$_, $pos++ for @$rows; + unshift @$col_names, "Pos"; + my @width= (0) x @$col_names; + foreach my $row ($col_names, @$rows) { + for my $idx (0 .. $#$row) { + $width[$idx] < length($row->[$idx]) + and $width[$idx]= length($row->[$idx]); + } + } + $width[-1]= 40 if $width[-1] > 40; + $width[$_]= -$width[$_] for 0, -1; + my $fmt= "#" . join(" | ", ("%*s") x @$col_names) . "\n"; + my $bar_fmt= "#" . join("-+-", ("%*s") x @$col_names) . "\n"; + printf $fmt, map { $width[$_], $col_names->[$_] } 0 .. $#width; + printf $bar_fmt, map { $width[$_], "-" x abs($width[$_]) } 0 .. $#width; + for my $idx (0 .. $#$rows) { + my $row= $rows->[$idx]; + print encode_utf8 sprintf $fmt, + map { $width[$_], $row->[$_] } 0 .. $#width; + } +} + +sub _report_list { + my ($self, $rows, $types, $extra, $col_names)= @_; + my %hash; + foreach my $row (@$rows) { + $hash{ $row->[0] }{ $row->[-1] }++; + } + my @vals= sort { $b <=> $a } keys %hash; # numeric sort + my $width= length($col_names->[0]); + $width < length($_) and $width= length($_) for @vals; + @vals= reverse @vals if $self->{in_reverse}; + + my $hdr_str= sprintf "%*s | %s", $width, $col_names->[0], $col_names->[-1]; + my $sep_str= sprintf "%*s-+-%s", $width, "-" x $width, "-" x 40; + my $fmt= "%*s | %s"; + + if ($self->{with_rank_numbers}) { + $hdr_str= sprintf "#%*s | %s", -length(0 + @$rows), "Pos", $hdr_str; + $sep_str= sprintf "#%*s-+-%s", -length(0 + @$rows), + "-" x length(0 + @$rows), $hdr_str; + } + print $hdr_str, "\n"; + print $sep_str, "\n"; + my $pos= 1; + foreach my $val (@vals) { + my $val_f= sprintf "%*s | ", $width, $val; + $val_f= sprintf "#%*d | %s", -length(0 + @$rows), $pos++, $val_f + if $self->{with_rank_numbers}; + print encode_utf8 wrap $val_f, + " " x length($val_f), + join(", ", $Collate->sort(keys %{ $hash{$val} })) . "\n"; + } +} + +sub _filter_sort_who { + my ($self, $hash)= @_; + my @who; + foreach my $name ($Collate->sort(keys %$hash)) { + $name =~ s/\s+<.*\z//; + $name =~ s/\s+\@.*\z//; + push @who, $name if length $name and lc($name) ne "unknown"; + } + return @who; +} + +sub print_who { + my ($self)= @_; + my @who= $self->_filter_sort_who($self->{who_stats}); + print encode_utf8 wrap "", "", join(", ", @who) . ".\n"; +} + +1; +__END__ + +=head1 NAME + +Porting::updateAUTHORS - Library to automatically update AUTHORS and .mailmap based on commit data. + +=head1 SYNOPSIS + + use Porting::updateAUTHORS; + + my $updater= Porting::updateAUTHORS->new( + authors_file => "AUTHORS", + mailmap_file => ".mailmap", + exclude_file => "Porting/exclude_contrib.txt", + ); + $updater->read_and_update(); + +=head1 DESCRIPTION + +This the brain of the F script. It is expected +to be used B that script and B that script. Most features and +options are documented in the F and are not +explicitly documented here, read the F manpage +for more details. + +=head1 METHODS + +Porting::updateAUTHORS uses OO as way of managing its internal state. +This documents the public methods it exposes. + +=over 4 + +=item add_new_mailmap_entries() + +If any additions were identified while reading the commits this will +inject them into the mailmap_hash so they can be written out. Returns a +count of additions found. + +=item check_fix_mailmap_hash() + +Analyzes the data contained the in the .mailmap file and applies any +automated fixes which are required and which it can automatically +perform. Returns a hash of adjusted entries and a hash with additional +metadata about the mailmap entries. + +=item new(%opts) + +Create a new object. Required parameters are + + authors_file + mailmap_file + exclude_file + +Other supported parameters are as follows: + + verbose + commit_range + +this list is not exhaustive. See the code implementing the main() +function in F for an exhaustive list. + +=item parse_orig_mailmap_hash() + +Takes a mailmap_hash and parses it and returns it as an array of array +records with the contents: + + [ $preferred_name, $preferred_email, + $other_name, $other_email, + $line_num ] + +=item read_and_update() + +Wraps the other functions in this library and implements the logic and +intent of this tool. Takes two arguments, the authors file name, and the +mailmap file name. Returns nothing but may modify the AUTHORS file +or the .mailmap file. Requires that both files are editable. + +=item read_commit_log() + +Read the commit log specified by the property "commit_range" and find +any new names it contains. + +Normally used via C and not called directly. + +=item read_authors_file() + +Read the AUTHORS file into the object, and return data about it. + +Normally used via C and not called directly. + +=item read_mailmap_file() + +Read the .mailmap file into the object and return data about it. + +Normally used via C and not called directly. + +=item read_exclusion_file() + +Read the exclusion file into the object and return data about it. + +Normally used via C and not called directly. + +=item update_authors_file() + +Write out an updated AUTHORS file atomically if it has changed, +returns 0 if the file was actually updated, 1 if it was not. + +Normally used via C and not called directly. + +=item update_mailmap_file() + +Write out an updated .mailmap file atomically if it has changed, +returns 0 if the file was actually updated, 1 if it was not. + +Normally used via C and not called directly. + +=item update_exclusion_file() + +Write out an updated exclusion file atomically if it has changed, +returns 0 if the file was actually update, 1 if it was not. + +Normally used via C and not called directly. + +=back + +=head1 TODO + +More documentation and testing. + +=head1 SEE ALSO + +F + +=head1 AUTHOR + +Yves Orton + +=cut diff --git a/gnu/usr.bin/perl/Porting/vote_admin_guide.pod b/gnu/usr.bin/perl/Porting/vote_admin_guide.pod index 3ba8febd673..d0c59316404 100644 --- a/gnu/usr.bin/perl/Porting/vote_admin_guide.pod +++ b/gnu/usr.bin/perl/Porting/vote_admin_guide.pod @@ -172,11 +172,11 @@ edit the Perl Core mailing list admins to match the incoming Steering Council =item * -update the GitHub "steering" team to match incoming Steering Council +update the L to match incoming Steering Council =item * -request that the Perl NOC update the perl-security list to include all incoming +request that the L update the perl-security list to include all incoming Steering Council members (without removing outgoing members; the incoming Steering Council will decide whether this is needed) diff --git a/gnu/usr.bin/perl/README.cn b/gnu/usr.bin/perl/README.cn index 05c2db6b074..dc735e1c15a 100644 --- a/gnu/usr.bin/perl/README.cn +++ b/gnu/usr.bin/perl/README.cn @@ -1,9 +1,11 @@ -=encoding utf8 +# vim: syntax=pod 如果你用一般的文字编辑器阅览这份文件, 请忽略文中奇特的注记字符. 这份文件是以 POD (简明文件格式) 写成; 这种格式是为了能让人直接阅读, 而特别设计的. 关于此格式的进一步信息, 请参考 perlpod 在线文档. +=encoding utf8 + =head1 NAME perlcn - 简体中文 Perl 指南 diff --git a/gnu/usr.bin/perl/README.jp b/gnu/usr.bin/perl/README.jp index df74b7d4f50..0f60c19df3b 100644 --- a/gnu/usr.bin/perl/README.jp +++ b/gnu/usr.bin/perl/README.jp @@ -1,3 +1,5 @@ +# vim: syntax=pod + =encoding utf8 =head1 NAME diff --git a/gnu/usr.bin/perl/README.ko b/gnu/usr.bin/perl/README.ko index 71d7d6ac521..aa9f996d8c6 100644 --- a/gnu/usr.bin/perl/README.ko +++ b/gnu/usr.bin/perl/README.ko @@ -1,9 +1,10 @@ -=encoding utf8 +# vim: syntax=pod 이 파일을 내용 그대로 읽고 있다면 우스꽝스러운 문자는 무시해주세요. 이 문서는 POD로 읽을 수 있도록 POD 형식(F 문서를 확인하세요)으로 작성되어 있습니다. +=encoding utf8 =head1 NAME diff --git a/gnu/usr.bin/perl/README.riscos b/gnu/usr.bin/perl/README.riscos index 2acd738c8c3..b8048e5cf90 100644 --- a/gnu/usr.bin/perl/README.riscos +++ b/gnu/usr.bin/perl/README.riscos @@ -1,3 +1,5 @@ +# vim: syntax=pod + If you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specifically designed to be readable as is. diff --git a/gnu/usr.bin/perl/README.tw b/gnu/usr.bin/perl/README.tw index d381d630691..2eefbc9bb8f 100644 --- a/gnu/usr.bin/perl/README.tw +++ b/gnu/usr.bin/perl/README.tw @@ -1,9 +1,11 @@ -=encoding utf8 +# vim: syntax=pod 如果你用一般的文字編輯器閱覽這份文件, 請忽略文中奇特的註記字符. 這份文件是以 POD (簡明文件格式) 寫成; 這種格式是為了能讓人直接讀取, 而特別設計的. 關於此格式的進一步資訊, 請參考 perlpod 線上文件. +=encoding utf8 + =head1 NAME perltw - 正體中文 Perl 指南 diff --git a/gnu/usr.bin/perl/README.vos b/gnu/usr.bin/perl/README.vos index 7249f492fd1..8ece9f2a11a 100644 --- a/gnu/usr.bin/perl/README.vos +++ b/gnu/usr.bin/perl/README.vos @@ -1,3 +1,5 @@ +# vim: syntax=pod + If you read this file _as_is_, just ignore the funny characters you see. It is written in the POD format (see pod/perlpod.pod) which is specially designed to be readable as is. diff --git a/gnu/usr.bin/perl/builtin.c b/gnu/usr.bin/perl/builtin.c index 9df66300827..a6373d2521d 100644 --- a/gnu/usr.bin/perl/builtin.c +++ b/gnu/usr.bin/perl/builtin.c @@ -32,6 +32,38 @@ static void S_warn_experimental_builtin(pTHX_ const char *name, bool prefix) prefix ? "builtin::" : "", name); } +/* These three utilities might want to live elsewhere to be reused from other + * code sometime + */ +#define prepare_export_lexical() S_prepare_export_lexical(aTHX) +static void S_prepare_export_lexical(pTHX) +{ + assert(PL_compcv); + + /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */ + ENTER; + SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); + SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1]; + SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); +} + +#define export_lexical(name, sv) S_export_lexical(aTHX_ name, sv) +static void S_export_lexical(pTHX_ SV *name, SV *sv) +{ + PADOFFSET off = pad_add_name_sv(name, padadd_STATE, 0, 0); + SvREFCNT_dec(PL_curpad[off]); + PL_curpad[off] = SvREFCNT_inc(sv); +} + +#define finish_export_lexical() S_finish_export_lexical(aTHX) +static void S_finish_export_lexical(pTHX) +{ + intro_my(); + + LEAVE; +} + + XS(XS_builtin_true); XS(XS_builtin_true) { @@ -125,6 +157,10 @@ XS(XS_builtin_func1_scalar) Perl_pp_floor(aTHX); break; + case OP_IS_TAINTED: + Perl_pp_is_tainted(aTHX); + break; + default: Perl_die(aTHX_ "panic: unhandled opcode %" IVdf " for xs_builtin_func1_scalar()", (IV) ix); @@ -227,6 +263,79 @@ XS(XS_builtin_trim) XSRETURN(1); } +XS(XS_builtin_export_lexically); +XS(XS_builtin_export_lexically) +{ + dXSARGS; + + warn_experimental_builtin("export_lexically", true); + + if(!PL_compcv) + Perl_croak(aTHX_ + "export_lexically can only be called at compile time"); + + if(items % 2) + Perl_croak(aTHX_ "Odd number of elements in export_lexically"); + + for(int i = 0; i < items; i += 2) { + SV *name = ST(i); + SV *ref = ST(i+1); + + if(!SvROK(ref)) + /* diag_listed_as: Expected %s reference in export_lexically */ + Perl_croak(aTHX_ "Expected a reference in export_lexically"); + + char sigil = SvPVX(name)[0]; + SV *rv = SvRV(ref); + + const char *bad = NULL; + switch(sigil) { + default: + /* overwrites the pointer on the stack; but this is fine, the + * caller's value isn't modified */ + ST(i) = name = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(name))); + + /* FALLTHROUGH */ + case '&': + if(SvTYPE(rv) != SVt_PVCV) + bad = "a CODE"; + break; + + case '$': + /* Permit any of SVt_NULL to SVt_PVMG. Technically this also + * includes SVt_INVLIST but it isn't thought possible for pureperl + * code to ever manage to see one of those. */ + if(SvTYPE(rv) > SVt_PVMG) + bad = "a SCALAR"; + break; + + case '@': + if(SvTYPE(rv) != SVt_PVAV) + bad = "an ARRAY"; + break; + + case '%': + if(SvTYPE(rv) != SVt_PVHV) + bad = "a HASH"; + break; + } + + if(bad) + Perl_croak(aTHX_ "Expected %s reference in export_lexically", bad); + } + + prepare_export_lexical(); + + for(int i = 0; i < items; i += 2) { + SV *name = ST(i); + SV *ref = ST(i+1); + + export_lexical(name, SvRV(ref)); + } + + finish_export_lexical(); +} + XS(XS_builtin_func1_void); XS(XS_builtin_func1_void) { @@ -380,22 +489,24 @@ static const struct BuiltinFuncDescriptor builtins[] = { { "builtin::false", &XS_builtin_false, &ck_builtin_const, BUILTIN_CONST_FALSE }, /* unary functions */ - { "builtin::is_bool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL }, - { "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN }, - { "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN }, - { "builtin::is_weak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK }, - { "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED }, - { "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR }, - { "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE }, - { "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL }, - { "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR }, - { "builtin::trim", &XS_builtin_trim, NULL, 0 }, + { "builtin::is_bool", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_BOOL }, + { "builtin::weaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_WEAKEN }, + { "builtin::unweaken", &XS_builtin_func1_void, &ck_builtin_func1, OP_UNWEAKEN }, + { "builtin::is_weak", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_WEAK }, + { "builtin::blessed", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_BLESSED }, + { "builtin::refaddr", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFADDR }, + { "builtin::reftype", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_REFTYPE }, + { "builtin::ceil", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_CEIL }, + { "builtin::floor", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_FLOOR }, + { "builtin::is_tainted", &XS_builtin_func1_scalar, &ck_builtin_func1, OP_IS_TAINTED }, + { "builtin::trim", &XS_builtin_trim, &ck_builtin_func1, 0 }, { "builtin::created_as_string", &XS_builtin_created_as_string, &ck_builtin_func1, 0 }, { "builtin::created_as_number", &XS_builtin_created_as_number, &ck_builtin_func1, 0 }, /* list functions */ { "builtin::indexed", &XS_builtin_indexed, &ck_builtin_funcN, 0 }, + { "builtin::export_lexically", &XS_builtin_export_lexically, NULL, 0 }, { 0 } }; @@ -408,11 +519,7 @@ XS(XS_builtin_import) Perl_croak(aTHX_ "builtin::import can only be called at compile time"); - /* We need to have PL_comppad / PL_curpad set correctly for lexical importing */ - ENTER; - SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(CvPADLIST(PL_compcv)); - SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(CvPADLIST(PL_compcv))[1]; - SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); + prepare_export_lexical(); for(int i = 1; i < items; i++) { SV *sym = ST(i); @@ -420,20 +527,16 @@ XS(XS_builtin_import) Perl_croak(aTHX_ builtin_not_recognised, sym); SV *ampname = sv_2mortal(Perl_newSVpvf(aTHX_ "&%" SVf, SVfARG(sym))); - SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym))); + SV *fqname = sv_2mortal(Perl_newSVpvf(aTHX_ "builtin::%" SVf, SVfARG(sym))); CV *cv = get_cv(SvPV_nolen(fqname), SvUTF8(fqname) ? SVf_UTF8 : 0); if(!cv) Perl_croak(aTHX_ builtin_not_recognised, sym); - PADOFFSET off = pad_add_name_sv(ampname, padadd_STATE, 0, 0); - SvREFCNT_dec(PL_curpad[off]); - PL_curpad[off] = SvREFCNT_inc(cv); + export_lexical(ampname, (SV *)cv); } - intro_my(); - - LEAVE; + finish_export_lexical(); } void diff --git a/gnu/usr.bin/perl/class.c b/gnu/usr.bin/perl/class.c new file mode 100644 index 00000000000..02c6c06bb47 --- /dev/null +++ b/gnu/usr.bin/perl/class.c @@ -0,0 +1,1064 @@ +/* class.c + * + * Copyright (C) 2022 by Paul Evans and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +/* This file contains the code that implements perl's new `use feature 'class'` + * object model + */ + +#include "EXTERN.h" +#define PERL_IN_CLASS_C +#include "perl.h" + +#include "XSUB.h" + +enum { + PADIX_SELF = 1, + PADIX_PARAMS = 2, +}; + +void +Perl_croak_kw_unless_class(pTHX_ const char *kw) +{ + PERL_ARGS_ASSERT_CROAK_KW_UNLESS_CLASS; + + if(!HvSTASH_IS_CLASS(PL_curstash)) + croak("Cannot '%s' outside of a 'class'", kw); +} + +#define newSVobject(fieldcount) Perl_newSVobject(aTHX_ fieldcount) +SV * +Perl_newSVobject(pTHX_ Size_t fieldcount) +{ + SV *sv = newSV_type(SVt_PVOBJ); + + Newx(ObjectFIELDS(sv), fieldcount, SV *); + ObjectMAXFIELD(sv) = fieldcount - 1; + + Zero(ObjectFIELDS(sv), fieldcount, SV *); + + return sv; +} + +PP(pp_initfield) +{ + dSP; + UNOP_AUX_item *aux = cUNOP_AUX->op_aux; + + SV *self = PAD_SVl(PADIX_SELF); + assert(SvTYPE(SvRV(self)) == SVt_PVOBJ); + SV *instance = SvRV(self); + + SV **fields = ObjectFIELDS(instance); + + PADOFFSET fieldix = aux[0].uv; + + SV *val = NULL; + + switch(PL_op->op_private & (OPpINITFIELD_AV|OPpINITFIELD_HV)) { + case 0: + if(PL_op->op_flags & OPf_STACKED) + val = newSVsv(POPs); + else + val = newSV(0); + break; + + case OPpINITFIELD_AV: + { + AV *av; + if(PL_op->op_flags & OPf_STACKED) { + SV **svp = PL_stack_base + POPMARK + 1; + STRLEN count = SP - svp + 1; + + av = newAV_alloc_x(count); + + av_extend(av, count); + while(svp <= SP) { + av_push_simple(av, newSVsv(*svp)); + svp++; + } + } + else + av = newAV(); + val = (SV *)av; + break; + } + + case OPpINITFIELD_HV: + { + HV *hv = newHV(); + if(PL_op->op_flags & OPf_STACKED) { + SV **svp = PL_stack_base + POPMARK + 1; + STRLEN svcount = SP - svp + 1; + + if(svcount % 2) + Perl_warner(aTHX_ + packWARN(WARN_MISC), "Odd number of elements in hash field initialization"); + + while(svp <= SP) { + SV *key = *svp; svp++; + SV *val = svp <= SP ? *svp : &PL_sv_undef; svp++; + + (void)hv_store_ent(hv, key, newSVsv(val), 0); + } + } + val = (SV *)hv; + break; + } + } + + fields[fieldix] = val; + + PADOFFSET padix = PL_op->op_targ; + if(padix) { + SAVESPTR(PAD_SVl(padix)); + SV *sv = PAD_SVl(padix) = SvREFCNT_inc(val); + save_freesv(sv); + } + + RETURN; +} + +XS(injected_constructor); +XS(injected_constructor) +{ + dXSARGS; + + HV *stash = (HV *)XSANY.any_sv; + assert(HvSTASH_IS_CLASS(stash)); + + struct xpvhv_aux *aux = HvAUX(stash); + + if((items - 1) % 2) + Perl_warn(aTHX_ "Odd number of arguments passed to %" HvNAMEf_QUOTEDPREFIX " constructor", + HvNAMEfARG(stash)); + + HV *params = NULL; + { + /* Set up params HV */ + params = newHV(); + SAVEFREESV((SV *)params); + + for(I32 i = 1; i < items; i += 2) { + SV *name = ST(i); + SV *val = (i+1 < items) ? ST(i+1) : &PL_sv_undef; + + /* TODO: think about sanity-checking name for being + * defined + * not ref (but overloaded objects?? boo) + * not duplicate + * But then, %params = @_; wouldn't do that + */ + + (void)hv_store_ent(params, name, SvREFCNT_inc(val), 0); + } + } + + SV *instance = newSVobject(aux->xhv_class_next_fieldix); + SvOBJECT_on(instance); + SvSTASH_set(instance, MUTABLE_HV(SvREFCNT_inc_simple(stash))); + + SV *self = sv_2mortal(newRV_noinc(instance)); + + assert(aux->xhv_class_initfields_cv); + { + ENTER; + SAVETMPS; + + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(self); + if(params) + PUSHs((SV *)params); // yes a raw HV + else + PUSHs(&PL_sv_undef); + PUTBACK; + + call_sv((SV *)aux->xhv_class_initfields_cv, G_VOID); + + SPAGAIN; + + FREETMPS; + LEAVE; + } + + if(aux->xhv_class_adjust_blocks) { + CV **cvp = (CV **)AvARRAY(aux->xhv_class_adjust_blocks); + U32 nblocks = av_count(aux->xhv_class_adjust_blocks); + + for(U32 i = 0; i < nblocks; i++) { + ENTER; + SAVETMPS; + SPAGAIN; + + EXTEND(SP, 2); + + PUSHMARK(SP); + PUSHs(self); /* I don't believe this needs to be an sv_mortalcopy() */ + PUTBACK; + + call_sv((SV *)cvp[i], G_VOID); + + SPAGAIN; + + FREETMPS; + LEAVE; + } + } + + if(params && hv_iterinit(params) > 0) { + /* TODO: consider sorting these into a canonical order, but that's awkward */ + HE *he = hv_iternext(params); + + SV *paramnames = newSVsv(HeSVKEY_force(he)); + SAVEFREESV(paramnames); + + while((he = hv_iternext(params))) + Perl_sv_catpvf(aTHX_ paramnames, ", %" SVf, SVfARG(HeSVKEY_force(he))); + + croak("Unrecognised parameters for %" HvNAMEf_QUOTEDPREFIX " constructor: %" SVf, + HvNAMEfARG(stash), SVfARG(paramnames)); + } + + EXTEND(SP, 1); + ST(0) = self; + XSRETURN(1); +} + +/* OP_METHSTART is an UNOP_AUX whose AUX list contains + * [0].uv = count of fieldbinding pairs + * [1].uv = maximum fieldidx found in the binding list + * [...] = pairs of (padix, fieldix) to bind in .uv fields + */ + +/* TODO: People would probably expect to find this in pp.c ;) */ +PP(pp_methstart) +{ + SV *self = av_shift(GvAV(PL_defgv)); + SV *rv = NULL; + + /* pp_methstart happens before the first OP_NEXTSTATE of the method body, + * meaning PL_curcop still points at the callsite. This is useful for + * croak() messages. However, it means we have to find our current stash + * via a different technique. + */ + CV *curcv; + if(LIKELY(CxTYPE(CX_CUR()) == CXt_SUB)) + curcv = CX_CUR()->blk_sub.cv; + else + curcv = find_runcv(NULL); + + if(!SvROK(self) || + !SvOBJECT((rv = SvRV(self))) || + SvTYPE(rv) != SVt_PVOBJ) { + HEK *namehek = CvGvNAME_HEK(curcv); + croak( + namehek ? "Cannot invoke method %" HEKf_QUOTEDPREFIX " on a non-instance" : + "Cannot invoke method on a non-instance", + namehek); + } + + if(CvSTASH(curcv) != SvSTASH(rv) && + !sv_derived_from_hv(self, CvSTASH(curcv))) + croak("Cannot invoke a method of %" HvNAMEf_QUOTEDPREFIX " on an instance of %" HvNAMEf_QUOTEDPREFIX, + HvNAMEfARG(CvSTASH(curcv)), HvNAMEfARG(SvSTASH(rv))); + + save_clearsv(&PAD_SVl(PADIX_SELF)); + sv_setsv(PAD_SVl(PADIX_SELF), self); + + UNOP_AUX_item *aux = cUNOP_AUX->op_aux; + if(aux) { + assert(SvTYPE(SvRV(self)) == SVt_PVOBJ); + SV *instance = SvRV(self); + SV **fieldp = ObjectFIELDS(instance); + + U32 fieldcount = (aux++)->uv; + U32 max_fieldix = (aux++)->uv; + + assert((U32)(ObjectMAXFIELD(instance)+1) > max_fieldix); + PERL_UNUSED_VAR(max_fieldix); + + for(Size_t i = 0; i < fieldcount; i++) { + PADOFFSET padix = (aux++)->uv; + U32 fieldix = (aux++)->uv; + + assert(fieldp[fieldix]); + + /* TODO: There isn't a convenient SAVE macro for doing both these + * steps in one go. Add one. */ + SAVESPTR(PAD_SVl(padix)); + SV *sv = PAD_SVl(padix) = SvREFCNT_inc(fieldp[fieldix]); + save_freesv(sv); + } + } + + if(PL_op->op_private & OPpINITFIELDS) { + SV *params = *av_fetch(GvAV(PL_defgv), 0, 0); + if(params && SvTYPE(params) == SVt_PVHV) { + SAVESPTR(PAD_SVl(PADIX_PARAMS)); + PAD_SVl(PADIX_PARAMS) = SvREFCNT_inc(params); + save_freesv(params); + } + } + + return NORMAL; +} + +static void +invoke_class_seal(pTHX_ void *_arg) +{ + class_seal_stash((HV *)_arg); +} + +void +Perl_class_setup_stash(pTHX_ HV *stash) +{ + PERL_ARGS_ASSERT_CLASS_SETUP_STASH; + + assert(HvHasAUX(stash)); + + if(HvSTASH_IS_CLASS(stash)) { + croak("Cannot reopen existing class %" HvNAMEf_QUOTEDPREFIX, + HvNAMEfARG(stash)); + } + + { + SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash)); + sv_2mortal(isaname); + + AV *isa = get_av(SvPV_nolen(isaname), (SvFLAGS(isaname) & SVf_UTF8)); + + if(isa && av_count(isa) > 0) + croak("Cannot create class %" HEKf " as it already has a non-empty @ISA", + HvNAME_HEK(stash)); + } + + char *classname = HvNAME(stash); + U32 nameflags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; + + /* TODO: + * Set some kind of flag on the stash to point out it's a class + * Allocate storage for all the extra things a class needs + * See https://github.com/leonerd/perl5/discussions/1 + */ + + /* Inject the constructor */ + { + SV *newname = Perl_newSVpvf(aTHX_ "%s::new", classname); + SAVEFREESV(newname); + + CV *newcv = newXS_flags(SvPV_nolen(newname), injected_constructor, __FILE__, NULL, nameflags); + CvXSUBANY(newcv).any_sv = (SV *)stash; + CvREFCOUNTED_ANYSV_on(newcv); + } + + /* TODO: + * DOES method + */ + + struct xpvhv_aux *aux = HvAUX(stash); + aux->xhv_class_superclass = NULL; + aux->xhv_class_initfields_cv = NULL; + aux->xhv_class_adjust_blocks = NULL; + aux->xhv_class_fields = NULL; + aux->xhv_class_next_fieldix = 0; + aux->xhv_class_param_map = NULL; + + aux->xhv_aux_flags |= HvAUXf_IS_CLASS; + + SAVEDESTRUCTOR_X(invoke_class_seal, stash); + + /* Prepare a suspended compcv for parsing field init expressions */ + { + I32 floor_ix = start_subparse(FALSE, 0); + + CvIsMETHOD_on(PL_compcv); + + /* We don't want to make `$self` visible during the expression but we + * still need to give it a name. Make it unusable from pure perl + */ + PADOFFSET padix = pad_add_name_pvs("$(self)", 0, NULL, NULL); + assert(padix == PADIX_SELF); + + padix = pad_add_name_pvs("%(params)", 0, NULL, NULL); + assert(padix == PADIX_PARAMS); + + PERL_UNUSED_VAR(padix); + + Newx(aux->xhv_class_suspended_initfields_compcv, 1, struct suspended_compcv); + suspend_compcv(aux->xhv_class_suspended_initfields_compcv); + + LEAVE_SCOPE(floor_ix); + } +} + +#define split_package_ver(value, pkgname, pkgversion) S_split_package_ver(aTHX_ value, pkgname, pkgversion) +static const char *S_split_package_ver(pTHX_ SV *value, SV *pkgname, SV *pkgversion) +{ + const char *start = SvPVX(value), + *p = start, + *end = start + SvCUR(value); + + while(*p && !isSPACE_utf8_safe(p, end)) + p += UTF8SKIP(p); + + sv_setpvn(pkgname, start, p - start); + if(SvUTF8(value)) + SvUTF8_on(pkgname); + + while(*p && isSPACE_utf8_safe(p, end)) + p += UTF8SKIP(p); + + if(*p) { + /* scan_version() gets upset about trailing content. We need to extract + * exactly what it wants + */ + start = p; + if(*p == 'v') + p++; + while(*p && strchr("0123456789._", *p)) + p++; + SV *tmpsv = newSVpvn(start, p - start); + SAVEFREESV(tmpsv); + + scan_version(SvPVX(tmpsv), pkgversion, FALSE); + } + + while(*p && isSPACE_utf8_safe(p, end)) + p += UTF8SKIP(p); + + return p; +} + +#define ensure_module_version(module, version) S_ensure_module_version(aTHX_ module, version) +static void S_ensure_module_version(pTHX_ SV *module, SV *version) +{ + dSP; + + ENTER; + + PUSHMARK(SP); + PUSHs(module); + PUSHs(version); + PUTBACK; + + call_method("VERSION", G_VOID); + + LEAVE; +} + +#define split_attr_nameval(sv, namp, valp) S_split_attr_nameval(aTHX_ sv, namp, valp) +static void S_split_attr_nameval(pTHX_ SV *sv, SV **namp, SV **valp) +{ + STRLEN svlen = SvCUR(sv); + bool do_utf8 = SvUTF8(sv); + + const char *paren_at = (const char *)memchr(SvPVX(sv), '(', svlen); + if(paren_at) { + STRLEN namelen = paren_at - SvPVX(sv); + + if(SvPVX(sv)[svlen-1] != ')') + /* Should be impossible to reach this by parsing regular perl code + * by as class_apply_attributes() is XS-visible API it might still + * be reachable. As it's likely unreachable by normal perl code, + * don't bother listing it in perldiag. + */ + /* diag_listed_as: SKIPME */ + croak("Malformed attribute string"); + *namp = sv_2mortal(newSVpvn_utf8(SvPVX(sv), namelen, do_utf8)); + + const char *value_at = paren_at + 1; + const char *value_max = SvPVX(sv) + svlen - 2; + + /* TODO: We're only obeying ASCII whitespace here */ + + /* Trim whitespace at the start */ + while(value_at < value_max && isSPACE(*value_at)) + value_at += 1; + while(value_max > value_at && isSPACE(*value_max)) + value_max -= 1; + + if(value_max >= value_at) + *valp = sv_2mortal(newSVpvn_utf8(value_at, value_max - value_at + 1, do_utf8)); + } + else { + *namp = sv; + *valp = NULL; + } +} + +static void +apply_class_attribute_isa(pTHX_ HV *stash, SV *value) +{ + assert(HvSTASH_IS_CLASS(stash)); + struct xpvhv_aux *aux = HvAUX(stash); + + /* Parse `value` into name + version */ + SV *superclassname = sv_newmortal(), *superclassver = sv_newmortal(); + const char *end = split_package_ver(value, superclassname, superclassver); + if(*end) + croak("Unexpected characters while parsing class :isa attribute: %s", end); + + if(aux->xhv_class_superclass) + croak("Class already has a superclass, cannot add another"); + + HV *superstash = gv_stashsv(superclassname, 0); + if(!superstash) { + /* Try to `require` the module then attempt a second time */ + load_module(PERL_LOADMOD_NOIMPORT, newSVsv(superclassname), NULL, NULL); + superstash = gv_stashsv(superclassname, 0); + } + if(!superstash || !HvSTASH_IS_CLASS(superstash)) + /* TODO: This would be a useful feature addition */ + croak("Class :isa attribute requires a class but %" HvNAMEf_QUOTEDPREFIX " is not one", + HvNAMEfARG(superstash)); + + if(superclassver && SvOK(superclassver)) + ensure_module_version(superclassname, superclassver); + + /* TODO: Suuuurely there's a way to fetch this neatly with stash + "ISA" + * You'd think that GvAV() of hv_fetchs() would do it, but no, because it + * won't lazily create a proper (magical) GV if one didn't already exist. + */ + { + SV *isaname = newSVpvf("%" HEKf "::ISA", HvNAME_HEK(stash)); + sv_2mortal(isaname); + + AV *isa = get_av(SvPV_nolen(isaname), GV_ADD | (SvFLAGS(isaname) & SVf_UTF8)); + + ENTER; + + /* Temporarily remove the SVf_READONLY flag */ + SAVESETSVFLAGS((SV *)isa, SVf_READONLY|SVf_PROTECT, SVf_READONLY|SVf_PROTECT); + SvREADONLY_off((SV *)isa); + + av_push(isa, newSVsv(value)); + + LEAVE; + } + + aux->xhv_class_superclass = (HV *)SvREFCNT_inc(superstash); + + struct xpvhv_aux *superaux = HvAUX(superstash); + + aux->xhv_class_next_fieldix = superaux->xhv_class_next_fieldix; + + if(superaux->xhv_class_adjust_blocks) { + if(!aux->xhv_class_adjust_blocks) + aux->xhv_class_adjust_blocks = newAV(); + + for(SSize_t i = 0; i <= AvFILL(superaux->xhv_class_adjust_blocks); i++) + av_push(aux->xhv_class_adjust_blocks, AvARRAY(superaux->xhv_class_adjust_blocks)[i]); + } + + if(superaux->xhv_class_param_map) { + aux->xhv_class_param_map = newHVhv(superaux->xhv_class_param_map); + } +} + +static struct { + const char *name; + bool requires_value; + void (*apply)(pTHX_ HV *stash, SV *value); +} const class_attributes[] = { + { .name = "isa", + .requires_value = true, + .apply = &apply_class_attribute_isa, + }, + {0} +}; + +static void +S_class_apply_attribute(pTHX_ HV *stash, OP *attr) +{ + assert(attr->op_type == OP_CONST); + + SV *name, *value; + split_attr_nameval(cSVOPx_sv(attr), &name, &value); + + for(int i = 0; class_attributes[i].name; i++) { + /* TODO: These attribute names are not UTF-8 aware */ + if(!strEQ(SvPVX(name), class_attributes[i].name)) + continue; + + if(class_attributes[i].requires_value && !(value && SvOK(value))) + croak("Class attribute %" SVf " requires a value", SVfARG(name)); + + (*class_attributes[i].apply)(aTHX_ stash, value); + return; + } + + croak("Unrecognized class attribute %" SVf, SVfARG(name)); +} + +void +Perl_class_apply_attributes(pTHX_ HV *stash, OP *attrlist) +{ + PERL_ARGS_ASSERT_CLASS_APPLY_ATTRIBUTES; + + if(!attrlist) + return; + if(attrlist->op_type == OP_NULL) { + op_free(attrlist); + return; + } + + if(attrlist->op_type == OP_LIST) { + OP *o = cLISTOPx(attrlist)->op_first; + assert(o->op_type == OP_PUSHMARK); + o = OpSIBLING(o); + + for(; o; o = OpSIBLING(o)) + S_class_apply_attribute(aTHX_ stash, o); + } + else + S_class_apply_attribute(aTHX_ stash, attrlist); + + op_free(attrlist); +} + +static OP * +S_newCROAKOP(pTHX_ SV *message) +{ + OP *o = newLISTOP(OP_LIST, 0, + newOP(OP_PUSHMARK, 0), + newSVOP(OP_CONST, 0, message)); + return op_convert_list(OP_DIE, 0, o); +} +#define newCROAKOP(message) S_newCROAKOP(aTHX_ message) + +void +Perl_class_seal_stash(pTHX_ HV *stash) +{ + PERL_ARGS_ASSERT_CLASS_SEAL_STASH; + + assert(HvSTASH_IS_CLASS(stash)); + struct xpvhv_aux *aux = HvAUX(stash); + + /* generate initfields CV */ + { + I32 floor_ix = PL_savestack_ix; + SAVEI32(PL_subline); + save_item(PL_subname); + + resume_compcv_final(aux->xhv_class_suspended_initfields_compcv); + + /* Some OP_INITFIELD ops will need to populate the pad with their + * result because later ops will rely on it. There's no need to do + * this for every op though. Store a mapping to work out which ones + * we'll need. + */ + PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); + HV *fieldix_to_padix = newHV(); + SAVEFREESV((SV *)fieldix_to_padix); + + /* padix 0 == @_; padix 1 == $self. Start at 2 */ + for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) { + PADNAME *pn = PadnamelistARRAY(pnl)[padix]; + if(!pn || !PadnameIsFIELD(pn)) + continue; + + U32 fieldix = PadnameFIELDINFO(pn)->fieldix; + (void)hv_store_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), newSVuv(padix), 0); + } + + OP *ops = NULL; + + ops = op_append_list(OP_LINESEQ, ops, + newUNOP_AUX(OP_METHSTART, OPpINITFIELDS << 8, NULL, NULL)); + + if(aux->xhv_class_superclass) { + HV *superstash = aux->xhv_class_superclass; + assert(HvSTASH_IS_CLASS(superstash)); + struct xpvhv_aux *superaux = HvAUX(superstash); + + /* Build an OP_ENTERSUB */ + OP *o = NULL; + o = op_append_list(OP_LIST, o, + newPADxVOP(OP_PADSV, 0, PADIX_SELF)); + o = op_append_list(OP_LIST, o, + newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS)); + /* TODO: This won't work at all well under `use threads` because + * it embeds the CV * to the superclass initfields CV right into + * the optree. Maybe we'll have to pop it in the pad or something + */ + o = op_append_list(OP_LIST, o, + newSVOP(OP_CONST, 0, (SV *)superaux->xhv_class_initfields_cv)); + + ops = op_append_list(OP_LINESEQ, ops, + op_convert_list(OP_ENTERSUB, OPf_WANT_VOID|OPf_STACKED, o)); + } + + PADNAMELIST *fieldnames = aux->xhv_class_fields; + + for(SSize_t i = 0; fieldnames && i <= PadnamelistMAX(fieldnames); i++) { + PADNAME *pn = PadnamelistARRAY(fieldnames)[i]; + char sigil = PadnamePV(pn)[0]; + PADOFFSET fieldix = PadnameFIELDINFO(pn)->fieldix; + + /* Extract the OP_{NEXT,DB}STATE op from the defop so we can + * splice it in + */ + OP *valop = PadnameFIELDINFO(pn)->defop; + if(valop && valop->op_type == OP_LINESEQ) { + OP *o = cLISTOPx(valop)->op_first; + cLISTOPx(valop)->op_first = NULL; + cLISTOPx(valop)->op_last = NULL; + /* have to clear the OPf_KIDS flag or op_free() will get upset */ + valop->op_flags &= ~OPf_KIDS; + op_free(valop); + assert(valop->op_type == OP_FREED); + + OP *fieldcop = o; + assert(fieldcop->op_type == OP_NEXTSTATE || fieldcop->op_type == OP_DBSTATE); + o = OpSIBLING(o); + OpLASTSIB_set(fieldcop, NULL); + + valop = o; + OpLASTSIB_set(valop, NULL); + + ops = op_append_list(OP_LINESEQ, ops, fieldcop); + } + + SV *paramname = PadnameFIELDINFO(pn)->paramname; + + U8 op_priv = 0; + switch(sigil) { + case '$': + if(paramname) { + if(!valop) + valop = newCROAKOP( + newSVpvf("Required parameter '%" SVf "' is missing for %" HvNAMEf_QUOTEDPREFIX " constructor", + SVfARG(paramname), HvNAMEfARG(stash)) + ); + + OP *helemop = + newBINOP(OP_HELEM, 0, + newPADxVOP(OP_PADHV, OPf_REF, PADIX_PARAMS), + newSVOP(OP_CONST, 0, SvREFCNT_inc(paramname))); + + if(PadnameFIELDINFO(pn)->def_if_undef) { + /* delete $params{$paramname} // DEFOP */ + valop = newLOGOP(OP_DOR, 0, + newUNOP(OP_DELETE, 0, helemop), valop); + } + else if(PadnameFIELDINFO(pn)->def_if_false) { + /* delete $params{$paramname} || DEFOP */ + valop = newLOGOP(OP_OR, 0, + newUNOP(OP_DELETE, 0, helemop), valop); + } + else { + /* exists $params{$paramname} ? delete $params{$paramname} : DEFOP */ + /* more efficient with the new OP_HELEMEXISTSOR */ + valop = newLOGOP(OP_HELEMEXISTSOR, OPpHELEMEXISTSOR_DELETE << 8, + helemop, valop); + } + + valop = op_contextualize(valop, G_SCALAR); + } + break; + + case '@': + op_priv = OPpINITFIELD_AV; + break; + + case '%': + op_priv = OPpINITFIELD_HV; + break; + + default: + NOT_REACHED; + } + + UNOP_AUX_item *aux; + Newx(aux, 2, UNOP_AUX_item); + + aux[0].uv = fieldix; + + OP *fieldop = newUNOP_AUX(OP_INITFIELD, valop ? OPf_STACKED : 0, valop, aux); + fieldop->op_private = op_priv; + + HE *he; + if((he = hv_fetch_ent(fieldix_to_padix, sv_2mortal(newSVuv(fieldix)), 0, 0)) && + SvOK(HeVAL(he))) { + fieldop->op_targ = SvUV(HeVAL(he)); + } + + ops = op_append_list(OP_LINESEQ, ops, fieldop); + } + + /* initfields CV should not get class_wrap_method_body() called on its + * body. pretend it isn't a method for now */ + CvIsMETHOD_off(PL_compcv); + CV *initfields = newATTRSUB(floor_ix, NULL, NULL, NULL, ops); + CvIsMETHOD_on(initfields); + + aux->xhv_class_initfields_cv = initfields; + } +} + +void +Perl_class_prepare_initfield_parse(pTHX) +{ + PERL_ARGS_ASSERT_CLASS_PREPARE_INITFIELD_PARSE; + + assert(HvSTASH_IS_CLASS(PL_curstash)); + struct xpvhv_aux *aux = HvAUX(PL_curstash); + + resume_compcv_and_save(aux->xhv_class_suspended_initfields_compcv); + CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax; +} + +void +Perl_class_prepare_method_parse(pTHX_ CV *cv) +{ + PERL_ARGS_ASSERT_CLASS_PREPARE_METHOD_PARSE; + + assert(cv == PL_compcv); + assert(HvSTASH_IS_CLASS(PL_curstash)); + + /* We expect this to be at the start of sub parsing, so there won't be + * anything in the pad yet + */ + assert(PL_comppad_name_fill == 0); + + PADOFFSET padix; + + padix = pad_add_name_pvs("$self", 0, NULL, NULL); + assert(padix == PADIX_SELF); + PERL_UNUSED_VAR(padix); + + intro_my(); + + CvNOWARN_AMBIGUOUS_on(cv); + CvIsMETHOD_on(cv); +} + +OP * +Perl_class_wrap_method_body(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_CLASS_WRAP_METHOD_BODY; + + if(!o) + return o; + + PADNAMELIST *pnl = PadlistNAMES(CvPADLIST(PL_compcv)); + + AV *fieldmap = newAV(); + UV max_fieldix = 0; + SAVEFREESV((SV *)fieldmap); + + /* padix 0 == @_; padix 1 == $self. Start at 2 */ + for(PADOFFSET padix = 2; padix <= PadnamelistMAX(pnl); padix++) { + PADNAME *pn = PadnamelistARRAY(pnl)[padix]; + if(!pn || !PadnameIsFIELD(pn)) + continue; + + U32 fieldix = PadnameFIELDINFO(pn)->fieldix; + if(fieldix > max_fieldix) + max_fieldix = fieldix; + + av_push(fieldmap, newSVuv(padix)); + av_push(fieldmap, newSVuv(fieldix)); + } + + UNOP_AUX_item *aux = NULL; + + if(av_count(fieldmap)) { + Newx(aux, 2 + av_count(fieldmap), UNOP_AUX_item); + + UNOP_AUX_item *ap = aux; + + (ap++)->uv = av_count(fieldmap) / 2; + (ap++)->uv = max_fieldix; + + for(Size_t i = 0; i < av_count(fieldmap); i++) + (ap++)->uv = SvUV(AvARRAY(fieldmap)[i]); + } + + /* If this is an empty method body then o will be an OP_STUB and not a + * list. This will confuse op_sibling_splice() */ + if(o->op_type != OP_LINESEQ) + o = newLISTOP(OP_LINESEQ, 0, o, NULL); + + op_sibling_splice(o, NULL, 0, newUNOP_AUX(OP_METHSTART, 0, NULL, aux)); + + return o; +} + +void +Perl_class_add_field(pTHX_ HV *stash, PADNAME *pn) +{ + PERL_ARGS_ASSERT_CLASS_ADD_FIELD; + + assert(HvSTASH_IS_CLASS(stash)); + struct xpvhv_aux *aux = HvAUX(stash); + + PADOFFSET fieldix = aux->xhv_class_next_fieldix; + aux->xhv_class_next_fieldix++; + + Newxz(PadnameFIELDINFO(pn), 1, struct padname_fieldinfo); + PadnameFLAGS(pn) |= PADNAMEf_FIELD; + + PadnameFIELDINFO(pn)->refcount = 1; + PadnameFIELDINFO(pn)->fieldix = fieldix; + PadnameFIELDINFO(pn)->fieldstash = (HV *)SvREFCNT_inc(stash); + + if(!aux->xhv_class_fields) + aux->xhv_class_fields = newPADNAMELIST(0); + + padnamelist_store(aux->xhv_class_fields, PadnamelistMAX(aux->xhv_class_fields)+1, pn); + PadnameREFCNT_inc(pn); +} + +static void +apply_field_attribute_param(pTHX_ PADNAME *pn, SV *value) +{ + if(!value) + /* Default to name minus the sigil */ + value = newSVpvn_utf8(PadnamePV(pn) + 1, PadnameLEN(pn) - 1, PadnameUTF8(pn)); + + if(PadnamePV(pn)[0] != '$') + croak("Only scalar fields can take a :param attribute"); + + if(PadnameFIELDINFO(pn)->paramname) + croak("Field already has a parameter name, cannot add another"); + + HV *stash = PadnameFIELDINFO(pn)->fieldstash; + assert(HvSTASH_IS_CLASS(stash)); + struct xpvhv_aux *aux = HvAUX(stash); + + if(aux->xhv_class_param_map && + hv_exists_ent(aux->xhv_class_param_map, value, 0)) + croak("Cannot assign :param(%" SVf ") to field %" SVf " because that name is already in use", + SVfARG(value), SVfARG(PadnameSV(pn))); + + PadnameFIELDINFO(pn)->paramname = SvREFCNT_inc(value); + + if(!aux->xhv_class_param_map) + aux->xhv_class_param_map = newHV(); + + (void)hv_store_ent(aux->xhv_class_param_map, value, newSVuv(PadnameFIELDINFO(pn)->fieldix), 0); +} + +static struct { + const char *name; + bool requires_value; + void (*apply)(pTHX_ PADNAME *pn, SV *value); +} const field_attributes[] = { + { .name = "param", + .requires_value = false, + .apply = &apply_field_attribute_param, + }, + {0} +}; + +static void +S_class_apply_field_attribute(pTHX_ PADNAME *pn, OP *attr) +{ + assert(attr->op_type == OP_CONST); + + SV *name, *value; + split_attr_nameval(cSVOPx_sv(attr), &name, &value); + + for(int i = 0; field_attributes[i].name; i++) { + /* TODO: These attribute names are not UTF-8 aware */ + if(!strEQ(SvPVX(name), field_attributes[i].name)) + continue; + + if(field_attributes[i].requires_value && !(value && SvOK(value))) + croak("Field attribute %" SVf " requires a value", SVfARG(name)); + + (*field_attributes[i].apply)(aTHX_ pn, value); + return; + } + + croak("Unrecognized field attribute %" SVf, SVfARG(name)); +} + +void +Perl_class_apply_field_attributes(pTHX_ PADNAME *pn, OP *attrlist) +{ + PERL_ARGS_ASSERT_CLASS_APPLY_FIELD_ATTRIBUTES; + + if(!attrlist) + return; + if(attrlist->op_type == OP_NULL) { + op_free(attrlist); + return; + } + + if(attrlist->op_type == OP_LIST) { + OP *o = cLISTOPx(attrlist)->op_first; + assert(o->op_type == OP_PUSHMARK); + o = OpSIBLING(o); + + for(; o; o = OpSIBLING(o)) + S_class_apply_field_attribute(aTHX_ pn, o); + } + else + S_class_apply_field_attribute(aTHX_ pn, attrlist); + + op_free(attrlist); +} + +void +Perl_class_set_field_defop(pTHX_ PADNAME *pn, OPCODE defmode, OP *defop) +{ + PERL_ARGS_ASSERT_CLASS_SET_FIELD_DEFOP; + + assert(defmode == 0 || defmode == OP_ORASSIGN || defmode == OP_DORASSIGN); + + assert(HvSTASH_IS_CLASS(PL_curstash)); + + forbid_outofblock_ops(defop, "field initialiser expression"); + + if(PadnameFIELDINFO(pn)->defop) + op_free(PadnameFIELDINFO(pn)->defop); + + char sigil = PadnamePV(pn)[0]; + switch(sigil) { + case '$': + defop = op_contextualize(defop, G_SCALAR); + break; + + case '@': + case '%': + defop = op_contextualize(op_force_list(defop), G_LIST); + break; + } + + PadnameFIELDINFO(pn)->defop = newLISTOP(OP_LINESEQ, 0, + newSTATEOP(0, NULL, NULL), defop); + switch(defmode) { + case OP_DORASSIGN: + PadnameFIELDINFO(pn)->def_if_undef = true; + break; + case OP_ORASSIGN: + PadnameFIELDINFO(pn)->def_if_false = true; + break; + } +} + +void +Perl_class_add_ADJUST(pTHX_ HV *stash, CV *cv) +{ + PERL_ARGS_ASSERT_CLASS_ADD_ADJUST; + + assert(HvSTASH_IS_CLASS(stash)); + struct xpvhv_aux *aux = HvAUX(stash); + + if(!aux->xhv_class_adjust_blocks) + aux->xhv_class_adjust_blocks = newAV(); + + av_push(aux->xhv_class_adjust_blocks, (SV *)cv); +} + +/* + * ex: set ts=8 sts=4 sw=4 et: + */ diff --git a/gnu/usr.bin/perl/cpan/AutoLoader/t/02AutoSplit.t b/gnu/usr.bin/perl/cpan/AutoLoader/t/02AutoSplit.t index f220a76cdc5..b50c6f2d0c6 100755 --- a/gnu/usr.bin/perl/cpan/AutoLoader/t/02AutoSplit.t +++ b/gnu/usr.bin/perl/cpan/AutoLoader/t/02AutoSplit.t @@ -149,8 +149,12 @@ foreach (@tests) { if ($args{Files}) { $args{Files} =~ s!/!:!gs if $^O eq 'MacOS'; + $args{Files} =~ s!\\!/!g if $^O eq 'MSWin32'; my (%missing, %got); - find (sub {$got{$File::Find::name}++ unless -d $_}, $dir); + find( + sub { (my $f = $File::Find::name) =~ s!\\!/!g; $got{$f}++ unless -d $_ }, + $dir + ); foreach (split /\n/, $args{Files}) { next if /^#/; $_ = lc($_) if $Is_VMS_lc; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/infback.c b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/infback.c index 5fb8c679417..264c14e0df6 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/infback.c +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/infback.c @@ -66,6 +66,7 @@ int ZEXPORT inflateBackInit_( state->window = window; state->wnext = 0; state->whave = 0; + state->sane = 1; return Z_OK; } @@ -605,25 +606,27 @@ int ZEXPORT inflateBack( break; case DONE: - /* inflate stream terminated properly -- write leftover output */ + /* inflate stream terminated properly */ ret = Z_STREAM_END; - if (left < state->wsize) { - if (out(out_desc, state->window, state->wsize - left)) - ret = Z_BUF_ERROR; - } goto inf_leave; case BAD: ret = Z_DATA_ERROR; goto inf_leave; - default: /* can't happen, but makes compilers happy */ + default: + /* can't happen, but makes compilers happy */ ret = Z_STREAM_ERROR; goto inf_leave; } - /* Return unused input */ + /* Write leftover output and return unused input */ inf_leave: + if (left < state->wsize) { + if (out(out_desc, state->window, state->wsize - left) && + ret == Z_STREAM_END) + ret = Z_BUF_ERROR; + } strm->next_in = next; strm->avail_in = have; return ret; diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.c b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.c index 0b58b29b1b5..d8405a24c46 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.c +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.c @@ -9,7 +9,7 @@ #define MAXBITS 15 const char inflate_copyright[] = - " inflate 1.2.12 Copyright 1995-2022 Mark Adler "; + " inflate 1.2.13 Copyright 1995-2022 Mark Adler "; /* If you use the zlib library in a product, an acknowledgment is welcome in the documentation of your product. If for some reason you cannot @@ -62,7 +62,7 @@ int ZLIB_INTERNAL inflate_table( 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0}; static const unsigned short lext[31] = { /* Length codes 257..285 extra */ 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 18, 18, 18, 18, - 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 199, 202}; + 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 194, 65}; static const unsigned short dbase[32] = { /* Distance codes 0..29 base */ 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.h b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.h index baa53a0b1a1..f53665311c1 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.h +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/inftrees.h @@ -38,7 +38,7 @@ typedef struct { /* Maximum size of the dynamic table. The maximum number of code structures is 1444, which is the sum of 852 for literal/length codes and 592 for distance codes. These values were found by exhaustive searches using the program - examples/enough.c found in the zlib distribtution. The arguments to that + examples/enough.c found in the zlib distribution. The arguments to that program are the number of symbols, the initial root table size, and the maximum bit length of a code. "enough 286 9 15" for literal/length codes returns returns 852, and "enough 30 6 15" for distance codes returns 592. diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/zlib.h b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/zlib.h index b5509cead64..bb740aaafac 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/zlib.h +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/zlib-src/zlib.h @@ -1,5 +1,5 @@ /* zlib.h -- interface of the 'zlib' general purpose compression library - version 1.2.12, March 11th, 2022 + version 1.2.13, October 13th, 2022 Copyright (C) 1995-2022 Jean-loup Gailly and Mark Adler @@ -37,11 +37,11 @@ extern "C" { #endif -#define ZLIB_VERSION "1.2.12" -#define ZLIB_VERNUM 0x12c0 +#define ZLIB_VERSION "1.2.13" +#define ZLIB_VERNUM 0x12d0 #define ZLIB_VER_MAJOR 1 #define ZLIB_VER_MINOR 2 -#define ZLIB_VER_REVISION 12 +#define ZLIB_VER_REVISION 13 #define ZLIB_VER_SUBREVISION 0 /* @@ -276,7 +276,7 @@ ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush)); == 0), or after each call of deflate(). If deflate returns Z_OK and with zero avail_out, it must be called again after making room in the output buffer because there might be more output pending. See deflatePending(), - which can be used if desired to determine whether or not there is more ouput + which can be used if desired to determine whether or not there is more output in that case. Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to @@ -660,7 +660,7 @@ ZEXTERN int ZEXPORT deflateGetDictionary OF((z_streamp strm, to dictionary. dictionary must have enough space, where 32768 bytes is always enough. If deflateGetDictionary() is called with dictionary equal to Z_NULL, then only the dictionary length is returned, and nothing is copied. - Similary, if dictLength is Z_NULL, then it is not set. + Similarly, if dictLength is Z_NULL, then it is not set. deflateGetDictionary() may return a length less than the window size, even when more than the window size in input has been provided. It may return up @@ -915,7 +915,7 @@ ZEXTERN int ZEXPORT inflateGetDictionary OF((z_streamp strm, to dictionary. dictionary must have enough space, where 32768 bytes is always enough. If inflateGetDictionary() is called with dictionary equal to Z_NULL, then only the dictionary length is returned, and nothing is copied. - Similary, if dictLength is Z_NULL, then it is not set. + Similarly, if dictLength is Z_NULL, then it is not set. inflateGetDictionary returns Z_OK on success, or Z_STREAM_ERROR if the stream state is inconsistent. @@ -1437,12 +1437,12 @@ ZEXTERN z_size_t ZEXPORT gzfread OF((voidp buf, z_size_t size, z_size_t nitems, In the event that the end of file is reached and only a partial item is available at the end, i.e. the remaining uncompressed data length is not a - multiple of size, then the final partial item is nevetheless read into buf + multiple of size, then the final partial item is nevertheless read into buf and the end-of-file flag is set. The length of the partial item read is not provided, but could be inferred from the result of gztell(). This behavior is the same as the behavior of fread() implementations in common libraries, but it prevents the direct use of gzfread() to read a concurrently written - file, reseting and retrying on end-of-file, when size is not 1. + file, resetting and retrying on end-of-file, when size is not 1. */ ZEXTERN int ZEXPORT gzwrite OF((gzFile file, voidpc buf, unsigned len)); @@ -1913,7 +1913,7 @@ ZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp)); ZEXTERN const z_crc_t FAR * ZEXPORT get_crc_table OF((void)); ZEXTERN int ZEXPORT inflateUndermine OF((z_streamp, int)); ZEXTERN int ZEXPORT inflateValidate OF((z_streamp, int)); -ZEXTERN unsigned long ZEXPORT inflateCodesUsed OF ((z_streamp)); +ZEXTERN unsigned long ZEXPORT inflateCodesUsed OF((z_streamp)); ZEXTERN int ZEXPORT inflateResetKeep OF((z_streamp)); ZEXTERN int ZEXPORT deflateResetKeep OF((z_streamp)); #if defined(_WIN32) && !defined(Z_SOLO) diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/29_plv5235w.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/29_plv5235w.t index f69d5fa8f89..d3d8d989ae7 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/29_plv5235w.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/29_plv5235w.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 120; + my $tests = 126; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -46,7 +46,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "bccd5d78dfebd48b89faf7f1fe711733"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [], "No local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/30_plv5240.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/30_plv5240.t index 2d6c0fd1662..ecb475bf829 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/30_plv5240.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/30_plv5240.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "3dffae79f6d2c74073f0d64646709101"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [], "No local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/31_plv52511.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/31_plv52511.t index a5b39ca27bf..a1f902dacb3 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/31_plv52511.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/31_plv52511.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "f0e463400e40ca35b67cec3834b5b9b7"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [ "SMOKEaa9ac6cf00899a6f55881d4ca6c1214215dc83ee" ], "Local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/32_plv5261rc1.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/32_plv5261rc1.t index 9db16b2ffd6..d59ea215521 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/32_plv5261rc1.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/32_plv5261rc1.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "dd710670fec7d2e260414648dcc94e89"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [ "RC1" ], "No local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/33_plv52711r.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/33_plv52711r.t index c6940d201a9..61469ba3203 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/33_plv52711r.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/33_plv52711r.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "bd9cf7a142ddbb434adea5b08eaefdc8"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [], "Local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/34_plv5280.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/34_plv5280.t index f6c38df27c0..09ee3112113 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/34_plv5280.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/34_plv5280.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -43,7 +43,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "4add7fd04b60c2048a46ff47087e6952"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [], "No local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/35_plv52910g.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/35_plv52910g.t index 6d822d1cb28..e9a04046031 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/35_plv52910g.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/35_plv52910g.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -43,7 +43,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "8404b533829bd9752df7f662a710f993"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [ "SMOKEdfba4714a9dc4c35123b4df0a5e1721ccb081d97" ], "No local patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/36_plv5300.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/36_plv5300.t index 6db751245f3..670aa1d0a59 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/36_plv5300.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/36_plv5300.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "b1138522685da4fff74f7b1118128d02"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [ ], "No patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/37_plv53111qm.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/37_plv53111qm.t index f566f7607b2..4d234fe1be9 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/37_plv53111qm.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/37_plv53111qm.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "146e648c6239f623b8a8242fc8b5759f"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [ ], "No patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/38_plv5320tld.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/38_plv5320tld.t index a8f0d736dc4..4edefd5c184 100644 --- a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/38_plv5320tld.t +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/38_plv5320tld.t @@ -5,7 +5,7 @@ use warnings; BEGIN { use Test::More; - my $tests = 128; + my $tests = 134; unless ($ENV{PERL_CORE}) { require Test::NoWarnings; Test::NoWarnings->import (); @@ -44,7 +44,11 @@ foreach my $o (sort keys %$opt) { eval { require Digest::MD5; }; my $md5 = $@ ? "0" x 32 : "901df8463a7bda6075bd75539214e75e"; ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); -is ($sig, $md5, "MD5"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } is_deeply ($conf->{build}{patches}, [ ], "No patches"); diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/39_plv5340tqm.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/39_plv5340tqm.t new file mode 100644 index 00000000000..c4ba00e09f9 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/39_plv5340tqm.t @@ -0,0 +1,181 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 134; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Jun 19 2021 15:51:32", "Build time"); +is ($conf->{config}{version}, "5.34.0", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP + PERL_OP_PARENT PERL_PRESERVE_IVUV USE_THREAD_SAFE_LOCALE + USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES + USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC + USE_LOCALE_TIME USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API USE_QUADMATH + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "12cfb15586bf005d29ff4c7ce770aefe"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 34, + bincompat5005 => undef, + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.34.0/x86_64-linux-thread-multi-quadmath/CORE", + config_args => "-Uversiononly -Dinc_version_list=none -Duse64bitall -Dusethreads -Duseithreads -Dusequadmath -Duseshrplib -des", + gccversion => "7.5.0", + gnulibc_version => "2.26", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "libc-2.26.so", + lseektype => "off_t", + osvers => "5.3.18-lp152.78-preempt", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 34 subversion 0) configuration: + + Platform: + osname=linux + osvers=5.3.18-lp152.78-preempt + archname=x86_64-linux-thread-multi-quadmath + uname='linux pc09 5.3.18-lp152.78-preempt #1 smp preempt tue jun 1 14:53:21 utc 2021 (556d823) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Uversiononly -Dinc_version_list=none -Duse64bitall -Dusethreads -Duseithreads -Dusequadmath -Duseshrplib -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=undef + usemymalloc=n + default_inc_excludes_dot=define + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-D_REENTRANT -D_GNU_SOURCE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='7.5.0' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='__float128' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/x86_64-suse-linux/lib /usr/lib /pro/local/lib /lib64 /usr/lib64 /lib /usr/local/lib64 + libs=-lpthread -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat -lquadmath + perllibs=-lpthread -ldl -lm -lcrypt -lutil -lc -lquadmath + libc=libc-2.26.so + so=so + useshrplib=true + libperl=libperl.so + gnulibc_version='2.26' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.34.0/x86_64-linux-thread-multi-quadmath/CORE' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_IMPLICIT_CONTEXT + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_PERLIO + USE_PERL_ATOF + USE_QUADMATH + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Built under linux + Compiled at Jun 19 2021 15:51:32 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + lib + /pro/lib/perl5/site_perl/5.34.0/x86_64-linux-thread-multi-quadmath + /pro/lib/perl5/site_perl/5.34.0 + /pro/lib/perl5/5.34.0/x86_64-linux-thread-multi-quadmath + /pro/lib/perl5/5.34.0 diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/40_plv5358dnqm.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/40_plv5358dnqm.t new file mode 100644 index 00000000000..00a9462e8ff --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/40_plv5358dnqm.t @@ -0,0 +1,176 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 134; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Jan 1 2022 11:18:27", "Build time"); +is ($conf->{config}{version}, "5.35.8", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + HAS_TIMES PERLIO_LAYERS PERL_COPY_ON_WRITE PERL_DONT_CREATE_GVSV + PERL_MALLOC_WRAP PERL_OP_PARENT PERL_PRESERVE_IVUV PERL_USE_DEVEL + USE_64_BIT_ALL USE_64_BIT_INT USE_LARGE_FILES USE_LOCALE + USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC + USE_LOCALE_TIME USE_PERLIO USE_PERL_ATOF USE_QUADMATH + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "3a52d65d54ee1032f878b51fb20c8efd"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 35, + bincompat5005 => undef, + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E", + config_args => "-Dusedevel -Duse64bitall -Dusequadmath -Uuseperlio -des", + gccversion => "11.2.1 20211124 [revision 7510c23c1ec53aa4a62705f0384079661342ff7b]", + gnulibc_version => "2.34", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "/lib/../lib64/libc.so.6", + lseektype => "off_t", + osvers => "5.15.8-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 35 subversion 8) configuration: + Snapshot of: 0ccfd062e2cfd32efe146d4c16faf3cae9e3cc84 + Platform: + osname=linux + osvers=5.15.8-1-default + archname=x86_64-linux-quadmath + uname='linux lx09 5.15.8-1-default #1 smp wed dec 15 08:12:54 utc 2021 (0530e5c) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Dusedevel -Duse64bitall -Dusequadmath -Uuseperlio -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=undef + usemultiplicity=undef + use64bitint=define + use64bitall=define + uselongdouble=undef + usemymalloc=n + default_inc_excludes_dot=define + Compiler: + cc='cc' + ccflags ='-pie -fPIE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-pie -fPIE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='11.2.1 20211124 [revision 7510c23c1ec53aa4a62705f0384079661342ff7b]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='__float128' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/x86_64-suse-linux/lib /usr/lib /data/pro/local/lib /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat -lquadmath + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc -lquadmath + libc=/lib/../lib64/libc.so.6 + so=so + useshrplib=false + libperl=libperl.a + gnulibc_version='2.34' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + HAS_TIMES + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + PERL_USE_DEVEL + USE_64_BIT_ALL + USE_64_BIT_INT + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_PERLIO + USE_PERL_ATOF + USE_QUADMATH + Built under linux + Compiled at Jan 1 2022 11:18:27 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + lib + /pro/lib/perl5/site_perl/5.35.8/x86_64-linux-quadmath + /pro/lib/perl5/site_perl/5.35.8 + /pro/lib/perl5/5.35.8/x86_64-linux-quadmath + /pro/lib/perl5/5.35.8 diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/41_plv5360dnqm.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/41_plv5360dnqm.t new file mode 100644 index 00000000000..ef63f1524ba --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/41_plv5360dnqm.t @@ -0,0 +1,179 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 134; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Jun 10 2022 14:46:57", "Build time"); +is ($conf->{config}{version}, "5.36.0", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + HAS_TIMES MULTIPLICITY PERLIO_LAYERS PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP PERL_OP_PARENT + PERL_PRESERVE_IVUV USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS + USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC USE_LOCALE_TIME USE_PERLIO USE_PERL_ATOF + USE_QUADMATH USE_REENTRANT_API USE_THREAD_SAFE_LOCALE + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "e8348134908b3d371c277aff6da654b8"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); +is ($sig, $md5, "MD5"); + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 36, + bincompat5005 => undef, + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.36.0/x86_64-linux-thread-multi-quadmath/CORE", + config_args => "-Uversiononly -Dinc_version_list=none -Duse64bitall -Dusethreads -Duseithreads -Dusequadmath -Duseshrplib -des", + gccversion => "12.1.0", + gnulibc_version => "2.35", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "/lib/../lib64/libc.so.6", + lseektype => "off_t", + osvers => "5.18.1-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 36 subversion 0) configuration: + + Platform: + osname=linux + osvers=5.18.1-1-default + archname=x86_64-linux-thread-multi-quadmath + uname='linux lx09 5.18.1-1-default #1 smp preempt_dynamic mon may 30 07:49:01 utc 2022 (d00e88d) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Uversiononly -Dinc_version_list=none -Duse64bitall -Dusethreads -Duseithreads -Dusequadmath -Duseshrplib -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=undef + usemymalloc=n + default_inc_excludes_dot=define + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -pie -fPIE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-D_REENTRANT -D_GNU_SOURCE -pie -fPIE -fPIC -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='12.1.0' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='__float128' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/x86_64-suse-linux/lib /usr/lib /data/pro/local/lib /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat -lquadmath + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc -lquadmath + libc=/lib/../lib64/libc.so.6 + so=so + useshrplib=true + libperl=libperl.so + gnulibc_version='2.35' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E -Wl,-rpath,/pro/lib/perl5/5.36.0/x86_64-linux-thread-multi-quadmath/CORE' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_PERLIO + USE_PERL_ATOF + USE_QUADMATH + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Built under linux + Compiled at Jun 10 2022 14:46:57 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + /pro/lib/perl5/site_perl/5.36.0/x86_64-linux-thread-multi-quadmath + /pro/lib/perl5/site_perl/5.36.0 + /pro/lib/perl5/5.36.0/x86_64-linux-thread-multi-quadmath + /pro/lib/perl5/5.36.0 diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/42_plv5373tld.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/42_plv5373tld.t new file mode 100644 index 00000000000..866ef1b35c1 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/42_plv5373tld.t @@ -0,0 +1,191 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 135; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Aug 21 2022 08:56:37", "Build time"); +is ($conf->{config}{version}, "5.37.3", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + DEBUGGING HAS_TIMES MULTIPLICITY PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV PERL_HASH_FUNC_SIPHASH13 PERL_HASH_USE_SBOX32 + PERLIO_LAYERS PERL_MALLOC_WRAP PERL_OP_PARENT PERL_PRESERVE_IVUV + PERL_TRACK_MEMPOOL PERL_USE_DEVEL PERL_USE_SAFE_PUTENV USE_64_BIT_ALL + USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES USE_LOCALE + USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME + USE_LONG_DOUBLE USE_PERL_ATOF USE_PERLIO USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "ff4175ca52fccf9c03c33d34af942b0d"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } + +is_deeply ($conf->{build}{patches}, [ ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 37, + bincompat5005 => undef, # GONE, chainsawed + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E", + config_args => "-Dusedevel -Dusethreads -Duseithreads -Duse64bitall -Duselongdouble -desr -Dusedevel -Uinstallusrbinperl -Dprefix=/media/Tux/perls-t", + gccversion => "12.1.1 20220812 [revision 6b7d570a5001bb79e34c0d1626a8c7f55386dac7]", + gnulibc_version => "2.35", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O2 -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "/lib/../lib64/libc.so.6", + lseektype => "off_t", + osvers => "5.19.1-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 37 subversion 3) configuration: + + Platform: + osname=linux + osvers=5.19.1-1-default + archname=x86_64-linux-thread-multi-ld + uname='linux lx09 5.19.1-1-default #1 smp preempt_dynamic thu aug 11 11:32:52 utc 2022 (a5bf6c0) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Dusedevel -Dusethreads -Duseithreads -Duse64bitall -Duselongdouble -desr -Dusedevel -Uinstallusrbinperl -Dprefix=/media/Tux/perls-t' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=define + usemymalloc=n + default_inc_excludes_dot=define + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O2' + cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBUGGING -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='12.1.1 20220812 [revision 6b7d570a5001bb79e34c0d1626a8c7f55386dac7]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='long double' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/x86_64-suse-linux/lib /usr/lib /data/pro/local/lib /usr/lib64 /usr/local/lib64 + libs=-lpthread -lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat + perllibs=-lpthread -lnsl -ldl -lm -lcrypt -lutil -lc + libc=/lib/../lib64/libc.so.6 + so=so + useshrplib=false + libperl=libperl.a + gnulibc_version='2.35' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E' + cccdlflags='-fPIC' + lddlflags='-shared -O2 -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + DEBUGGING + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_HASH_FUNC_SIPHASH13 + PERL_HASH_USE_SBOX32 + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + PERL_TRACK_MEMPOOL + PERL_USE_DEVEL + PERL_USE_SAFE_PUTENV + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_LONG_DOUBLE + USE_PERLIO + USE_PERL_ATOF + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Built under linux + Compiled at Aug 21 2022 08:56:37 + %ENV: + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + @INC: + /media/Tux/perls-t/lib/site_perl/5.37.3/x86_64-linux-thread-multi-ld + /media/Tux/perls-t/lib/site_perl/5.37.3 + /media/Tux/perls-t/lib/5.37.3/x86_64-linux-thread-multi-ld + /media/Tux/perls-t/lib/5.37.3 diff --git a/gnu/usr.bin/perl/cpan/Config-Perl-V/t/43_plv53710rcs.t b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/43_plv53710rcs.t new file mode 100644 index 00000000000..ee0cecb50db --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Config-Perl-V/t/43_plv53710rcs.t @@ -0,0 +1,202 @@ +#!/pro/bin/perl + +use strict; +use warnings; + +BEGIN { + use Test::More; + my $tests = 135; + unless ($ENV{PERL_CORE}) { + require Test::NoWarnings; + Test::NoWarnings->import (); + $tests++; + } + + plan tests => $tests; + } + +use Config::Perl::V qw( summary ); + +ok (my $conf = Config::Perl::V::plv2hash (), "Read perl -v block"); +ok (exists $conf->{$_}, "Has $_ entry") for qw( build environment config inc ); + +is ($conf->{build}{osname}, $conf->{config}{osname}, "osname"); +is ($conf->{build}{stamp}, "Feb 28 2023 18:30:03", "Build time"); +is ($conf->{config}{version}, "5.37.10", "reconstructed \$Config{version}"); + +my $opt = Config::Perl::V::plv2hash ("")->{build}{options}; +foreach my $o (sort qw( + DEBUGGING HAS_TIMES MULTIPLICITY PERL_COPY_ON_WRITE PERL_RC_STACK + PERL_DONT_CREATE_GVSV PERL_HASH_FUNC_SIPHASH13 PERL_HASH_USE_SBOX32 + PERLIO_LAYERS PERL_MALLOC_WRAP PERL_OP_PARENT PERL_PRESERVE_IVUV + PERL_TRACK_MEMPOOL PERL_USE_DEVEL PERL_USE_SAFE_PUTENV USE_64_BIT_ALL + USE_64_BIT_INT USE_ITHREADS USE_LARGE_FILES USE_LOCALE + USE_LOCALE_COLLATE USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LOCALE_TIME + USE_LONG_DOUBLE USE_PERL_ATOF USE_PERLIO USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + )) { + is ($conf->{build}{options}{$o}, 1, "Runtime option $o set"); + delete $opt->{$o}; + } +foreach my $o (sort keys %$opt) { + is ($conf->{build}{options}{$o}, 0, "Runtime option $o unset"); + } + +eval { require Digest::MD5; }; +my $md5 = $@ ? "0" x 32 : "964776ac5595a8a584dfba7ee063e4b9"; +ok (my $sig = Config::Perl::V::signature ($conf), "Get signature"); + +SKIP: { + ord "A" == 65 or skip "ASCII-centric test", 1; + is ($sig, $md5, "MD5"); + } + +is_deeply ($conf->{build}{patches}, [ "uncommitted-changes" ], "No patches"); + +my %check = ( + alignbytes => 16, + api_version => 37, + bincompat5005 => undef, # GONE, chainsawed + byteorder => 12345678, + cc => "cc", + cccdlflags => "-fPIC", + ccdlflags => "-Wl,-E", + config_args => "-Dusedevel -Duse64bitall -Dusethreads -Duseithreads -Duselongdouble -Doptimize='-O0\\ -g' -Accflags=-DPERL_RC_STACK -des", + gccversion => "12.2.1 20230124 [revision 193f7e62815b4089dfaed4c2bd34fd4f10209e27]", + gnulibc_version => "2.37", + ivsize => 8, + ivtype => "long", + ld => "cc", + lddlflags => "-shared -O0 -g -L/pro/local/lib -fstack-protector-strong", + ldflags => "-L/pro/local/lib -fstack-protector-strong", + libc => "/lib/../lib64/libc.so.6", + lseektype => "off_t", + osvers => "6.1.12-1-default", + use64bitall => "define", + use64bitint => "define", + usemymalloc => "n", + default_inc_excludes_dot + => "define", + ); +is ($conf->{config}{$_}, $check{$_}, "reconstructed \$Config{$_}") for sort keys %check; + +ok (my $info = summary ($conf), "A summary"); +ok (exists $info->{$_}, "Summary has $_") for qw( cc config_args usemymalloc default_inc_excludes_dot ); +is ($info->{default_inc_excludes_dot}, "define", "This build has . NOT in INC"); + +__END__ +Summary of my perl5 (revision 5 version 37 subversion 10) configuration: + Derived from: f0cf813c73daf1ae652b454fc8bc4828aec1f049 + Platform: + osname=linux + osvers=6.1.12-1-default + archname=x86_64-linux-thread-multi-ld + uname='linux lx09 6.1.12-1-default #1 smp preempt_dynamic wed feb 15 05:31:41 utc 2023 (373f017) x86_64 x86_64 x86_64 gnulinux ' + config_args='-Dusedevel -Duse64bitall -Dusethreads -Duseithreads -Duselongdouble -Doptimize='-O0\ -g' -Accflags=-DPERL_RC_STACK -des' + hint=recommended + useposix=true + d_sigaction=define + useithreads=define + usemultiplicity=define + use64bitint=define + use64bitall=define + uselongdouble=define + usemymalloc=n + default_inc_excludes_dot=define + Compiler: + cc='cc' + ccflags ='-D_REENTRANT -D_GNU_SOURCE -pie -fPIE -fPIC -DDEBUGGING -DPERL_RC_STACK -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64 -D_FORTIFY_SOURCE=2' + optimize='-O0 -g' + cppflags='-D_REENTRANT -D_GNU_SOURCE -pie -fPIE -fPIC -DDEBUGGING -DPERL_RC_STACK -fwrapv -fno-strict-aliasing -pipe -fstack-protector-strong -I/pro/local/include' + ccversion='' + gccversion='12.2.1 20230124 [revision 193f7e62815b4089dfaed4c2bd34fd4f10209e27]' + gccosandvers='' + intsize=4 + longsize=8 + ptrsize=8 + doublesize=8 + byteorder=12345678 + doublekind=3 + d_longlong=define + longlongsize=8 + d_longdbl=define + longdblsize=16 + longdblkind=3 + ivtype='long' + ivsize=8 + nvtype='long double' + nvsize=16 + Off_t='off_t' + lseeksize=8 + alignbytes=16 + prototype=define + Linker and Libraries: + ld='cc' + ldflags ='-L/pro/local/lib -fstack-protector-strong' + libpth=/usr/local/lib /usr/x86_64-suse-linux/lib /usr/lib /data/pro/local/lib /usr/lib64 /usr/local/lib64 + libs=-lpthread -lgdbm -ldb -ldl -lm -lcrypt -lutil -lc -lgdbm_compat + perllibs=-lpthread -ldl -lm -lcrypt -lutil -lc + libc=/lib/../lib64/libc.so.6 + so=so + useshrplib=false + libperl=libperl.a + gnulibc_version='2.37' + Dynamic Linking: + dlsrc=dl_dlopen.xs + dlext=so + d_dlsymun=undef + ccdlflags='-Wl,-E' + cccdlflags='-fPIC' + lddlflags='-shared -O0 -g -L/pro/local/lib -fstack-protector-strong' + + +Characteristics of this binary (from libperl): + Compile-time options: + DEBUGGING + HAS_TIMES + MULTIPLICITY + PERLIO_LAYERS + PERL_COPY_ON_WRITE + PERL_DONT_CREATE_GVSV + PERL_HASH_FUNC_SIPHASH13 + PERL_HASH_USE_SBOX32 + PERL_MALLOC_WRAP + PERL_OP_PARENT + PERL_PRESERVE_IVUV + PERL_RC_STACK + PERL_TRACK_MEMPOOL + PERL_USE_DEVEL + PERL_USE_SAFE_PUTENV + USE_64_BIT_ALL + USE_64_BIT_INT + USE_ITHREADS + USE_LARGE_FILES + USE_LOCALE + USE_LOCALE_COLLATE + USE_LOCALE_CTYPE + USE_LOCALE_NUMERIC + USE_LOCALE_TIME + USE_LONG_DOUBLE + USE_PERLIO + USE_PERL_ATOF + USE_REENTRANT_API + USE_THREAD_SAFE_LOCALE + Locally applied patches: + uncommitted-changes + Built under linux + Compiled at Feb 28 2023 18:30:03 + %ENV: + PERL5LIB="/pro/3gl/CPAN/perl-git/lib" + PERL6LIB="inst#/pro/3gl/CPAN/rakudo/install" + PERL_ARCHLIB="/pro/3gl/CPAN/perl-git" + PERL_CORE="1" + PERL_INC="/pro/3gl/CPAN/perl-git" + PERL_LIB="/pro/3gl/CPAN/perl-git/lib" + PERL_SRC="/pro/3gl/CPAN/perl-git" + @INC: + /pro/3gl/CPAN/perl-git/lib + /pro/3gl/CPAN/perl-git/lib + /pro/lib/perl5/site_perl/5.37.10/x86_64-linux-thread-multi-ld + /pro/lib/perl5/site_perl/5.37.10 + /pro/lib/perl5/5.37.10/x86_64-linux-thread-multi-ld + /pro/lib/perl5/5.37.10 diff --git a/gnu/usr.bin/perl/cpan/Encode/t/Unicode_trailing_nul.t b/gnu/usr.bin/perl/cpan/Encode/t/Unicode_trailing_nul.t index 80a1e19f5a3..a212599619d 100644 --- a/gnu/usr.bin/perl/cpan/Encode/t/Unicode_trailing_nul.t +++ b/gnu/usr.bin/perl/cpan/Encode/t/Unicode_trailing_nul.t @@ -1,3 +1,9 @@ +BEGIN { + if ( $] < 5.009 ) { + print "1..0 # Skip: Perl <= 5.9 or later required\n"; + exit 0; + } +} use strict; use Test::More; diff --git a/gnu/usr.bin/perl/cpan/Encode/t/truncated_utf8.t b/gnu/usr.bin/perl/cpan/Encode/t/truncated_utf8.t index b3792676641..d6c3363eb62 100644 --- a/gnu/usr.bin/perl/cpan/Encode/t/truncated_utf8.t +++ b/gnu/usr.bin/perl/cpan/Encode/t/truncated_utf8.t @@ -12,6 +12,10 @@ BEGIN { print "1..0 # Skip: EBCDIC\n"; exit 0; } + if ( $] < 5.009 ) { + print "1..0 # Skip: Perl <= 5.9 or later required\n"; + exit 0; + } $| = 1; } diff --git a/gnu/usr.bin/perl/cpan/Encode/t/utf32warnings.t b/gnu/usr.bin/perl/cpan/Encode/t/utf32warnings.t index b151cc789a9..5759541922f 100644 --- a/gnu/usr.bin/perl/cpan/Encode/t/utf32warnings.t +++ b/gnu/usr.bin/perl/cpan/Encode/t/utf32warnings.t @@ -1,3 +1,9 @@ +BEGIN { + if ( $] < 5.009 ) { + print "1..0 # Skip: Perl <= 5.9 or later required\n"; + exit 0; + } +} use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/Encode/t/xml.t b/gnu/usr.bin/perl/cpan/Encode/t/xml.t index 2c7e721d914..5cfc6178a5f 100644 --- a/gnu/usr.bin/perl/cpan/Encode/t/xml.t +++ b/gnu/usr.bin/perl/cpan/Encode/t/xml.t @@ -1,3 +1,9 @@ +BEGIN { + if ( $] < 5.009 ) { + print "1..0 # Skip: Perl <= 5.9 or later required\n"; + exit 0; + } +} use strict; use warnings; @@ -8,7 +14,7 @@ my $content = String->new("--\x{30c6}--"); my $text = Encode::encode('latin1', $content, Encode::FB_XMLCREF); is $text, "--テ--"; -done_testing; +done_testing(); package String; use overload diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm index 444b89a0e89..cb78ecaaf1f 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/lib/ExtUtils/MM_OS390.pm @@ -2,7 +2,7 @@ package ExtUtils::MM_OS390; use strict; use warnings; -our $VERSION = '7.64'; +our $VERSION = '7.70'; $VERSION =~ tr/_//d; use ExtUtils::MakeMaker::Config; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST.t index b242a453afe..c84d5f3a3ac 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST.t @@ -76,7 +76,7 @@ is( !!$mm->{PERL_CORE}, !!$ENV{PERL_CORE}, 'PERL_CORE' ); my($perl_src, $mm_perl_src); if( $ENV{PERL_CORE} ) { - $perl_src = File::Spec->catdir($Updir, $Updir, $Updir, $Updir, $Updir); + $perl_src = File::Spec->catdir($Updir, $Updir, $Updir, $Updir, $Updir, $Updir); $perl_src = File::Spec->canonpath($perl_src); $mm_perl_src = File::Spec->canonpath($mm->{PERL_SRC}); } @@ -84,7 +84,7 @@ else { $mm_perl_src = $mm->{PERL_SRC}; } -is( $mm_perl_src, $perl_src, 'PERL_SRC' ); +is( $mm_perl_src, $perl_src, "PERL_SRC" ); # PERM_* diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST_PREFIX.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST_PREFIX.t index 1a79de21b9b..ac117ef0248 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST_PREFIX.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/INST_PREFIX.t @@ -109,7 +109,7 @@ is( !!$mm->{PERL_CORE}, !!$ENV{PERL_CORE}, 'PERL_CORE' ); my($perl_src, $mm_perl_src); if( $ENV{PERL_CORE} ) { - $perl_src = File::Spec->catdir($Updir, $Updir, $Updir, $Updir, $Updir); + $perl_src = File::Spec->catdir($Updir, $Updir, $Updir, $Updir, $Updir, $Updir); $perl_src = File::Spec->canonpath($perl_src); $mm_perl_src = File::Spec->canonpath($mm->{PERL_SRC}); } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/hints.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/hints.t index 79b96f67101..6b3cf737421 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/hints.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/hints.t @@ -61,8 +61,9 @@ CLOO local $SIG{__WARN__} = sub { $stderr .= join '', @_ }; $mm->check_hints; - my $Escaped_Hint_File = quotemeta($Hint_File); - like( $stderr, qr{^Failed to run hint file $Escaped_Hint_File: Argh!\n\z}, 'hint files produce errors' ); + is( $stderr, <catfile(File::Spec->curdir, @_, split m{\/}, $file); $file = File::Spec->rel2abs($file); @@ -131,9 +140,11 @@ sub teardown_recurs { foreach my $file (keys %Files) { my $dir = dirname($file); if( -e $dir ) { - rmtree($dir) || return; + rmtree($dir) or next; } } + chdir(".."); + rmtree($tmpdir); return 1; } diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/lib/ExtUtils/PL2Bat.pm b/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/lib/ExtUtils/PL2Bat.pm index 070e186fecd..68074179455 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/lib/ExtUtils/PL2Bat.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/lib/ExtUtils/PL2Bat.pm @@ -1,5 +1,5 @@ package ExtUtils::PL2Bat; -$ExtUtils::PL2Bat::VERSION = '0.004'; +$ExtUtils::PL2Bat::VERSION = '0.005'; use strict; use warnings; @@ -122,7 +122,7 @@ ExtUtils::PL2Bat - Batch file creation to run perl scripts on Windows =head1 VERSION -version 0.004 +version 0.005 =head1 OVERVIEW diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/t/make_executable.t b/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/t/make_executable.t index 0d75dc1629f..ec76a93a680 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/t/make_executable.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-PL2Bat/t/make_executable.t @@ -13,6 +13,11 @@ my @test_vals = ( 0, 1, 2, 3, -1, -2, 65535, 65536, 65537, 47, 100, 200, 255, 25 plan($OSNAME eq 'MSWin32' ? ( tests => (($#test_vals+1)*5)+2 ) : ( skip_all => 'Only usable on Windows' )); +# the method of execution of the test script is geared to cmd.exe so ensure +# this is used in case the user have some non-standard shell. +# E.g. TCC/4NT doesn't quite handle the invocation correctly producing errors. +$ENV{COMSPEC} = "$ENV{SystemRoot}\\System32\\cmd.exe"; + my $perl_in_fname = 'test_perl_source'; open my $out, '>', $perl_in_fname or die qq{Couldn't create source file ("$perl_in_fname"): $!}; diff --git a/gnu/usr.bin/perl/cpan/Getopt-Long/t/gol-basic.t b/gnu/usr.bin/perl/cpan/Getopt-Long/t/gol-basic.t index 16bb2d02fcc..5bbde72f603 100755 --- a/gnu/usr.bin/perl/cpan/Getopt-Long/t/gol-basic.t +++ b/gnu/usr.bin/perl/cpan/Getopt-Long/t/gol-basic.t @@ -15,7 +15,7 @@ die("Getopt::Long version $want_version required--this is only version ". $Getopt::Long::VERSION) unless $Getopt::Long::VERSION ge $want_version; -print "1..12\n"; +print "1..18\n"; @ARGV = qw(-Foo -baR --foo bar); undef $opt_baR; @@ -43,3 +43,26 @@ print ($rv ? "" : "not "); print "ok 10\n"; print ("@ARGV" eq 'file' ? "" : "not ", "ok 11\n"); ( $HELP && $FOO && !$BAR && $FILE eq 'foo' && $NO == 5 ) ? print "" : print "not "; print "ok 12\n"; + +# Test behaviour when the same option name is given twice, but not an multi-value option. +# The option given later on the command line is used. +# +{ + my $foo; + + @ARGV = qw(--foo a --foo b); + $rd = GetOptions('foo=s' => \$foo); + print ($rv ? "" : "not "); print "ok 13\n"; + print ($foo eq 'b' ? "" : "not ", "ok 14\n"); + + @ARGV = qw(--no-foo --foo); + $rd = GetOptions('foo!' => \$foo); + print ($rv ? "" : "not "); print "ok 15\n"; + print ($foo eq '1' ? "" : "not ", "ok 16\n"); + + @ARGV = qw(--foo --no-foo); + $rd = GetOptions('foo!' => \$foo); + print ($rv ? "" : "not "); print "ok 17\n"; + # Check it is set to an explicit 0. + print ($foo eq '0' ? "" : "not ", "ok 18\n"); +} diff --git a/gnu/usr.bin/perl/cpan/HTTP-Tiny/t/180_verify_SSL.t b/gnu/usr.bin/perl/cpan/HTTP-Tiny/t/180_verify_SSL.t new file mode 100644 index 00000000000..757ecc7996a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/HTTP-Tiny/t/180_verify_SSL.t @@ -0,0 +1,109 @@ +#!perl + +use strict; +use warnings; +use Test::More 0.88; +use lib 't'; + +use HTTP::Tiny; + +delete $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT}; + +{ + my $ht = HTTP::Tiny->new(); + is($ht->verify_SSL, 1, "verify_SSL is 1 by default"); +} + +{ + my $ht = HTTP::Tiny->new( + verify_SSL => 0 + ); + is($ht->verify_SSL, 0, "verify_SSL=>0 sets 0"); +} + +{ + my $ht = HTTP::Tiny->new( + verify_ssl => 0 + ); + is($ht->verify_SSL, 0, "verify_ssl=>0 sets 0"); +} + +{ + my $ht = HTTP::Tiny->new( + verify_SSL => 1, + verify_ssl => 0 + ); + is($ht->verify_SSL, 1, "verify_SSL=>1 and verify_ssl=>0 sets 1"); +} + +{ + my $ht = HTTP::Tiny->new( + verify_SSL => 0, + verify_ssl => 1 + ); + is($ht->verify_SSL, 1, "verify_SSL=>0 and verify_ssl=>1 sets 1"); +} + +{ + my $ht = HTTP::Tiny->new( + verify_SSL => 0, + verify_ssl => 0 + ); + is($ht->verify_SSL, 0, "verify_SSL=>0 and verify_ssl=>0 sets 0"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "1"; + my $ht = HTTP::Tiny->new(); + is($ht->verify_SSL, 0, "PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1 changes verify_SSL default to 0"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "0"; + my $ht = HTTP::Tiny->new(); + is($ht->verify_SSL, 1, "PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=0 keeps verify_SSL default at 1"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "False"; + my $ht = HTTP::Tiny->new(); + is($ht->verify_SSL, 1, "Unsupported PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=False keeps verify_SSL default at 1"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "1"; + my $ht = HTTP::Tiny->new(verify_SSL=>1); + is($ht->verify_SSL, 1, "PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1 does not override verify_SSL attribute set to 1"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "1"; + my $ht = HTTP::Tiny->new( + verify_SSL => 1, + verify_ssl => 1 + ); + is($ht->verify_SSL, 1, "PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1, verify_SSL=>1 and verify_ssl=>1 sets 1"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "1"; + my $ht = HTTP::Tiny->new( + verify_SSL => 1, + verify_ssl => 0 + ); + is($ht->verify_SSL, 1, "PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1, verify_SSL=>1 and verify_ssl=>0 sets 1"); +} + +{ + local $ENV{PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT} = "1"; + my $ht = HTTP::Tiny->new( + verify_SSL => 0, + verify_ssl => 0 + ); + is($ht->verify_SSL, 0, "PERL_HTTP_TINY_SSL_INSECURE_BY_DEFAULT=1, verify_SSL=>0 and verify_ssl=>0 sets 0"); +} + + + +done_testing; + diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip b/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip index d0f92fb620e..199599ee38e 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip +++ b/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip @@ -12,7 +12,7 @@ use IO::Compress::Zip qw(zip use Getopt::Long; -my $VERSION = '1.002'; +my $VERSION = '1.00'; my $compression_method = ZIP_CM_DEFLATE; my $stream = 0; @@ -51,6 +51,10 @@ if ($compression_method == ZIP_CM_DEFLATE && defined $level) push @extraOpts, (Level => $level) } +# force streaming zip file when writing to stdout. +$stream = 1 + if $zipfile eq '-'; + zip '-' => $zipfile, Name => $memberName, Zip64 => $zip64, @@ -107,7 +111,8 @@ Usage: producer | streamzip [OPTIONS] | consumer producer | streamzip [OPTIONS] -zipfile output.zip -Stream data from stdin, compress into a Zip container, and stream to stdout. +Stream data from stdin, compress into a Zip container, and either stream to stdout, or +write to a named file. OPTIONS @@ -131,7 +136,7 @@ OPTIONS zstd Use LZMA compression [needs IO::Compress::Zstd] -version Display version number [$VERSION] -Copyright (c) 2019-2021 Paul Marquess. All rights reserved. +Copyright (c) 2019-2022 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. @@ -287,7 +292,7 @@ Paul Marquess F. =head1 COPYRIGHT -Copyright (c) 2019-2021 Paul Marquess. All rights reserved. +Copyright (c) 2019-2022 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/t/005defhdr.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/005defhdr.t index 8d4d16310fc..91a4a9dabe5 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/005defhdr.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/005defhdr.t @@ -19,7 +19,7 @@ BEGIN { $extra = 1 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - plan tests => 595 + $extra ; + plan tests => 114 + $extra ; use_ok('Compress::Raw::Zlib') ; @@ -123,6 +123,7 @@ EOM } +if (0) # disable these tests: IO::Compress::Deflate doesn't create the zlib header itself so no need to test { title "Check user-defined header settings match zlib" ; @@ -168,13 +169,16 @@ EOM my $hdr1 = ReadHeaderInfoZlib($string, %$opts); + # zlib-ng <= 2.0.6 with Level 1 sets the CINFO value to 5 . All other zlib & zlib-ng use expected value of 7 + # Note that zlib-ng 2.0.x uses a 16-bit encoding for ZLIBNG_VERNUM + my $cinfoValue = Compress::Raw::Zlib::is_zlibng() && Compress::Raw::Zlib::ZLIBNG_VERNUM() <= 0x2060 && defined $opts->{'-Level'} && $opts->{'-Level'} == 1 ? 5 : 7; is $hdr->{CM}, 8, " CM is 8"; - is $hdr->{CINFO}, 7, " CINFO is 7"; + is $hdr->{CINFO}, $cinfoValue, " CINFO is $cinfoValue"; is $hdr->{FDICT}, 0, " FDICT is 0"; while (my ($k, $v) = each %$expect) { - if (ZLIB_VERNUM >= 0x1220) + if (Compress::Raw::Zlib::is_zlibng() || ZLIB_VERNUM >= 0x1220) { is $hdr->{$k}, $v, " $k is $v" } else { ok 1, " Skip test for $k" } @@ -357,4 +361,3 @@ EOM ok $gunz->close ; } } - diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/011-streamzip.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/011-streamzip.t index 668177616ff..386ba37a11a 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/011-streamzip.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/011-streamzip.t @@ -87,7 +87,7 @@ sub check # streamzip -# ######## +# ######### { title "streamzip" ; @@ -123,28 +123,34 @@ for my $method (qw(store deflate bzip2 lzma xz zstd)) { if ($method eq 'lzma') { - eval { require IO::Compress::Lzma } ; + no warnings; + eval { require IO::Compress::Lzma && defined &{ 'IO::Compress::Adapter::Bzip2::mkRawZipCompObject' } } ; skip "Method 'lzma' needs IO::Compress::Lzma\n", 8 if $@; } if ($method eq 'zstd') { - eval { require IO::Compress::Zstd } ; + no warnings; + eval { require IO::Compress::Zstd && defined &{ 'IO::Compress::Adapter::Zstd::mkRawZipCompObject' }} ; skip "Method 'zstd' needs IO::Compress::Zstd\n", 8 if $@; } if ($method eq 'xz') { - eval { require IO::Compress::Xz } ; - skip "Method 'zstd' needs IO::Compress::Xz\n", 8 + no warnings; + eval { require IO::Compress::Xz && defined &{ 'IO::Compress::Adapter::Xz::mkRawZipCompObject' }} ; + skip "Method 'xz' needs IO::Compress::Xz\n", 8 if $@; } { title "streamzip method $method" ; + skip "streaming unzip not supported with zstd\n", 7 + if $method eq 'zstd' ; + my ($infile, $outfile); my $lex = LexFile->new( $infile, $outfile ); diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-03zlib-v1.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-03zlib-v1.t index 41734d055b6..73d7b894f78 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-03zlib-v1.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-03zlib-v1.t @@ -703,7 +703,8 @@ EOM ($GOT, $status) = $k->inflate($rest) ; # Z_STREAM_END returned by 1.12.2, Z_DATA_ERROR for older zlib - if (ZLIB_VERNUM >= ZLIB_1_2_12_0) + # always Z_STREAM_ENDin zlib_ng + if (ZLIB_VERNUM >= ZLIB_1_2_12_0 || Compress::Raw::Zlib::is_zlibng) { cmp_ok $status, '==', Z_STREAM_END ; } diff --git a/gnu/usr.bin/perl/cpan/IO-Zlib/Zlib.pm b/gnu/usr.bin/perl/cpan/IO-Zlib/Zlib.pm index 84aa5e428fd..2c2e869ff86 100644 --- a/gnu/usr.bin/perl/cpan/IO-Zlib/Zlib.pm +++ b/gnu/usr.bin/perl/cpan/IO-Zlib/Zlib.pm @@ -291,7 +291,7 @@ use Fcntl qw(SEEK_SET); use Symbol; use Tie::Handle; -our $VERSION = "1.11"; +our $VERSION = "1.14"; our $AUTOLOAD; our @ISA = qw(Tie::Handle); diff --git a/gnu/usr.bin/perl/cpan/IO-Zlib/t/basic.t b/gnu/usr.bin/perl/cpan/IO-Zlib/t/basic.t index c689a043355..b93f1cb546e 100755 --- a/gnu/usr.bin/perl/cpan/IO-Zlib/t/basic.t +++ b/gnu/usr.bin/perl/cpan/IO-Zlib/t/basic.t @@ -10,7 +10,7 @@ sub ok print "not ok $no\n" unless $ok ; } -my $name = "test.gz"; +my $name = "test_basic_$$.gz"; print "1..17\n"; diff --git a/gnu/usr.bin/perl/cpan/IO-Zlib/t/external.t b/gnu/usr.bin/perl/cpan/IO-Zlib/t/external.t index 7a9988a084d..a2764ef3194 100755 --- a/gnu/usr.bin/perl/cpan/IO-Zlib/t/external.t +++ b/gnu/usr.bin/perl/cpan/IO-Zlib/t/external.t @@ -70,7 +70,7 @@ ok(14, $@ =~ /^IO::Zlib::gzopen_external: mode 'xyz' is illegal /); # The following is a copy of the basic.t, shifted up by 14 tests, # the difference being that now we should be using the external gzip. -my $name="test.gz"; +my $name="test_external_$$.gz"; my $hello = <$name")) { diff --git a/gnu/usr.bin/perl/cpan/IO-Zlib/t/uncomp2.t b/gnu/usr.bin/perl/cpan/IO-Zlib/t/uncomp2.t index 182b9625a71..e5448a6b727 100755 --- a/gnu/usr.bin/perl/cpan/IO-Zlib/t/uncomp2.t +++ b/gnu/usr.bin/perl/cpan/IO-Zlib/t/uncomp2.t @@ -17,7 +17,7 @@ hello world this is a test EOM -my $name = "test$$"; +my $name = "test_uncomp2_$$"; if (open(FH, ">$name")) { diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP/Boolean.pm b/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP/Boolean.pm index d1ee0a477c0..146446e93d7 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP/Boolean.pm +++ b/gnu/usr.bin/perl/cpan/JSON-PP/lib/JSON/PP/Boolean.pm @@ -1,8 +1,9 @@ package JSON::PP::Boolean; use strict; -require overload; -local $^W; +use warnings; +use overload (); +overload::unimport('overload', qw(0+ ++ -- fallback)); overload::import('overload', "0+" => sub { ${$_[0]} }, "++" => sub { $_[0] = ${$_[0]} + 1 }, @@ -10,7 +11,7 @@ overload::import('overload', fallback => 1, ); -$JSON::PP::Boolean::VERSION = '4.07'; +our $VERSION = '4.16'; 1; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/001_utf8.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/001_utf8.t index e160f824161..4044e44690f 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/001_utf8.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/001_utf8.t @@ -10,17 +10,23 @@ BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } use utf8; use JSON::PP; - -ok (JSON::PP->new->allow_nonref (1)->utf8 (1)->encode ("ü") eq "\"\xc3\xbc\""); -ok (JSON::PP->new->allow_nonref (1)->encode ("ü") eq "\"ü\""); -ok (JSON::PP->new->allow_nonref (1)->ascii (1)->utf8 (1)->encode (chr 0x8000) eq '"\u8000"'); -ok (JSON::PP->new->allow_nonref (1)->ascii (1)->utf8 (1)->pretty (1)->encode (chr 0x10402) eq "\"\\ud801\\udc02\"\n"); - -eval { JSON::PP->new->allow_nonref (1)->utf8 (1)->decode ('"ü"') }; +my $pilcrow_utf8 = (ord "^" == 0x5E) ? "\xc2\xb6" # 8859-1 + : (ord "^" == 0x5F) ? "\x80\x65" # CP 1024 + : "\x78\x64"; # assume CP 037 +is (JSON::PP->new->allow_nonref (1)->utf8 (1)->encode ("¶"), "\"$pilcrow_utf8\""); +is (JSON::PP->new->allow_nonref (1)->encode ("¶"), "\"¶\""); +is (JSON::PP->new->allow_nonref (1)->ascii (1)->utf8 (1)->encode (chr 0x8000), '"\u8000"'); +is (JSON::PP->new->allow_nonref (1)->ascii (1)->utf8 (1)->pretty (1)->encode (chr 0x10402), "\"\\ud801\\udc02\"\n"); + +eval { JSON::PP->new->allow_nonref (1)->utf8 (1)->decode ('"¶"') }; ok $@ =~ /malformed UTF-8/; -ok (JSON::PP->new->allow_nonref (1)->decode ('"ü"') eq "ü"); -ok (JSON::PP->new->allow_nonref (1)->decode ('"\u00fc"') eq "ü"); -ok (JSON::PP->new->allow_nonref (1)->decode ('"\ud801\udc02' . "\x{10204}\"") eq "\x{10402}\x{10204}"); -ok (JSON::PP->new->allow_nonref (1)->decode ('"\"\n\\\\\r\t\f\b"') eq "\"\012\\\015\011\014\010"); +is (JSON::PP->new->allow_nonref (1)->decode ('"¶"'), "¶"); +is (JSON::PP->new->allow_nonref (1)->decode ('"\u00b6"'), "¶"); +is (JSON::PP->new->allow_nonref (1)->decode ('"\ud801\udc02' . "\x{10204}\""), "\x{10402}\x{10204}"); + +my $controls = (ord "^" == 0x5E) ? "\012\\\015\011\014\010" + : (ord "^" == 0x5F) ? "\025\\\015\005\014\026" # CP 1024 + : "\045\\\015\005\014\026"; # assume CP 037 +is (JSON::PP->new->allow_nonref (1)->decode ('"\"\n\\\\\r\t\f\b"'), "\"$controls"); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/003_types.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/003_types.t index 11a73e2d148..feaeeb224c6 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/003_types.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/003_types.t @@ -3,7 +3,7 @@ use strict; use warnings; use Test::More; -BEGIN { plan tests => 76 + 2 }; +BEGIN { plan tests => 78 + 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } @@ -47,6 +47,14 @@ ok ('[null]' eq encode_json [undef]); ok ('[true]' eq encode_json [JSON::PP::true]); ok ('[false]' eq encode_json [JSON::PP::false]); +SKIP: { + skip "core booleans not supported", 2 + unless JSON::PP->can("CORE_BOOL") && JSON::PP::CORE_BOOL(); + + ok ('[true]' eq encode_json [!!1]); + ok ('[false]' eq encode_json [!!0]); +} + for my $v (1, 2, 3, 5, -1, -2, -3, -4, 100, 1000, 10000, -999, -88, -7, 7, 88, 999, -1e5, 1e6, 1e7, 1e8) { ok ($v == ((decode_json "[$v]")->[0])); ok ($v == ((decode_json encode_json [$v])->[0])); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/004_dwiw_encode.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/004_dwiw_encode.t index 32e4500fee3..f413e87650c 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/004_dwiw_encode.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/004_dwiw_encode.t @@ -7,12 +7,10 @@ use strict; use warnings; -use Test; +use Test::More tests => 5; # main { - BEGIN { plan tests => 5 } - BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } use JSON::PP; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/005_dwiw_decode.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/005_dwiw_decode.t index 9bfe2fd07e6..ab195ad4250 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/005_dwiw_decode.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/005_dwiw_decode.t @@ -7,12 +7,10 @@ use strict; use warnings; -use Test; +use Test::More tests => 7; # main { - BEGIN { plan tests => 7 } - BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } use JSON::PP; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/008_pc_base.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/008_pc_base.t index 762edfd9656..e717baefbe9 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/008_pc_base.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/008_pc_base.t @@ -77,7 +77,7 @@ $obj = $pc->decode($js); is($obj->[0],"\x01"); $obj = ["\e"]; -is($js = $pc->encode($obj),'["\\u001b"]'); +is($js = $pc->encode($obj), (ord("A") == 65) ? '["\\u001b"]' : '["\\u0027"]'); $obj = $pc->decode($js); is($obj->[0],"\e"); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/014_latin1.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/014_latin1.t index 7030db86378..cef90580f1f 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/014_latin1.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/014_latin1.t @@ -11,9 +11,9 @@ use JSON::PP; my $pp = JSON::PP->new->latin1->allow_nonref; -ok ($pp->encode ("\x{12}\x{89} ") eq "\"\\u0012\x{89} \""); -ok ($pp->encode ("\x{12}\x{89}\x{abc}") eq "\"\\u0012\x{89}\\u0abc\""); +ok ($pp->encode ("\x{12}\x{b6} ") eq "\"\\u0012\x{b6} \""); +ok ($pp->encode ("\x{12}\x{b6}\x{abc}") eq "\"\\u0012\x{b6}\\u0abc\""); -ok ($pp->decode ("\"\\u0012\x{89}\"" ) eq "\x{12}\x{89}"); -ok ($pp->decode ("\"\\u0012\x{89}\\u0abc\"") eq "\x{12}\x{89}\x{abc}"); +ok ($pp->decode ("\"\\u0012\x{b6}\"" ) eq "\x{12}\x{b6}"); +ok ($pp->decode ("\"\\u0012\x{b6}\\u0abc\"") eq "\x{12}\x{b6}\x{abc}"); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/020_faihu.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/020_faihu.t index 3aa2902a9c9..28bc18b0e22 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/020_faihu.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/020_faihu.t @@ -7,8 +7,6 @@ use warnings; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } -BEGIN { if ($] < 5.008) { require Test::More; Test::More::plan(skip_all => "requires Perl 5.8 or later"); } }; - use JSON::PP; use Encode qw(encode decode); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/020_unknown.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/020_unknown.t index 6ab5b79040f..4dceff8587c 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/020_unknown.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/020_unknown.t @@ -29,10 +29,6 @@ is( $json->encode( [ \undef ] ), '[null]' ); is( $json->encode( [ \{} ] ), '[null]' ); -SKIP: { - - skip "this test is for Perl 5.8 or later", 2 if( $] < 5.008 ); - $json->allow_unknown(0); my $fh; @@ -48,5 +44,3 @@ is( $json->encode( [ $fh ] ), '[null]' ); close $fh; unlink('hoge.txt'); - -} diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary.pl b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary.pl new file mode 100644 index 00000000000..d0747da6aba --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary.pl @@ -0,0 +1,52 @@ +# copied over from JSON::XS and modified to use JSON::PP + +use strict; +use warnings; +use Test::More; +BEGIN { + if (defined(my $n= $ENV{JSONPP_CHUNK})) { + $ENV{JSONPP_FROM}= 1 + $n * 48; + $ENV{JSONPP_TO}= (1 + $n) * 48; + } + $ENV{JSONPP_FROM} = 1 unless defined $ENV{JSONPP_FROM}; + $ENV{JSONPP_TO} = 768 unless defined $ENV{JSONPP_TO}; +} +BEGIN { plan tests => 32 * ($ENV{JSONPP_TO} - $ENV{JSONPP_FROM} + 1) }; + +BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } + +use JSON::PP; + + +sub test($) { + my $js; + + $js = JSON::PP->new->allow_nonref(0)->utf8->ascii->shrink->encode ([$_[0]]); + ok ($_[0] eq ((decode_json $js)->[0]), " - 0"); + $js = JSON::PP->new->allow_nonref(0)->utf8->ascii->encode ([$_[0]]); + ok ($_[0] eq (JSON::PP->new->utf8->shrink->decode($js))->[0], " - 1"); + + $js = JSON::PP->new->allow_nonref(0)->utf8->shrink->encode ([$_[0]]); + ok ($_[0] eq ((decode_json $js)->[0]), " - 2"); + $js = JSON::PP->new->allow_nonref(1)->utf8->encode ([$_[0]]); + ok ($_[0] eq (JSON::PP->new->utf8->shrink->decode($js))->[0], " - 3"); + + $js = JSON::PP->new->allow_nonref(1)->ascii->encode ([$_[0]]); + ok ($_[0] eq JSON::PP->new->decode ($js)->[0], " - 4"); + $js = JSON::PP->new->allow_nonref(0)->ascii->encode ([$_[0]]); + ok ($_[0] eq JSON::PP->new->shrink->decode ($js)->[0], " - 5"); + + $js = JSON::PP->new->allow_nonref(1)->shrink->encode ([$_[0]]); + ok ($_[0] eq JSON::PP->new->decode ($js)->[0], " - 6"); + $js = JSON::PP->new->allow_nonref(0)->encode ([$_[0]]); + ok ($_[0] eq JSON::PP->new->shrink->decode ($js)->[0], " - 7"); +} + +srand $ENV{JSONPP_FROM}; # doesn't help too much, but its at least more deterministic + +for ($ENV{JSONPP_FROM} .. $ENV{JSONPP_TO}) { + test join "", map chr ($_ & 255), 0..$_; + test join "", map chr rand 255, 0..$_; + test join "", map chr ($_ * 97 & ~0x4000), 0..$_; + test join "", map chr (rand (2**20) & ~0x800), 0..$_; +} diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary00.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary00.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary00.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary01.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary01.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary01.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary02.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary02.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary02.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary03.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary03.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary03.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary04.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary04.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary04.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary05.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary05.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary05.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary06.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary06.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary06.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary07.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary07.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary07.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary08.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary08.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary08.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary09.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary09.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary09.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary10.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary10.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary10.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary11.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary11.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary11.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary12.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary12.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary12.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary13.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary13.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary13.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary14.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary14.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary14.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary15.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary15.t new file mode 100644 index 00000000000..9fa1c265173 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/099_binary15.t @@ -0,0 +1,3 @@ +$0=~/binary(\d\d)/ or die "Could not detect chunk from '$0'"; +$ENV{JSONPP_CHUNK} = 0+$1; +do "./t/099_binary.pl"; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/105_esc_slash.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/105_esc_slash.t index ae2d7d207b7..56f415cf020 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/105_esc_slash.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/105_esc_slash.t @@ -1,6 +1,6 @@ use Test::More; -use strict; +use strict; use warnings; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/106_allow_barekey.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/106_allow_barekey.t index f5c91893461..20918bbdc2a 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/106_allow_barekey.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/106_allow_barekey.t @@ -1,6 +1,6 @@ use Test::More; -use strict; +use strict; use warnings; BEGIN { plan tests => 2 }; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/107_allow_singlequote.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/107_allow_singlequote.t index 5948f418411..b3462f9775b 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/107_allow_singlequote.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/107_allow_singlequote.t @@ -1,6 +1,6 @@ use Test::More; -use strict; +use strict; use warnings; BEGIN { plan tests => 4 }; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/108_decode.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/108_decode.t index e0cec290154..3282c853ada 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/108_decode.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/108_decode.t @@ -5,10 +5,12 @@ use strict; use warnings; use Test::More; -BEGIN { plan tests => 6 }; +BEGIN { plan tests => 7 }; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } +my $isASCII = ord "A" == 65; + use JSON::PP; no utf8; @@ -22,16 +24,23 @@ is($json->decode(q|"\u00c3\u00bc"|), "\xc3\xbc"); # utf8 my $str = 'あ'; # Japanese 'a' in utf8 -is($json->decode(q|"\u00e3\u0081\u0082"|), $str); +is($json->decode(($isASCII) ? q|"\u00e3\u0081\u0082"| + : q|"\u00ce\u0043\u0043"|), + $str); utf8::decode($str); # usually UTF-8 flagged on, but no-op for 5.005. is($json->decode(q|"\u3042"|), $str); -my $utf8 = $json->decode(q|"\ud808\udf45"|); # chr 12345 +# chr 0x12400, which was chosen because it has the same representation in +# both EBCDIC 1047 and 037 +my $utf8 = $json->decode(q|"\ud809\udc00"|); utf8::encode($utf8); # UTF-8 flagged off -is($utf8, "\xf0\x92\x8d\x85"); +is($utf8, ($isASCII) ? "\xf0\x92\x90\x80" : "\xDE\x4A\x41\x41"); +eval { $json->decode(q|{"action":"foo" "method":"bar","tid":1}|) }; +my $error = $@; +like $error => qr!""method":"bar","tid"..."!; diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/109_encode.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/109_encode.t index 95f7764ff2e..bd0dcf42324 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/109_encode.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/109_encode.t @@ -15,21 +15,30 @@ no utf8; my $json = JSON::PP->new->allow_nonref; -is($json->encode("ü"), q|"ü"|); # as is +# U+00B6 chosen because it works on both ASCII and EBCDIC +is($json->encode("¶"), q|"¶"|); # as is $json->ascii; -is($json->encode("\xfc"), q|"\u00fc"|); # latin1 -is($json->encode("\xc3\xbc"), q|"\u00c3\u00bc"|); # utf8 -is($json->encode("ü"), q|"\u00c3\u00bc"|); # utf8 -is($json->encode('あ'), q|"\u00e3\u0081\u0082"|); +is($json->encode("\xb6"), q|"\u00b6"|); # latin1 -if ($] >= 5.006) { - is($json->encode(chr hex 3042 ), q|"\u3042"|); - is($json->encode(chr hex 12345 ), q|"\ud808\udf45"|); +if (ord "A" == 65) { + is($json->encode("\xc2\xb6"), q|"\u00c2\u00b6"|); # utf8 + is($json->encode("¶"), q|"\u00c2\u00b6"|); # utf8 + is($json->encode('あ'), q|"\u00e3\u0081\u0082"|); } else { - is($json->encode(chr hex 3042 ), $json->encode(chr 66)); - is($json->encode(chr hex 12345 ), $json->encode(chr 69)); + if (ord '^' == 95) { # EBCDIC 1047 + is($json->encode("\x80\x65"), q|"\u0080\u0065"|); # utf8 + is($json->encode("¶"), q|"\u0080\u0065"|); # utf8 + } + else { # Assume EBCDIC 037 + is($json->encode("\x78\x64"), q|"\u0078\u0064"|); # utf8 + is($json->encode("¶"), q|"\u0078\u0064"|); # utf8 + } + + is($json->encode('あ'), (q|"\u00ce\u0043\u0043"|)); } +is($json->encode(chr hex 3042 ), q|"\u3042"|); +is($json->encode(chr hex 12345 ), q|"\ud808\udf45"|); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/112_upgrade.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/112_upgrade.t index 853439a174d..681ce67f650 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/112_upgrade.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/112_upgrade.t @@ -9,17 +9,17 @@ BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } use JSON::PP; my $json = JSON::PP->new->allow_nonref->utf8; -my $str = '\\u00c8'; +my $str = '\\u00b6'; -my $value = $json->decode( '"\\u00c8"' ); +my $value = $json->decode( '"\\u00b6"' ); #use Devel::Peek; #Dump( $value ); -is( $value, chr 0xc8 ); +is( $value, chr 0xb6 ); ok( utf8::is_utf8( $value ) ); -eval { $json->decode( '"' . chr(0xc8) . '"' ) }; +eval { $json->decode( '"' . chr(0xb6) . '"' ) }; ok( $@ =~ /malformed UTF-8 character in JSON string/ ); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/118_boolean_values.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/118_boolean_values.t index f575b72290a..1019b39070a 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/118_boolean_values.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/118_boolean_values.t @@ -4,8 +4,6 @@ use Test::More; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } use JSON::PP; -BEGIN { plan skip_all => "requires Perl 5.008 or later" if $] < 5.008 } - #SKIP_ALL_UNLESS_XS4_COMPAT package # diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/119_incr_parse_utf8.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/119_incr_parse_utf8.t new file mode 100644 index 00000000000..90916fbbe23 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/119_incr_parse_utf8.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More tests => 24; + +use utf8; +use JSON::PP; +use Encode; +use charnames qw< :full >; + +use vars qw< @vs >; + +############################################################ +### These first tests mimic the ones in `t/001_utf8.t` ### +############################################################ + +scalar eval { JSON::PP->new->allow_nonref (1)->utf8 (1)->incr_parse ('"ü"') }; +like $@, qr/malformed UTF-8/; + +ok (JSON::PP->new->allow_nonref (1)->incr_parse ('"ü"') eq "ü"); +ok (JSON::PP->new->allow_nonref (1)->incr_parse ('"\u00fc"') eq "ü"); +ok (JSON::PP->new->allow_nonref (1)->incr_parse ('"\ud801\udc02' . "\x{10204}\"") eq "\x{10402}\x{10204}"); +ok (JSON::PP->new->allow_nonref (1)->incr_parse ('"\"\n\\\\\r\t\f\b"') eq "\"\012\\\015\011\014\010"); + + +my $JSON_TXT = <utf8' ### +####################### + +@vs = eval { JSON::PP->new->utf8->incr_parse( $JSON_TXT ) }; +like $@, qr/Wide character in subroutine entry/; + + +@vs = eval { JSON::PP->new->utf8->incr_parse( encode 'UTF-8' => $JSON_TXT ) }; + +ok( !$@ ); +ok( scalar @vs == 3 ); + +is_deeply( \@vs, [ { a => "1" }, { b => "\N{BULLET}" }, { c => "3" } ] ); +is_deeply( $vs[0], { a => "1" } ); +is_deeply( $vs[1], { b => "\N{BULLET}" } ); +is_deeply( $vs[2], { c => "3" } ); + + +# Double-Encoded => "You Get What You Ask For" + +@vs = eval { JSON::PP->new->utf8->incr_parse( encode 'UTF-8' => ( encode 'UTF-8' => $JSON_TXT ) ) }; + +ok( !$@ ); +ok( scalar @vs == 3 ); + +is_deeply( \@vs, [ { a => "1" }, { b => "\x{E2}\x{80}\x{A2}" }, { c => "3" } ] ); +is_deeply( $vs[0], { a => "1" } ); +is_deeply( $vs[1], { b => "\x{E2}\x{80}\x{A2}" } ); +is_deeply( $vs[2], { c => "3" } ); + + +########################## +### Without '->utf8' ### +########################## + +@vs = eval { JSON::PP->new->incr_parse( $JSON_TXT ) }; + +ok( !$@ ); +ok( scalar @vs == 3 ); + +is_deeply( \@vs, [ { a => "1" }, { b => "\N{BULLET}" }, { c => "3" } ] ); +is_deeply( $vs[0], { a => "1" } ); +is_deeply( $vs[1], { b => "\N{BULLET}" } ); +is_deeply( $vs[2], { c => "3" } ); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/120_incr_parse_truncated.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/120_incr_parse_truncated.t new file mode 100644 index 00000000000..ea37ee46c2c --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/120_incr_parse_truncated.t @@ -0,0 +1,218 @@ +use strict; +use warnings; +use Test::More; +use JSON::PP; + +plan tests => 19 * 3 + 1 * 6; + +sub run_test { + my ($input, $sub) = @_; + $sub->($input); +} + +run_test('{"one": 1}', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok ($res, "curly braces okay -- '$input'"); + ok (!$e, "no error -- '$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error"); +}); + +run_test('{"one": 1]', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "unbalanced curly braces -- '$input'"); + ok ($e, "got error -- '$input'"); + like ($e, qr/, or \} expected while parsing object\/hash/, "'} expected' json string error"); +}); + +run_test('"', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('[', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('}', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok ($e, "no error for input='$input'"); + like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); +}); + +run_test(']', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok ($e, "no error for input='$input'"); + like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); +}); + +run_test('1', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok ($res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); +}); + +run_test('1', sub { + my $input = shift; + my $coder = JSON::PP->new->allow_nonref(0); + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok ($e, "no error for input='$input'"); + like ($e, qr/JSON text must be an object or array/, "'JSON text must be an object or array' json string error for input='$input'"); +}); + +run_test('"1', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); +}); + +run_test('\\', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok ($e, "no error for input='$input'"); + like ($e, qr/malformed JSON string/, "'malformed JSON string' json string error for input='$input'"); +}); + +run_test('{"one": "', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": {', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": [', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": t', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": \\', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": ', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": 1', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); +}); + +run_test('{"one": {"two": 2', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated '$input'"); + ok (!$e, "no error -- '$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error -- $input"); +}); + +# Test Appending Closing '}' Curly Bracket +run_test('{"one": 1', sub { + my $input = shift; + my $coder = JSON::PP->new; + my $res = eval { $coder->incr_parse($input) }; + my $e = $@; # test more clobbers $@, we need it twice + ok (!$res, "truncated input='$input'"); + ok (!$e, "no error for input='$input'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input'"); + + $res = eval { $coder->incr_parse('}') }; + $e = $@; # test more clobbers $@, we need it twice + ok ($res, "truncated input='$input' . '}'"); + ok (!$e, "no error for input='$input' . '}'"); + unlike ($e, qr/, or \} expected while parsing object\/hash/, "No '} expected' json string error for input='$input' . '}'"); +}); diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/core_bools.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/core_bools.t new file mode 100644 index 00000000000..c48093bbac0 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/core_bools.t @@ -0,0 +1,85 @@ +use strict; +use warnings; +use JSON::PP; +use Test::More; +BEGIN { + # this is only for JSON.pm + plan skip_all => 'no support for core boolean options' + unless JSON::PP->can('CORE_BOOL'); +} + +plan tests => 24; + +my $json = JSON::PP->new; + +is $json->get_core_bools, !!0, 'core_bools initially false'; + +$json->boolean_values(!!0, !!1); +SKIP: { + skip "core_bools option doesn't register as true for core bools without core boolean support", 1 + unless JSON::PP::CORE_BOOL; + + is $json->get_core_bools, !!1, 'core_bools true when setting bools to core bools'; +} + +$json->boolean_values(!!1, !!0); +is $json->get_core_bools, !!0, 'core_bools false when setting bools to anything other than correct core bools'; + +my $ret = $json->core_bools; +is $ret, $json, + "returns the same object"; + +my ($new_false, $new_true) = $json->get_boolean_values; + +# ensure this registers as true on older perls where the boolean values +# themselves can't be tracked. +is $json->get_core_bools, !!1, 'core_bools true when setting core_bools'; + +ok defined $new_true, "core true value is defined"; +ok defined $new_false, "core false value is defined"; + +ok !ref $new_true, "core true value is not blessed"; +ok !ref $new_false, "core falase value is not blessed"; + +{ + my @warnings; + local $SIG{__WARN__} = sub { + push @warnings, @_; + warn @_; + }; + + cmp_ok $new_true, 'eq', '1', 'core true value is "1"'; + cmp_ok $new_true, '==', 1, 'core true value is 1'; + + cmp_ok $new_false, 'eq', '', 'core false value is ""'; + cmp_ok $new_false, '==', 0, 'core false value is 0'; + + is scalar @warnings, 0, 'no warnings'; +} + +SKIP: { + skip "core boolean support needed to detect core booleans", 4 + unless JSON::PP::CORE_BOOL; + BEGIN { JSON::PP::CORE_BOOL and warnings->unimport(qw(experimental::builtin)) } + ok JSON::PP::is_bool($new_true), 'core true is a boolean'; + ok JSON::PP::is_bool($new_false), 'core false is a boolean'; + + ok builtin::is_bool($new_true), 'core true is a core boolean'; + ok builtin::is_bool($new_false), 'core false is a core boolean'; +} + +my $should_true = $json->allow_nonref(1)->decode('true'); +my $should_false = $json->allow_nonref(1)->decode('false'); + +ok !ref $should_true && $should_true, "JSON true turns into an unblessed true value"; +ok !ref $should_false && !$should_false, "JSON false turns into an unblessed false value"; + +SKIP: { + skip "core boolean support needed to detect core booleans", 4 + unless JSON::PP::CORE_BOOL; + ok JSON::PP::is_bool($should_true), 'decoded true is a boolean'; + ok JSON::PP::is_bool($should_false), 'decoded false is a boolean'; + + ok JSON::PP::is_bool($should_true), 'decoded true is a core boolean'; + ok JSON::PP::is_bool($should_false), 'decoded false is a core boolean'; +} diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/gh_28_json_test_suite.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/gh_28_json_test_suite.t index ffbe2942dfb..3df2e6c6aba 100644 --- a/gnu/usr.bin/perl/cpan/JSON-PP/t/gh_28_json_test_suite.t +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/gh_28_json_test_suite.t @@ -5,8 +5,6 @@ use strict; use warnings; use Test::More; -BEGIN { plan skip_all => 'this test is for Perl 5.8 or later' if $] < 5.008; } - BEGIN { plan tests => 20 }; BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } diff --git a/gnu/usr.bin/perl/cpan/JSON-PP/t/rt_122270_old_xs_boolean.t b/gnu/usr.bin/perl/cpan/JSON-PP/t/rt_122270_old_xs_boolean.t new file mode 100644 index 00000000000..a3deb48787d --- /dev/null +++ b/gnu/usr.bin/perl/cpan/JSON-PP/t/rt_122270_old_xs_boolean.t @@ -0,0 +1,33 @@ +# copied over from JSON::XS and modified to use JSON::PP + +use strict; +use warnings; +use Test::More; +BEGIN { plan tests => 10 }; + +BEGIN { $ENV{PERL_JSON_BACKEND} = 0; } + +use utf8; +use JSON::PP; + +SKIP: { + skip "no JSON::XS < 3", 5 unless eval { require JSON::XS; JSON::XS->VERSION < 3 }; + + my $false = JSON::XS::false(); + ok (JSON::PP::is_bool $false); + ok (++$false == 1); + ok (!JSON::PP::is_bool $false); + ok (!JSON::PP::is_bool "JSON::PP::Boolean"); + ok (!JSON::PP::is_bool {}); # GH-34 +} + +SKIP: { + skip "no Types::Serialiser 0.01", 5 unless eval { require JSON::XS; JSON::XS->VERSION(3.00); require Types::Serialiser; Types::Serialiser->VERSION == 0.01 }; + + my $false = JSON::XS::false(); + ok (JSON::PP::is_bool $false); + ok (++$false == 1); + ok (!JSON::PP::is_bool $false); + ok (!JSON::PP::is_bool "JSON::PP::Boolean"); + ok (!JSON::PP::is_bool {}); # GH-34 +} diff --git a/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/Base64.pm b/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/Base64.pm index 923c888da4c..3605481a79c 100644 --- a/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/Base64.pm +++ b/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/Base64.pm @@ -8,7 +8,7 @@ our @ISA = qw(Exporter); our @EXPORT = qw(encode_base64 decode_base64); our @EXPORT_OK = qw(encode_base64url decode_base64url encoded_base64_length decoded_base64_length); -our $VERSION = '3.16'; +our $VERSION = '3.16_01'; require XSLoader; XSLoader::load('MIME::Base64', $VERSION); diff --git a/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/QuotedPrint.pm b/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/QuotedPrint.pm index fe792ad30ea..4539f00455c 100644 --- a/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/QuotedPrint.pm +++ b/gnu/usr.bin/perl/cpan/MIME-Base64/lib/MIME/QuotedPrint.pm @@ -7,7 +7,7 @@ require Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(encode_qp decode_qp); -our $VERSION = '3.16'; +our $VERSION = '3.16_01'; use MIME::Base64; # will load XS version of {en,de}code_qp() diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/t/biglog.t b/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/t/biglog.t index 18f959b39c6..a33eedf31b8 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/t/biglog.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt-FastCalc/t/biglog.t @@ -35,7 +35,6 @@ is($class->new(1)->bexp(), '2', "$class->new(1)->bexp()"); is($class->new(2)->bexp(), '7', "$class->new(2)->bexp()"); is($class->new(3)->bexp(), '20', "$class->new(3)->bexp()"); -############################################################################### ############################################################################### # Math::BigFloat tests @@ -146,7 +145,7 @@ is($class->new("10")->bpow("0.6", 10), "3.981071706", qq|$class->new("10")->bpow("0.6", 10)|); # blog should handle bigint input -is(Math::BigFloat::blog(Math::BigInt->new(100), 10), 2, "blog(100)"); +is(Math::BigFloat->blog(Math::BigInt->new(100), 10), 2, "blog(100)"); ############################################################################### # some integer results @@ -190,9 +189,9 @@ test_bpow('9.86902225', '0.5', undef, '3.1415'); test_bpow('0.2', '0.41', 10, '0.5169187652'); -is($class->new("0.01")->bpow("28.4", 40)->bsstr(), - '1584893192461113485202101373391507013269e-96', - qq|$class->new("0.01")->bpow("28.4", 40)->bsstr()|); +is($class->new("0.1")->bpow("28.4", 40)->bsstr(), + '3981071705534972507702523050877520434877e-68', + qq|$class->new("0.1")->bpow("28.4", 40)->bsstr()|); # The following test takes too long. #is($class->new("2")->bpow("-1034.5", 40)->bsstr(), @@ -231,8 +230,6 @@ is($class->new("-394.84010945715266885")->bexp(20)->bsstr(), # all done -1; - ############################################################################### sub test_bpow { diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Lib.pm b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Lib.pm index 55ba01059ba..37fa9b94de5 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Lib.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/lib/Math/BigInt/Lib.pm @@ -4,7 +4,7 @@ use 5.006001; use strict; use warnings; -our $VERSION = '1.999830'; +our $VERSION = '1.999837'; $VERSION =~ tr/_//d; use Carp; @@ -1771,7 +1771,7 @@ sub _modinv { # modulo zero if ($class -> _is_zero($y)) { - return (undef, undef); + return; } # modulo one @@ -1801,7 +1801,7 @@ sub _modinv { } # if the gcd is not 1, there exists no modular multiplicative inverse - return (undef, undef) unless $class -> _is_one($a); + return unless $class -> _is_one($a); ($v, $sign == 1 ? '+' : '-'); } diff --git a/gnu/usr.bin/perl/cpan/Math-BigRat/t/downgrade.t b/gnu/usr.bin/perl/cpan/Math-BigRat/t/downgrade.t index d05d78a39ad..3a9f52acc95 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigRat/t/downgrade.t +++ b/gnu/usr.bin/perl/cpan/Math-BigRat/t/downgrade.t @@ -5,7 +5,7 @@ use strict; use warnings; -use Test::More tests => 33; +use Test::More tests => 141; use Math::BigInt upgrade => 'Math::BigRat'; use Math::BigRat downgrade => 'Math::BigInt'; @@ -105,3 +105,326 @@ is(ref $four, "Math::BigRat", "Creating a 4 does not downgrade"); is(ref $zero, "Math::BigRat", "Creating a 0 does not downgrade"); is(ref $inf, "Math::BigRat", "Creating an Inf does not downgrade"); is(ref $nan, "Math::BigRat", "Creating a NaN does not downgrade"); + +################################################################################ +# Verify that other methods downgrade when they should. + +Math::BigRat -> downgrade("Math::BigInt"); + +note("bneg()"); + +$x = $zero -> copy() -> bneg(); +cmp_ok($x, "==", 0, "-(0) = 0"); +is(ref($x), "Math::BigInt", "-(0) => Math::BigInt"); + +$x = $four -> copy() -> bneg(); +cmp_ok($x, "==", -4, "-(4) = -4"); +is(ref($x), "Math::BigInt", "-(4) => Math::BigInt"); + +$x = $inf -> copy() -> bneg(); +cmp_ok($x, "==", "-inf", "-(Inf) = -Inf"); +is(ref($x), "Math::BigInt", "-(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bneg(); +is($x, "NaN", "-(NaN) = NaN"); +is(ref($x), "Math::BigInt", "-(NaN) => Math::BigInt"); + +note("bnorm()"); + +$x = $zero -> copy() -> bnorm(); +cmp_ok($x, "==", 0, "bnorm(0)"); +is(ref($x), "Math::BigInt", "bnorm(0) => Math::BigInt"); + +$x = $four -> copy() -> bnorm(); +cmp_ok($x, "==", 4, "bnorm(4)"); +is(ref($x), "Math::BigInt", "bnorm(4) => Math::BigInt"); + +$x = $inf -> copy() -> bnorm(); +cmp_ok($x, "==", "inf", "bnorm(Inf)"); +is(ref($x), "Math::BigInt", "bnorm(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bnorm(); +is($x, "NaN", "bnorm(NaN)"); +is(ref($x), "Math::BigInt", "bnorm(NaN) => Math::BigInt"); + +note("binc()"); + +$x = $zero -> copy() -> binc(); +cmp_ok($x, "==", 1, "binc(0)"); +is(ref($x), "Math::BigInt", "binc(0) => Math::BigInt"); + +$x = $four -> copy() -> binc(); +cmp_ok($x, "==", 5, "binc(4)"); +is(ref($x), "Math::BigInt", "binc(4) => Math::BigInt"); + +$x = $inf -> copy() -> binc(); +cmp_ok($x, "==", "inf", "binc(Inf)"); +is(ref($x), "Math::BigInt", "binc(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> binc(); +is($x, "NaN", "binc(NaN)"); +is(ref($x), "Math::BigInt", "binc(NaN) => Math::BigInt"); + +note("bdec()"); + +$x = $zero -> copy() -> bdec(); +cmp_ok($x, "==", -1, "bdec(0)"); +is(ref($x), "Math::BigInt", "bdec(0) => Math::BigInt"); + +$x = $four -> copy() -> bdec(); +cmp_ok($x, "==", 3, "bdec(4)"); +is(ref($x), "Math::BigInt", "bdec(4) => Math::BigInt"); + +$x = $inf -> copy() -> bdec(); +cmp_ok($x, "==", "inf", "bdec(Inf)"); +is(ref($x), "Math::BigInt", "bdec(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bdec(); +is($x, "NaN", "bdec(NaN)"); +is(ref($x), "Math::BigInt", "bdec(NaN) => Math::BigInt"); + +note("badd()"); + +$x = $half -> copy() -> badd($nan); +is($x, "NaN", "0.5 + NaN = NaN"); +is(ref($x), "Math::BigInt", "0.5 + NaN => Math::BigInt"); + +$x = $half -> copy() -> badd($inf); +cmp_ok($x, "==", "+Inf", "0.5 + Inf = Inf"); +is(ref($x), "Math::BigInt", "2.5 + Inf => Math::BigInt"); + +$x = $half -> copy() -> badd($half); +cmp_ok($x, "==", 1, "0.5 + 0.5 = 1"); +is(ref($x), "Math::BigInt", "0.5 + 0.5 => Math::BigInt"); + +$x = $half -> copy() -> badd($half -> copy() -> bneg()); +cmp_ok($x, "==", 0, "0.5 + -0.5 = 0"); +is(ref($x), "Math::BigInt", "0.5 + -0.5 => Math::BigInt"); + +$x = $four -> copy() -> badd($zero); +cmp_ok($x, "==", 4, "4 + 0 = 4"); +is(ref($x), "Math::BigInt", "4 + 0 => Math::BigInt"); + +$x = $zero -> copy() -> badd($four); +cmp_ok($x, "==", 4, "0 + 4 = 4"); +is(ref($x), "Math::BigInt", "0 + 4 => Math::BigInt"); + +$x = $inf -> copy() -> badd($four); +cmp_ok($x, "==", "+Inf", "Inf + 4 = Inf"); +is(ref($x), "Math::BigInt", "Inf + 4 => Math::BigInt"); + +$x = $nan -> copy() -> badd($four); +is($x, "NaN", "NaN + 4 = NaN"); +is(ref($x), "Math::BigInt", "NaN + 4 => Math::BigInt"); + +note("bsub()"); + +$x = $half -> copy() -> bsub($nan); +is($x, "NaN", "0.5 - NaN = NaN"); +is(ref($x), "Math::BigInt", "0.5 - NaN => Math::BigInt"); + +$x = $half -> copy() -> bsub($inf); +cmp_ok($x, "==", "-Inf", "2.5 - Inf = -Inf"); +is(ref($x), "Math::BigInt", "2.5 - Inf => Math::BigInt"); + +$x = $half -> copy() -> bsub($half); +cmp_ok($x, "==", 0, "0.5 - 0.5 = 0"); +is(ref($x), "Math::BigInt", "0.5 - 0.5 => Math::BigInt"); + +$x = $half -> copy() -> bsub($half -> copy() -> bneg()); +cmp_ok($x, "==", 1, "0.5 - -0.5 = 1"); +is(ref($x), "Math::BigInt", "0.5 - -0.5 => Math::BigInt"); + +$x = $four -> copy() -> bsub($zero); +cmp_ok($x, "==", 4, "4 - 0 = 4"); +is(ref($x), "Math::BigInt", "4 - 0 => Math::BigInt"); + +$x = $zero -> copy() -> bsub($four); +cmp_ok($x, "==", -4, "0 - 4 = -4"); +is(ref($x), "Math::BigInt", "0 - 4 => Math::BigInt"); + +$x = $inf -> copy() -> bsub($four); +cmp_ok($x, "==", "Inf", "Inf - 4 = Inf"); +is(ref($x), "Math::BigInt", "Inf - 4 => Math::BigInt"); + +$x = $nan -> copy() -> bsub($four); +is($x, "NaN", "NaN - 4 = NaN"); +is(ref($x), "Math::BigInt", "NaN - 4 => Math::BigInt"); + +note("bmul()"); + +$x = $zero -> copy() -> bmul($four); +cmp_ok($x, "==", 0, "bmul(0, 4) = 0"); +is(ref($x), "Math::BigInt", "bmul(0, 4) => Math::BigInt"); + +$x = $four -> copy() -> bmul($four); +cmp_ok($x, "==", 16, "bmul(4, 4) = 16"); +is(ref($x), "Math::BigInt", "bmul(4, 4) => Math::BigInt"); + +$x = $inf -> copy() -> bmul($four); +cmp_ok($x, "==", "inf", "bmul(Inf, 4) = Inf"); +is(ref($x), "Math::BigInt", "bmul(Inf, 4) => Math::BigInt"); + +$x = $nan -> copy() -> bmul($four); +is($x, "NaN", "bmul(NaN, 4) = NaN"); +is(ref($x), "Math::BigInt", "bmul(NaN, 4) => Math::BigInt"); + +$x = $four -> copy() -> bmul("0.5"); +cmp_ok($x, "==", 2, "bmul(4, 0.5) = 2"); +is(ref($x), "Math::BigInt", "bmul(4, 0.5) => Math::BigInt"); + +# bmuladd() + +note("bdiv()"); + +note("bmod()"); + +note("bmodpow()"); + +note("bpow()"); + +note("blog()"); + +note("bexp()"); + +note("bnok()"); + +note("bsin()"); + +note("bcos()"); + +note("batan()"); + +note("batan()"); + +note("bsqrt()"); + +note("broot()"); + +note("bfac()"); + +note("bdfac()"); + +note("btfac()"); + +note("bmfac()"); + +note("blsft()"); + +note("brsft()"); + +note("band()"); + +note("bior()"); + +note("bxor()"); + +note("bnot()"); + +note("bround()"); + +# Add tests for rounding a non-integer to an integer. Fixme! + +$x = $zero -> copy() -> bround(); +cmp_ok($x, "==", 0, "bround(0)"); +is(ref($x), "Math::BigInt", "bround(0) => Math::BigInt"); + +$x = $four -> copy() -> bround(); +cmp_ok($x, "==", 4, "bround(4)"); +is(ref($x), "Math::BigInt", "bround(4) => Math::BigInt"); + +$x = $inf -> copy() -> bround(); +cmp_ok($x, "==", "inf", "bround(Inf)"); +is(ref($x), "Math::BigInt", "bround(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bround(); +is($x, "NaN", "bround(NaN)"); +is(ref($x), "Math::BigInt", "bround(NaN) => Math::BigInt"); + +note("bfround()"); + +# Add tests for rounding a non-integer to an integer. Fixme! + +$x = $zero -> copy() -> bfround(); +cmp_ok($x, "==", 0, "bfround(0)"); +is(ref($x), "Math::BigInt", "bfround(0) => Math::BigInt"); + +$x = $four -> copy() -> bfround(); +cmp_ok($x, "==", 4, "bfround(4)"); +is(ref($x), "Math::BigInt", "bfround(4) => Math::BigInt"); + +$x = $inf -> copy() -> bfround(); +cmp_ok($x, "==", "inf", "bfround(Inf)"); +is(ref($x), "Math::BigInt", "bfround(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bfround(); +is($x, "NaN", "bfround(NaN)"); +is(ref($x), "Math::BigInt", "bfround(NaN) => Math::BigInt"); + +note("bfloor()"); + +$x = $half -> copy() -> bfloor(); +cmp_ok($x, "==", 0, "bfloor(0)"); +is(ref($x), "Math::BigInt", "bfloor(0) => Math::BigInt"); + +$x = $inf -> copy() -> bfloor(); +cmp_ok($x, "==", "Inf", "bfloor(Inf)"); +is(ref($x), "Math::BigInt", "bfloor(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bfloor(); +is($x, "NaN", "bfloor(NaN)"); +is(ref($x), "Math::BigInt", "bfloor(NaN) => Math::BigInt"); + +note("bceil()"); + +$x = $half -> copy() -> bceil(); +cmp_ok($x, "==", 1, "bceil(0)"); +is(ref($x), "Math::BigInt", "bceil(0) => Math::BigInt"); + +$x = $inf -> copy() -> bceil(); +cmp_ok($x, "==", "Inf", "bceil(Inf)"); +is(ref($x), "Math::BigInt", "bceil(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bceil(); +is($x, "NaN", "bceil(NaN)"); +is(ref($x), "Math::BigInt", "bceil(NaN) => Math::BigInt"); + +note("bint()"); + +$x = $half -> copy() -> bint(); +cmp_ok($x, "==", 0, "bint(0)"); +is(ref($x), "Math::BigInt", "bint(0) => Math::BigInt"); + +$x = $inf -> copy() -> bint(); +cmp_ok($x, "==", "Inf", "bint(Inf)"); +is(ref($x), "Math::BigInt", "bint(Inf) => Math::BigInt"); + +$x = $nan -> copy() -> bint(); +is($x, "NaN", "bint(NaN)"); +is(ref($x), "Math::BigInt", "bint(NaN) => Math::BigInt"); + +note("bgcd()"); + +note("blcm()"); + +# mantissa() ? + +# exponent() ? + +# parts() ? + +# sparts() + +# nparts() + +# eparts() + +# dparts() + +# fparts() + +# numerator() + +# denominator() + +#require 'upgrade.inc'; # all tests here for sharing diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/basic.t b/gnu/usr.bin/perl/cpan/Memoize/t/basic.t new file mode 100644 index 00000000000..fd4527f539b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/basic.t @@ -0,0 +1,90 @@ +use strict; use warnings; +use Memoize; +use Test::More tests => 27; + +# here we test memoize() itself i.e. whether it sets everything up as requested +# (except for the (LIST|SCALAR)_CACHE options which are tested elsewhere) + +my ( $sub, $wrapped ); + +sub dummy {1} +$sub = \&dummy; +$wrapped = memoize 'dummy'; +isnt \&dummy, $sub, 'memoizing replaces the sub'; +is ref $wrapped, 'CODE', '... and returns a coderef'; +is \&dummy, $wrapped, '... which is the replacement'; + +sub dummy_i {1} +$sub = \&dummy_i; +$wrapped = memoize 'dummy_i', INSTALL => 'another'; +is \&dummy_i, $sub, 'INSTALL does not replace the sub'; +is \&another, $wrapped, '... but installs the memoized version where requested'; + +sub dummy_p {1} +$sub = \&dummy_p; +$wrapped = memoize 'dummy_p', INSTALL => 'another::package::too'; +is \&another::package::too, $wrapped, '... even if that is a whole other package'; + +sub find_sub { + my ( $needle, $symtbl ) = ( @_, *main::{'HASH'} ); + while ( my ( $name, $glob ) = each %$symtbl ) { + if ( $name =~ /::\z/ ) { + find_sub( $needle, *$glob{'HASH'} ) unless *$glob{'HASH'} == $symtbl; + } elsif ( defined( my $sub = eval { *$glob{'CODE'} } ) ) { + return 1 if $needle == $sub; + } + } + return !1; +} + +sub dummy_u {1} +$sub = \&dummy_u; +$wrapped = memoize 'dummy_u', INSTALL => undef; +is \&dummy_u, $sub, '... unless the passed name is undef'; +ok !find_sub( $wrapped ), '... which does not install the memoized version anywhere'; + +$sub = sub {1}; +$wrapped = memoize $sub; +is ref $wrapped, 'CODE', 'memoizing a $coderef wraps it'; +ok !find_sub( $wrapped ), '... without installing the memoized version anywhere'; + +$sub = sub {1}; +$wrapped = memoize $sub, INSTALL => 'another'; +is \&another, $wrapped, '... unless requested using INSTALL'; + +my $num_args; +sub fake_normalize { $num_args = @_ } +$wrapped = memoize sub {1}, NORMALIZER => 'fake_normalize'; +$wrapped->( ('x') x 7 ); +is $num_args, 7, 'NORMALIZER installs the requested normalizer; both by name'; +$wrapped = memoize sub {1}, NORMALIZER => \&fake_normalize; +$wrapped->( ('x') x 23 ); +is $num_args, 23, '... as well as by reference'; + +$wrapped = eval { memoize 'dummy_none' }; +is $wrapped, undef, 'memoizing a non-existent function fails'; +like $@, qr/^Cannot operate on nonexistent function `dummy_none'/, '... with the expected error'; + +for my $nonsub ({}, [], \my $x) { + is eval { memoize $nonsub }, undef, "memoizing ${\ref $nonsub} ref fails"; + like $@, qr/^Usage: memoize 'functionname'\|coderef \{OPTIONS\}/, '... with the expected error'; +} + +sub no_warnings_ok (&$) { + my $w; + local $SIG{'__WARN__'} = sub { push @$w, @_; &diag }; + shift->(); + local $Test::Builder::Level = $Test::Builder::Level + 1; + is( $w, undef, shift ) or diag join '', @$w; +} + +sub q1 ($) { $_[0] + 1 } +sub q2 () { time } +sub q3 { join "--", @_ } + +no_warnings_ok { memoize 'q1' } 'no warnings with $ protype'; +no_warnings_ok { memoize 'q2' } 'no warnings with empty protype'; +no_warnings_ok { memoize 'q3' } 'no warnings without protype'; +is q1(@{['a'..'z']}), 27, '$ prototype is honored'; +is eval('q2("test")'), undef, 'empty prototype is honored'; +like $@, qr/^Too many arguments for main::q2 /, '... with the expected error'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/cache.t b/gnu/usr.bin/perl/cpan/Memoize/t/cache.t new file mode 100644 index 00000000000..75d9dcc7403 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/cache.t @@ -0,0 +1,148 @@ +use strict; use warnings; +use Memoize 0.45 qw(memoize unmemoize); +use Fcntl; +use Test::More tests => 65; + +sub list { wantarray ? @_ : $_[-1] } + +# Test FAULT +sub ns {} +sub na {} +ok eval { memoize 'ns', SCALAR_CACHE => 'FAULT'; 1 }, 'SCALAR_CACHE => FAULT'; +ok eval { memoize 'na', LIST_CACHE => 'FAULT'; 1 }, 'LIST_CACHE => FAULT'; +is eval { scalar(ns()) }, undef, 'exception in scalar context'; +is eval { list(na()) }, undef, 'exception in list context'; + +# Test FAULT/FAULT +sub dummy {1} +for ([qw(FAULT FAULT)], [qw(FAULT MERGE)], [qw(MERGE FAULT)]) { + my ($l_opt, $s_opt) = @$_; + my $memodummy = memoize 'dummy', LIST_CACHE => $l_opt, SCALAR_CACHE => $s_opt, INSTALL => undef; + my ($ret, $e); + { local $@; $ret = eval { scalar $memodummy->() }; $e = $@ } + is $ret, undef, "scalar context fails under $l_opt/$s_opt"; + like $e, qr/^Anonymous function called in forbidden scalar context/, '... with the right error message'; + { local $@; $ret = eval { +($memodummy->())[0] }; $e = $@ } + is $ret, undef, "list context fails under $l_opt/$s_opt"; + like $e, qr/^Anonymous function called in forbidden list context/, '... with the right error message'; + unmemoize $memodummy; +} + +# Test HASH +my (%s, %l); +sub nul {} +ok eval { memoize 'nul', SCALAR_CACHE => [HASH => \%s], LIST_CACHE => [HASH => \%l]; 1 }, '*_CACHE => HASH'; +nul('x'); +nul('y'); +is_deeply [sort keys %s], [qw(x y)], 'scalar context calls populate SCALAR_CACHE'; +is_deeply \%l, {}, '... and does not touch the LIST_CACHE'; +%s = (); +() = nul('p'); +() = nul('q'); +is_deeply [sort keys %l], [qw(p q)], 'list context calls populate LIST_CACHE'; +is_deeply \%s, {}, '... and does not touch the SCALAR_CACHE'; + +# Test MERGE +sub xx { wantarray } +ok !scalar(xx()), 'false in scalar context'; +ok list(xx()), 'true in list context'; +ok eval { memoize 'xx', LIST_CACHE => 'MERGE'; 1 }, 'LIST_CACHE => MERGE'; +ok !scalar(xx()), 'false in scalar context again'; +# Should return cached false value from previous invocation +ok !list(xx()), 'still false in list context'; + +sub reff { [1,2,3] } +sub listf { (1,2,3) } + +memoize 'reff', LIST_CACHE => 'MERGE'; +memoize 'listf'; + +scalar reff(); +is_deeply [reff()], [[1,2,3]], 'reff list context after scalar context'; + +scalar listf(); +is_deeply [listf()], [1,2,3], 'listf list context after scalar context'; + +unmemoize 'reff'; +memoize 'reff', LIST_CACHE => 'MERGE'; +unmemoize 'listf'; +memoize 'listf'; + +is_deeply [reff()], [[1,2,3]], 'reff list context'; + +is_deeply [listf()], [1,2,3], 'listf list context'; + +sub f17 { return 17 } +memoize 'f17', SCALAR_CACHE => 'MERGE'; +is_deeply [f17()], [17], 'f17 first call'; +is_deeply [f17()], [17], 'f17 second call'; +is scalar(f17()), 17, 'f17 scalar context call'; + +my (%cache, $num_cache_misses); +sub cacheit { + ++$num_cache_misses; + "cacheit result"; +} +sub test_cacheit { + is scalar(cacheit()), 'cacheit result', 'scalar context'; + is $num_cache_misses, 1, 'function called once'; + + is +(cacheit())[0], 'cacheit result', 'list context'; + is $num_cache_misses, 1, 'function not called again'; + + is_deeply [values %cache], [['cacheit result']], 'expected cached value'; + + %cache = (); + + is +(cacheit())[0], 'cacheit result', 'list context'; + is $num_cache_misses, 2, 'function again called after clearing the cache'; + + is scalar(cacheit()), 'cacheit result', 'scalar context'; + is $num_cache_misses, 2, 'function not called again'; +} + +memoize 'cacheit', LIST_CACHE => [HASH => \%cache], SCALAR_CACHE => 'MERGE'; +test_cacheit; +unmemoize 'cacheit'; +( $num_cache_misses, %cache ) = (); +memoize 'cacheit', SCALAR_CACHE => [HASH => \%cache], LIST_CACHE => 'MERGE'; +test_cacheit; + +# Test errors +my @w; +my $sub = eval { + local $SIG{'__WARN__'} = sub { push @w, @_ }; + memoize(sub {}, LIST_CACHE => ['TIE', 'WuggaWugga']); +}; +is $sub, undef, 'bad TIE fails'; +like $@, qr/^Can't locate WuggaWugga.pm in \@INC/, '... with the expected error'; +like $w[0], qr/^TIE option to memoize\(\) is deprecated; use HASH instead/, '... and the expected deprecation warning'; +is @w, 1, '... and no other warnings'; + +is eval { memoize sub {}, LIST_CACHE => 'YOB GORGLE' }, undef, 'bad LIST_CACHE fails'; +like $@, qr/^Unrecognized option to `LIST_CACHE': `YOB GORGLE'/, '... with the expected error'; + +is eval { memoize sub {}, SCALAR_CACHE => ['YOB GORGLE'] }, undef, 'bad SCALAR_CACHE fails'; +like $@, qr/^Unrecognized option to `SCALAR_CACHE': `YOB GORGLE'/, '... with the expected error'; + +for my $option (qw(LIST_CACHE SCALAR_CACHE)) { + is eval { memoize sub {}, $option => ['MERGE'] }, undef, "$option=>['MERGE'] fails"; + like $@, qr/^Unrecognized option to `$option': `MERGE'/, '... with the expected error'; +} + +# this test needs a DBM which +# a) Memoize knows is scalar-only +# b) is always available (on all platforms, perl configs etc) +# c) never fails to load +# so we use AnyDBM_File (which fulfills (a) & (b)) +# on top of a fake dummy DBM (ditto (b) & (c)) +sub DummyDBM::TIEHASH { bless {}, shift } +$INC{'DummyDBM.pm'} = 1; +@AnyDBM_File::ISA = 'DummyDBM'; +$sub = eval { + no warnings; + memoize sub {}, SCALAR_CACHE => [ TIE => 'AnyDBM_File' ], LIST_CACHE => 'MERGE'; +}; +is $sub, undef, 'smuggling in a scalar-only LIST_CACHE via MERGE fails'; +like $@, qr/^You can't use AnyDBM_File for LIST_CACHE because it can only store scalars/, + '... with the expected error'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t b/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t index ae567872557..b42cc3ef1dd 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/correctness.t @@ -1,129 +1,103 @@ -#!/usr/bin/perl - -use lib '..'; +use strict; use warnings; use Memoize; +use Test::More tests => 17; -print "1..25\n"; - -print "# Basic\n"; +# here we test whether memoization actually has the desired effect -# A function that should only be called once. -{ my $COUNT = 0; - sub no_args { - $FAIL++ if $COUNT++; - 11; - } +my ($fib, $ns1_calls, $ns2_calls, $total_calls) = ([0,1], 1, 1, 1+1); +while (@$fib < 23) { + push @$fib, $$fib[-1] + $$fib[-2]; + my $n_calls = 1 + $ns1_calls + $ns2_calls; + $total_calls += $n_calls; + ($ns2_calls, $ns1_calls) = ($ns1_calls, $n_calls); } -# -memoize('no_args'); - -$c1 = &no_args(); -print (($c1 == 11) ? "ok 1\n" : "not ok 1\n"); -$c2 = &no_args(); -print (($c2 == 11) ? "ok 2\n" : "not ok 2\n"); -print $FAIL ? "not ok 3\n" : "ok 3\n"; # Was it really memoized? - -$FAIL = 0; -$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 12 } }; -$fm = memoize($f); - -$c1 = &$fm(); -print (($c1 == 12) ? "ok 4\n" : "not ok 4\n"); -$c2 = &$fm(); -print (($c2 == 12) ? "ok 5\n" : "not ok 5\n"); -print $FAIL ? "not ok 6\n" : "ok 6\n"; # Was it really memoized? - -$f = do { my $COUNT = 0; sub { $FAIL++ if $COUNT++; 13 } }; -$fm = memoize($f, INSTALL => 'another'); - -$c1 = &another(); # Was it really installed? -print (($c1 == 13) ? "ok 7\n" : "not ok 7\n"); -$c2 = &another(); -print (($c2 == 13) ? "ok 8\n" : "not ok 8\n"); -print $FAIL ? "not ok 9\n" : "ok 9\n"; # Was it really memoized? -$c3 = &$fm(); # Call memoized version through returned ref -print (($c3 == 13) ? "ok 10\n" : "not ok 10\n"); -print $FAIL ? "not ok 11\n" : "ok 11\n"; # Was it really memoized? -$c4 = &$f(); # Call original version again -print (($c4 == 13) ? "ok 12\n" : "not ok 12\n"); -print $FAIL ? "ok 13\n" : "not ok 13\n"; # Did we get the original? - -print "# Fibonacci\n"; - -sub mt1 { # Fibonacci - my $n = shift; - return $n if $n < 2; - mt1($n-1) + mt2($n-2); -} -sub mt2 { - my $n = shift; - return $n if $n < 2; - mt1($n-1) + mt2($n-2); +my $num_calls; +sub fib { + ++$num_calls; + my $n = shift; + return $n if $n < 2; + fib($n-1) + fib($n-2); } -@f1 = map { mt1($_) } (0 .. 15); -@f2 = map { mt2($_) } (0 .. 15); -memoize('mt1'); -@f3 = map { mt1($_) } (0 .. 15); -@f4 = map { mt1($_) } (0 .. 15); -@arrays = (\@f1, \@f2, \@f3, \@f4); -$n = 13; -for ($i=0; $i<3; $i++) { - for ($j=$i+1; $j<3; $j++) { - $n++; - print ((@{$arrays[$i]} == @{$arrays[$j]}) ? "ok $n\n" : "not ok $n\n"); - $n++; - for ($k=0; $k < @{$arrays[$i]}; $k++) { - (print "not ok $n\n", next) if $arrays[$i][$k] != $arrays[$j][$k]; - } - print "ok $n\n"; - } -} +my @s1 = map 0+fib($_), 0 .. $#$fib; +is_deeply \@s1, $fib, 'unmemoized Fibonacci works'; +is $num_calls, $total_calls, '... with the expected amount of calls'; +undef $num_calls; +memoize 'fib'; +my @f1 = map 0+fib($_), 0 .. $#$fib; +my @f2 = map 0+fib($_), 0 .. $#$fib; +is_deeply \@f1, $fib, 'memoized Fibonacci works'; +is $num_calls, @$fib, '... with a minimal amount of calls'; -print "# Normalizers\n"; +######################################################################## -sub fake_normalize { - return ''; -} +my $timestamp; +sub timelist { (++$timestamp) x $_[0] } -sub f1 { - return shift; -} -sub f2 { - return shift; -} -sub f3 { - return shift; -} -&memoize('f1'); -&memoize('f2', NORMALIZER => 'fake_normalize'); -&memoize('f3', NORMALIZER => \&fake_normalize); -@f1r = map { f1($_) } (1 .. 10); -@f2r = map { f2($_) } (1 .. 10); -@f3r = map { f3($_) } (1 .. 10); -$n++; -print (("@f1r" eq "1 2 3 4 5 6 7 8 9 10") ? "ok $n\n" : "not ok $n\n"); -$n++; -print (("@f2r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n"); -$n++; -print (("@f3r" eq "1 1 1 1 1 1 1 1 1 1") ? "ok $n\n" : "not ok $n\n"); - -print "# INSTALL => undef option.\n"; -{ my $i = 1; - sub u1 { $i++ } +memoize('timelist'); + +my $t1 = [timelist(1)]; +is_deeply [timelist(1)], $t1, 'memoizing a volatile function makes it stable'; +my $t7 = [timelist(7)]; +isnt @$t1, @$t7, '... unless the arguments change'; +is_deeply $t7, [($$t7[0]) x 7], '... which leads to the expected new return value'; +is_deeply [timelist(7)], $t7, '... which then also stays stable'; + +sub con { wantarray ? 'list' : 'scalar' } +memoize('con'); +is scalar(con(1)), 'scalar', 'scalar context propgates properly'; +is_deeply [con(1)], ['list'], 'list context propgates properly'; + +######################################################################## + +my %underlying; +sub ExpireTest::TIEHASH { bless \%underlying, shift } +sub ExpireTest::EXISTS { exists $_[0]{$_[1]} } +sub ExpireTest::FETCH { $_[0]{$_[1]} } +sub ExpireTest::STORE { $_[0]{$_[1]} = $_[2] } + +my %CALLS; +sub id { + my($arg) = @_; + ++$CALLS{$arg}; + $arg; } -my $um = memoize('u1', INSTALL => undef); -@umr = (&$um, &$um, &$um); -@u1r = (&u1, &u1, &u1 ); # Did *not* clobber &u1 -$n++; -print (("@umr" eq "1 1 1") ? "ok $n\n" : "not ok $n\n"); # Increment once -$n++; -print (("@u1r" eq "2 3 4") ? "ok $n\n" : "not ok $n\n"); # Increment thrice -$n++; -print ((defined &{"undef"}) ? "not ok $n\n" : "ok $n\n"); # Just in case - -print "# $n tests in all.\n"; +tie my %cache => 'ExpireTest'; +memoize 'id', + SCALAR_CACHE => [HASH => \%cache], + LIST_CACHE => 'FAULT'; + +my $arg = [1..3, 1, 2, 1]; +is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; +is_deeply \%CALLS, {1=>1,2=>1,3=>1}, 'amount of initial calls per arg as expected'; + +delete $underlying{1}; +$arg = [1..3]; +is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; +is_deeply \%CALLS, {1=>2,2=>1,3=>1}, 'amount of calls per arg after expiring 1 as expected'; + +delete @underlying{1,2}; +is_deeply [map scalar(id($_)), @$arg], $arg, 'memoized function sanity check'; +is_deeply \%CALLS, {1=>3,2=>2,3=>1}, 'amount of calls per arg after expiring 1 & 2 as expected'; + +######################################################################## + +my $fail; +$SIG{__WARN__} = sub { if ( $_[0] =~ /^Deep recursion/ ) { $fail = 1 } else { warn $_[0] } }; + +my $limit; +sub deep_probe { deep_probe() if ++$limit < 100_000 and not $fail } +sub deep_test { no warnings "recursion"; deep_test() if $limit-- > 0 } +memoize "deep_test"; + +SKIP: { + deep_probe(); + skip "no warning after $limit recursive calls (maybe PERL_SUB_DEPTH_WARN was raised?)", 1 if not $fail; + undef $fail; + deep_test(); + ok !$fail, 'no recursion warning thrown from Memoize'; +} diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/expmod.t b/gnu/usr.bin/perl/cpan/Memoize/t/expmod.t new file mode 100644 index 00000000000..4e82b3904b8 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/expmod.t @@ -0,0 +1,57 @@ +use strict; use warnings; +use Memoize; +use Memoize::Expire; +use Test::More tests => 22; + +tie my %h => 'Memoize::Expire', HASH => \my %backing; + +$h{foo} = 1; +my $num_keys = keys %backing; +my $num_refs = grep ref, values %backing; + +is $h{foo}, 1, 'setting and getting a plain scalar value works'; +cmp_ok $num_keys, '>', 0, 'HASH option is effective'; +is $num_refs, 0, 'backing storage contains only plain scalars'; + +$h{bar} = my $bar = {}; +my $num_keys_step2 = keys %backing; +$num_refs = grep ref, values %backing; + +is ref($h{bar}), ref($bar), 'setting and getting a reference value works'; +cmp_ok $num_keys, '<', $num_keys_step2, 'HASH option is effective'; +is $num_refs, 1, 'backing storage contains only one reference'; + +my $contents = eval { +{ %h } }; + +ok defined $contents, 'dumping the tied hash works'; +is_deeply $contents, { foo => 1, bar => $bar }, ' ... with the expected contents'; + +######################################################################## + +my $RETURN = 1; +my %CALLS; + +tie my %cache => 'Memoize::Expire', NUM_USES => 2; +memoize sub { ++$CALLS{$_[0]}; $RETURN }, + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT', + INSTALL => 'call'; + +is call($_), 1, "$_ gets new val" for 0..3; + +is_deeply \%CALLS, {0=>1,1=>1,2=>1,3=>1}, 'memoized function called once per argument'; + +$RETURN = 2; +is call(1), 1, '1 expires'; +is call(1), 2, '1 gets new val'; +is call(2), 1, '2 expires'; + +is_deeply \%CALLS, {0=>1,1=>2,2=>1,3=>1}, 'memoized function called for expired argument'; + +$RETURN = 3; +is call(0), 1, '0 expires'; +is call(1), 2, '1 expires'; +is call(2), 3, '2 gets new val'; +is call(3), 1, '3 expires'; + +is_deeply \%CALLS, {0=>1,1=>2,2=>2,3=>1}, 'memoized function called for other expired argument'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t b/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t index 3573c216854..1b63b09defe 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t @@ -1,9 +1,6 @@ -#!/usr/bin/perl - -# test caching timeout - -use lib '..'; +use strict; use warnings; use Memoize; +use Memoize::Expire; my $DEBUG = 0; my $LIFETIME = 15; @@ -11,32 +8,21 @@ my $LIFETIME = 15; my $test = 0; $| = 1; -if (-e '.fast') { - print "1..0\n"; +if ($ENV{PERL_MEMOIZE_TESTS_FAST_ONLY}) { + print "1..0 # Skipped: Slow tests disabled\n"; exit 0; } print "# Testing the timed expiration policy.\n"; print "# This will take about thirty seconds.\n"; -print "1..26\n"; - -require Memoize::Expire; -++$test; print "ok $test - Expire loaded\n"; - -sub now { -# print "NOW: @_ ", time(), "\n"; - time; -} +print "1..24\n"; tie my %cache => 'Memoize::Expire', LIFETIME => $LIFETIME; - -memoize 'now', - SCALAR_CACHE => [HASH => \%cache ], - LIST_CACHE => 'FAULT' - ; - -++$test; print "ok $test - function memoized\n"; +memoize sub { time }, + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT', + INSTALL => 'now'; my (@before, @after, @now); diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/flush.t b/gnu/usr.bin/perl/cpan/Memoize/t/flush.t index bf9262ec7ca..33eceac8879 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/flush.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/flush.t @@ -1,42 +1,24 @@ -#!/usr/bin/perl - -use lib '..'; -use Memoize 'flush_cache', 'memoize'; -print "1..8\n"; -print "ok 1\n"; - - +use strict; use warnings; +use Memoize qw(flush_cache memoize); +use Test::More tests => 9; my $V = 100; sub VAL { $V } -memoize 'VAL'; -print "ok 2\n"; - -my $c1 = VAL(); -print (($c1 == 100) ? "ok 3\n" : "not ok 3\n"); +ok eval { memoize('VAL'); 1 }, 'memozing the test function'; +is VAL(), 100, '... with the expected return value'; $V = 200; -$c1 = VAL(); -print (($c1 == 100) ? "ok 4\n" : "not ok 4\n"); +is VAL(), 100, '... which is expectedly sticky'; -flush_cache('VAL'); -$c1 = VAL(); -print (($c1 == 200) ? "ok 5\n" : "not ok 5\n"); +ok eval { flush_cache('VAL'); 1 }, 'flusing the cache by name works'; +is VAL(), 200, '... with the expected new return value'; $V = 300; -$c1 = VAL(); -print (($c1 == 200) ? "ok 6\n" : "not ok 6\n"); +is VAL(), 200, '... which is expectedly sticky'; -flush_cache(\&VAL); -$c1 = VAL(); -print (($c1 == 300) ? "ok 7\n" : "not ok 7\n"); +ok eval { flush_cache(\&VAL); 1 }, 'flusing the cache by name works'; +is VAL(), 300, '... with the expected new return value'; $V = 400; -$c1 = VAL(); -print (($c1 == 300) ? "ok 8\n" : "not ok 8\n"); - - - - - +is VAL(), 300, '... which is expectedly sticky'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm b/gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm new file mode 100644 index 00000000000..59c18d5d75a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/lib/DBMTest.pm @@ -0,0 +1,102 @@ +use strict; use warnings; + +package DBMTest; + +my ($module, $is_scalar_only); + +use Memoize qw(memoize unmemoize); +use Test::More; + +sub errlines { split /\n/, $@ } + +my $ARG = 'Keith Bostic is a pinhead'; + +sub c5 { 5 } +sub c23 { 23 } + +sub test_dbm { SKIP: { + tie my %cache, $module, @_ or die $!; + + my $sub = eval { unmemoize memoize sub {}, LIST_CACHE => [ HASH => \%cache ] }; + my $errx = qr/^You can't use \Q$module\E for LIST_CACHE because it can only store scalars/; + if ($is_scalar_only) { + is $sub, undef, "use as LIST_CACHE fails"; + like $@, $errx, '... with the expected error'; + } else { + ok $sub, "use as LIST_CACHE succeeds"; + } + + $sub = eval { no warnings; unmemoize memoize sub {}, LIST_CACHE => [ TIE => $module, @_ ] }; + if ($is_scalar_only) { + is $sub, undef, '... including under the TIE option'; + like $@, $errx, '... with the expected error'; + } else { + ok $sub, 'use as LIST_CACHE succeeds'; + } + + eval { exists $cache{'dummy'}; 1 } + or skip join("\n", 'exists() unsupported', errlines), 3; + + memoize 'c5', + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT'; + + is c5($ARG), 5, 'store value during first memoization'; + unmemoize 'c5'; + + untie %cache; + + tie %cache, $module, @_ or die $!; + + # Now something tricky---we'll memoize c23 with the wrong table that + # has the 5 already cached. + memoize 'c23', + SCALAR_CACHE => [ HASH => \%cache ], + LIST_CACHE => 'FAULT'; + + is c23($ARG), 5, '... and find it still there after second memoization'; + unmemoize 'c23'; + + untie %cache; + + { no warnings; memoize 'c23', + SCALAR_CACHE => [ TIE => $module, @_ ], + LIST_CACHE => 'FAULT'; + } + + is c23($ARG), 5, '... as well as a third memoization via TIE'; + unmemoize 'c23'; +} } + +my @file; + +sub cleanup { 1 while unlink @file } + +sub import { + (undef, $module, my %arg) = (shift, @_); + + $is_scalar_only = $arg{'is_scalar_only'} ? 2 : 0; + eval "require $module" + ? plan tests => 5 + $is_scalar_only + ($arg{extra_tests}||0) + : plan skip_all => join "\n# ", "Could not load $module", errlines; + + my ($basename) = map { s/.*:://; s/_file\z//; 'm_'.$_.$$ } lc $module; + my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir'; # copypaste from DBD::DBM + @file = map { $_, "$_.db", "$_.pag", $_.$dirfext } $basename; + cleanup; + + my $pkg = caller; + no strict 'refs'; + *{$pkg.'::'.$_} = \&$_ for qw(test_dbm cleanup); + *{$pkg.'::file'} = \$basename; +} + +END { + cleanup; + if (my @failed = grep -e, @file) { + @failed = grep !unlink, @failed; # to set $! + warn "Can't unlink @failed! ($!)\n" if @failed; + } +} + +1; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t b/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t index a920ff4b307..8b9f90f2b7e 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/normalize.t @@ -1,10 +1,6 @@ -#!/usr/bin/perl - -use lib '..'; +use strict; use warnings; use Memoize; - -print "1..7\n"; - +use Test::More tests => 11; sub n_null { '' } @@ -24,34 +20,47 @@ my $a_normal = memoize('a1', INSTALL => undef); my $a_nomemo = memoize('a2', INSTALL => undef, NORMALIZER => 'n_diff'); my $a_allmemo = memoize('a3', INSTALL => undef, NORMALIZER => 'n_null'); +my @ARGS; @ARGS = (1, 2, 3, 2, 1); -@res = map { &$a_normal($_) } @ARGS; -print ((("@res" eq "1-1 2-2 3-3 2-2 1-1") ? '' : 'not '), "ok 1\n"); - -@res = map { &$a_nomemo($_) } @ARGS; -print ((("@res" eq "1-1 2-2 3-3 2-4 1-5") ? '' : 'not '), "ok 2\n"); +is_deeply [map $a_normal->($_), @ARGS], [qw(1-1 2-2 3-3 2-2 1-1)], 'no normalizer'; +is_deeply [map $a_nomemo->($_), @ARGS], [qw(1-1 2-2 3-3 2-4 1-5)], 'n_diff'; +is_deeply [map $a_allmemo->($_), @ARGS], [qw(1-1 1-1 1-1 1-1 1-1)], 'n_null'; -@res = map { &$a_allmemo($_) } @ARGS; -print ((("@res" eq "1-1 1-1 1-1 1-1 1-1") ? '' : 'not '), "ok 3\n"); - - - # Test fully-qualified name and installation +my $COUNT; $COUNT = 0; sub parity { $COUNT++; $_[0] % 2 } sub parnorm { $_[0] % 2 } memoize('parity', NORMALIZER => 'main::parnorm'); -@res = map { &parity($_) } @ARGS; -print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 4\n"); -print (( ($COUNT == 2) ? '' : 'not '), "ok 5\n"); +is_deeply [map parity($_), @ARGS], [qw(1 0 1 0 1)], 'parity normalizer'; +is $COUNT, 2, '... with the expected number of calls'; # Test normalization with reference to normalizer function $COUNT = 0; sub par2 { $COUNT++; $_[0] % 2 } memoize('par2', NORMALIZER => \&parnorm); -@res = map { &par2($_) } @ARGS; -print ((("@res" eq "1 0 1 0 1") ? '' : 'not '), "ok 6\n"); -print (( ($COUNT == 2) ? '' : 'not '), "ok 7\n"); +is_deeply [map par2($_), @ARGS], [qw(1 0 1 0 1)], '... also installable by coderef'; +is $COUNT, 2, '... still with the expected number of calls'; + +$COUNT = 0; +sub count_uninitialized { $COUNT += join('', @_) =~ /\AUse of uninitialized value / } +my $war1 = memoize(sub {1}, NORMALIZER => sub {undef}); +{ local $SIG{__WARN__} = \&count_uninitialized; $war1->() } +is $COUNT, 0, 'no warning when normalizer returns undef'; +# Context propagated correctly to normalizer? +sub n { + my $which = wantarray ? 'list' : 'scalar'; + local $Test::Builder::Level = $Test::Builder::Level + 2; + is $_[0], $which, "$which context propagates properly"; +} +sub f { 1 } +memoize('f', NORMALIZER => 'n'); +my $s = f 'scalar'; +my @a = f 'list'; +sub args { scalar @_ } +sub null_args { join chr(28), splice @_ } +memoize('args', NORMALIZER => 'null_args'); +ok args(1), 'original @_ is protected from normalizer'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency b/gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency new file mode 100644 index 00000000000..42e53f92411 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/st_concurrency @@ -0,0 +1,36 @@ +#!/bin/sh + +# running this script intermittently yields +# +# Magic number checking on storable file failed at ... +# +# but it is difficult to trigger this error 100% reliably +# as would be needed to turn this script into an actual test + +perl -I. -x t/st_concurrency st_shared & +perl -I. -x t/st_concurrency st_shared & +perl -I. -x t/st_concurrency st_shared & +perl -I. -x t/st_concurrency st_shared & +wait && exec rm st_shared + +#!perl +use strict; use warnings; + +use Memoize::Storable; +use Fcntl 'LOCK_EX'; + +sub rand32 () { int rand 1<<32 } + +# the script locks itself to increase the likelihood of the error: +# after releasing the lock, the first process writes to the file +# just as another process acquires the lock and starts to read it +# (but this still does not trigger the error reliably) + +open my $fh, $0 or die $!; +flock $fh, LOCK_EX or die $!; + +tie my %cache => 'Memoize::Storable', $ARGV[0]; +$cache{(rand32)} = rand32; + +close $fh; +# vim: ft=perl diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t b/gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t new file mode 100644 index 00000000000..e562aafd0a4 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/threadsafe.t @@ -0,0 +1,37 @@ +use strict; use warnings; + +use Memoize qw(memoize unmemoize); +use Test::More + ("$]" < 5.009 || "$]" >= 5.010001) && eval { require threads; 1 } + ? ( tests => 8 ) + : ( skip_all => $@ ); + +my $i; +sub count_up { ++$i } + +memoize('count_up'); +my $cached = count_up(); + +is count_up(), $cached, 'count_up() is memoized'; + +my $got = threads->new(sub { + local $@ = ''; + my $v = eval { count_up() }; + +{ E => $@, V => $v }; +})->join; + +is $got->{E}, '', 'calling count_up() in another thread works'; +is $got->{V}, $cached, '... and returns the same result'; +is count_up(), $cached, '... whereas count_up() on the main thread is unaffected'; + +$got = threads->new(sub { + local $@ = ''; + my $u = eval { unmemoize('count_up') }; + my $v = eval { count_up() }; + +{ E => $@, U => $u, V => $v }; +})->join; + +is $got->{E}, '', 'unmemoizing count_up() in another thread works'; +is ref($got->{U}), 'CODE', '... and returns a coderef as expected'; +is $got->{V}, 1+$cached, '... and does in fact unmemoize the function'; +is count_up(), $cached, '... whereas count_up() on the main thread is unaffected'; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie.t index 02c20d6fc79..fbae0e98869 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie.t @@ -1,80 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.52 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -eval {require Memoize::AnyDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - - - -print "1..4\n"; - -sub i { - $_[0]; -} - -$ARG = 'Keith Bostic is a pinhead'; - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -$file = "md$$"; -@files = ($file, "$file.db", "$file.dir", "$file.pag"); -1 while unlink @files; - - -tryout('Memoize::AnyDBM_File', $file, 1); # Test 1..4 -# tryout('DB_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag"; - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - my $t1 = c5($ARG); - my $t2 = c5($ARG); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => ['HASH', \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23($ARG); - my $t4 = c23($ARG); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno # Result $t3\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno # Result $t4\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'Memoize::AnyDBM_File', is_scalar_only => 1; -{ - my @present = grep -e, @files; - if (@present && (@failed = grep { not unlink } @present)) { - warn "Can't unlink @failed! ($!)"; - } -} +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t new file mode 100644 index 00000000000..3c72e7fbd34 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_db.t @@ -0,0 +1,8 @@ +use strict; use warnings; +use Fcntl; + +use lib 't/lib'; +use DBMTest 'DB_File', is_scalar_only => 1; + +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t index 8d55647b01d..e738cc454d6 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_gdbm.t @@ -1,68 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -eval {require GDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "md$$"; -1 while unlink $file, "$file.dir", "$file.pag"; -tryout('GDBM_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag"; - -sub tryout { - require GDBM_File; - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file, &GDBM_File::GDBM_NEWDB, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'GDBM_File', is_scalar_only => 1; +test_dbm $file, &GDBM_File::GDBM_WRCREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t index a328bc01bb7..b261c1cc703 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_ndbm.t @@ -1,70 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -# use Memoize::NDBM_File; -# $Memoize::NDBM_File::Verbose = 0; - -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -eval {require Memoize::NDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "md$$"; -1 while unlink $file, "$file.dir", "$file.pag", "$file.db"; -tryout('Memoize::NDBM_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag", "$file.db"; - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - - tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'Memoize::NDBM_File', is_scalar_only => 1; +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t new file mode 100644 index 00000000000..611afc3ef58 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_odbm.t @@ -0,0 +1,8 @@ +use strict; use warnings; +use Fcntl; + +use lib 't/lib'; +use DBMTest 'ODBM_File', is_scalar_only => 1; + +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t index 588efd95612..d0126c2ed7a 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_sdbm.t @@ -1,75 +1,8 @@ -#!/usr/bin/perl - -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); +use strict; use warnings; use Fcntl; -# use Memoize::SDBM_File; -# $Memoize::GDBM_File::Verbose = 0; - -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } - -sub n { - $_[0]+1; -} - -eval {require Memoize::SDBM_File}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "md$$"; -1 while unlink $file, "$file.dir", "$file.pag"; -if ( $^O eq 'VMS' ) { - 1 while unlink "$file.sdbm_dir"; -} -tryout('Memoize::SDBM_File', $file, 1); # Test 1..4 -1 while unlink $file, "$file.dir", "$file.pag"; -if ( $^O eq 'VMS' ) { - 1 while unlink "$file.sdbm_dir"; -} - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file, O_RDWR | O_CREAT, 0666 - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} +use lib 't/lib'; +use DBMTest 'SDBM_File', is_scalar_only => 1; +test_dbm $file, O_RDWR | O_CREAT, 0666; +cleanup; diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t b/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t index de3b8dc26b8..99e0cfdcd20 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/tie_storable.t @@ -1,76 +1,16 @@ -#!/usr/bin/perl -# -*- mode: perl; perl-indent-level: 2 -*- +use strict; use warnings; +use Test::More; -use lib qw(. ..); -use Memoize 0.45 qw(memoize unmemoize); -# $Memoize::Storable::Verbose = 0; +use lib 't/lib'; +use DBMTest 'Memoize::Storable', extra_tests => 1; -eval {require Memoize::Storable}; -if ($@) { - print "1..0\n"; - exit 0; -} - -sub i { - $_[0]; -} - -sub c119 { 119 } -sub c7 { 7 } -sub c43 { 43 } -sub c23 { 23 } -sub c5 { 5 } +test_dbm $file; +cleanup; -sub n { - $_[0]+1; +SKIP: { + skip "skip Storable $Storable::VERSION too old for last_op_in_netorder", 1 + unless eval { Storable->VERSION('0.609') }; + { tie my %cache, 'Memoize::Storable', $file, 'nstore' or die $! } + ok Storable::last_op_in_netorder(), 'nstore option works'; + cleanup; } - -eval {require Storable}; -if ($@) { - print "1..0\n"; - exit 0; -} - -print "1..4\n"; - -$file = "storable$$"; -1 while unlink $file; -tryout('Memoize::Storable', $file, 1); # Test 1..4 -1 while unlink $file; - -sub tryout { - my ($tiepack, $file, $testno) = @_; - - tie my %cache => $tiepack, $file - or die $!; - - memoize 'c5', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t1 = c5(); - my $t2 = c5(); - print (($t1 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t2 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c5'; - 1; - 1; - - # Now something tricky---we'll memoize c23 with the wrong table that - # has the 5 already cached. - memoize 'c23', - SCALAR_CACHE => [HASH => \%cache], - LIST_CACHE => 'FAULT' - ; - - my $t3 = c23(); - my $t4 = c23(); - $testno++; - print (($t3 == 5) ? "ok $testno\n" : "not ok $testno\n"); - $testno++; - print (($t4 == 5) ? "ok $testno\n" : "not ok $testno\n"); - unmemoize 'c23'; -} - diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t b/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t index 82b318c6452..f4b9e98991c 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/unmemoize.t @@ -1,26 +1,51 @@ -#!/usr/bin/perl - -use lib '..'; +use strict; use warnings; use Memoize qw(memoize unmemoize); - -print "1..5\n"; - -eval { unmemoize('f') }; # Should fail -print (($@ ? '' : 'not '), "ok 1\n"); - -{ my $I = 0; - sub u { $I++ } +use Test::More tests => 26; + +is eval { unmemoize('u') }, undef, 'trying to unmemoize without memoizing fails'; +my $errx = qr/^Could not unmemoize function `u', because it was not memoized to begin with/; +like $@, $errx, '... with the expected error'; + +sub u {1} +my $sub = \&u; +my $wrapped = memoize('u'); +is \&u, $wrapped, 'trying to memoize succeeds'; + +is eval { unmemoize('u') }, $sub, 'trying to unmemoize succeeds' or diag $@; + +is \&u, $sub, '... and does in fact unmemoize it'; + +is eval { unmemoize('u') }, undef, 'trying to unmemoize it again fails'; +like $@, $errx, '... with the expected error'; + +# Memoizing a function multiple times separately is not very useful +# but it should not break unmemoize or make memoization lose its mind + +my $ret; +my $dummy = sub { $ret }; +ok memoize $dummy, INSTALL => 'memo1'; +ok memoize $dummy, INSTALL => 'memo2'; +ok defined &memo1, 'memoized once'; +ok defined &memo2, 'memoized twice'; +$@ = ''; +ok eval { unmemoize 'memo1' }, 'unmemoized once'; +is $@, '', '... and no exception'; +$@ = ''; +ok eval { unmemoize 'memo2' }, 'unmemoized twice'; +is $@, '', '... and no exception'; +is \&memo1, $dummy, 'unmemoized installed once'; +is \&memo2, $dummy, 'unmemoized installed twice'; + +my @quux = qw(foo bar baz); +my %memo = map +($_ => memoize $dummy), @quux; +for (@quux) { $ret = $_; is $memo{$_}->(), $_, "\$memo{$_}->() returns $_" } +for (@quux) { undef $ret; is $memo{$_}->(), $_, "\$memo{$_}->() returns $_" } + +my $destroyed = 0; +sub Counted::DESTROY { ++$destroyed } +{ + my $memo = memoize $dummy, map +( "$_\_CACHE" => [ HASH => bless {}, 'Counted' ] ), qw(LIST SCALAR); + ok $memo, 'memoize anon'; + ok eval { unmemoize $memo }, 'unmemoized anon'; } -memoize('u'); -my @ur = (&u, &u, &u); -print (("@ur" eq "0 0 0") ? "ok 2\n" : "not ok 2\n"); - -eval { unmemoize('u') }; # Should succeed -print ($@ ? "not ok 3\n" : "ok 3\n"); - -@ur = (&u, &u, &u); -print (("@ur" eq "1 2 3") ? "ok 4\n" : "not ok 4\n"); - -eval { unmemoize('u') }; # Should fail -print ($@ ? "ok 5\n" : "not ok 5\n"); - +is $destroyed, 2, 'no cyclic references'; diff --git a/gnu/usr.bin/perl/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t b/gnu/usr.bin/perl/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t index 5270fb4691b..f11901545b4 100755 --- a/gnu/usr.bin/perl/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t +++ b/gnu/usr.bin/perl/cpan/PerlIO-via-QuotedPrint/t/QuotedPrint.t @@ -10,6 +10,7 @@ BEGIN { # Magic Perl CORE pragma } if (ord("A") == 193) { print "1..0 # Skip: EBCDIC\n"; + exit 0; } } diff --git a/gnu/usr.bin/perl/cpan/Pod-Checker/lib/Pod/Checker.pm b/gnu/usr.bin/perl/cpan/Pod-Checker/lib/Pod/Checker.pm index bee20d0bfad..1dfb58b1284 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Checker/lib/Pod/Checker.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Checker/lib/Pod/Checker.pm @@ -10,7 +10,7 @@ package Pod::Checker; use strict; use warnings; -our $VERSION = '1.74'; ## Current version of this package +our $VERSION = '1.75'; ## Current version of this package =head1 NAME @@ -1112,7 +1112,10 @@ sub new { $self->{'-line'} ||= $caller->{'_line'}; $self->{'-type'} ||= $simple_link->{'type'}; - + # preserve raw link text for additional checks + $self->{'-raw-link-text'} = (exists $simple_link->{'raw'}) + ? "$simple_link->{'raw'}" + : ""; # Force stringification of page and node. (This expands any E<>.) $self->{'-page'} = exists $simple_link->{'to'} ? "$simple_link->{'to'}" : ""; $self->{'-node'} = exists $simple_link->{'section'} ? "$simple_link->{'section'}" : ""; diff --git a/gnu/usr.bin/perl/cpan/Pod-Usage/t/inc/Pod/PlainText.pm b/gnu/usr.bin/perl/cpan/Pod-Usage/t/inc/Pod/PlainText.pm index 733d2a07e47..5257b724e05 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Usage/t/inc/Pod/PlainText.pm +++ b/gnu/usr.bin/perl/cpan/Pod-Usage/t/inc/Pod/PlainText.pm @@ -37,6 +37,12 @@ BEGIN { require Symbol; Symbol->import; } + if ($] < 5.008 || ord "A" == 65) { + *to_native = sub { return chr shift; }; + } + else { + *to_native = sub { return chr utf8::unicode_to_native(shift); }; + } } ############################################################################ @@ -52,71 +58,71 @@ BEGIN { '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) + "Aacute" => to_native(0xC1), # capital A, acute accent + "aacute" => to_native(0xE1), # small a, acute accent + "Acirc" => to_native(0xC2), # capital A, circumflex accent + "acirc" => to_native(0xE2), # small a, circumflex accent + "AElig" => to_native(0xC6), # capital AE diphthong (ligature) + "aelig" => to_native(0xE6), # small ae diphthong (ligature) + "Agrave" => to_native(0xC0), # capital A, grave accent + "agrave" => to_native(0xE0), # small a, grave accent + "Aring" => to_native(0xC5), # capital A, ring + "aring" => to_native(0xE5), # small a, ring + "Atilde" => to_native(0xC3), # capital A, tilde + "atilde" => to_native(0xE3), # small a, tilde + "Auml" => to_native(0xC4), # capital A, dieresis or umlaut mark + "auml" => to_native(0xE4), # small a, dieresis or umlaut mark + "Ccedil" => to_native(0xC7), # capital C, cedilla + "ccedil" => to_native(0xE7), # small c, cedilla + "Eacute" => to_native(0xC9), # capital E, acute accent + "eacute" => to_native(0xE9), # small e, acute accent + "Ecirc" => to_native(0xCA), # capital E, circumflex accent + "ecirc" => to_native(0xEA), # small e, circumflex accent + "Egrave" => to_native(0xC8), # capital E, grave accent + "egrave" => to_native(0xE8), # small e, grave accent + "ETH" => to_native(0xD0), # capital Eth, Icelandic + "eth" => to_native(0xF0), # small eth, Icelandic + "Euml" => to_native(0xCB), # capital E, dieresis or umlaut mark + "euml" => to_native(0xEB), # small e, dieresis or umlaut mark + "Iacute" => to_native(0xCD), # capital I, acute accent + "iacute" => to_native(0xED), # small i, acute accent + "Icirc" => to_native(0xCE), # capital I, circumflex accent + "icirc" => to_native(0xEE), # small i, circumflex accent + "Igrave" => to_native(0xCD), # capital I, grave accent + "igrave" => to_native(0xED), # small i, grave accent + "Iuml" => to_native(0xCF), # capital I, dieresis or umlaut mark + "iuml" => to_native(0xEF), # small i, dieresis or umlaut mark + "Ntilde" => to_native(0xD1), # capital N, tilde + "ntilde" => to_native(0xF1), # small n, tilde + "Oacute" => to_native(0xD3), # capital O, acute accent + "oacute" => to_native(0xF3), # small o, acute accent + "Ocirc" => to_native(0xD4), # capital O, circumflex accent + "ocirc" => to_native(0xF4), # small o, circumflex accent + "Ograve" => to_native(0xD2), # capital O, grave accent + "ograve" => to_native(0xF2), # small o, grave accent + "Oslash" => to_native(0xD8), # capital O, slash + "oslash" => to_native(0xF8), # small o, slash + "Otilde" => to_native(0xD5), # capital O, tilde + "otilde" => to_native(0xF5), # small o, tilde + "Ouml" => to_native(0xD6), # capital O, dieresis or umlaut mark + "ouml" => to_native(0xF6), # small o, dieresis or umlaut mark + "szlig" => to_native(0xDF), # small sharp s, German (sz ligature) + "THORN" => to_native(0xDE), # capital THORN, Icelandic + "thorn" => to_native(0xFE), # small thorn, Icelandic + "Uacute" => to_native(0xDA), # capital U, acute accent + "uacute" => to_native(0xFA), # small u, acute accent + "Ucirc" => to_native(0xDB), # capital U, circumflex accent + "ucirc" => to_native(0xFB), # small u, circumflex accent + "Ugrave" => to_native(0xD9), # capital U, grave accent + "ugrave" => to_native(0xF9), # small u, grave accent + "Uuml" => to_native(0xDC), # capital U, dieresis or umlaut mark + "uuml" => to_native(0xFC), # small u, dieresis or umlaut mark + "Yacute" => to_native(0xDD), # capital Y, acute accent + "yacute" => to_native(0xFD), # small y, acute accent + "yuml" => to_native(0xFF), # small y, dieresis or umlaut mark + + "lchevron" => to_native(0xAB), # left chevron (double less than) + "rchevron" => to_native(0xBB), # right chevron (double greater than) ); diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/exotic_names.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/exotic_names.t index 3c5f212325d..c51114a6acd 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/exotic_names.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/exotic_names.t @@ -40,8 +40,8 @@ sub caller3_ok { ), ( $ord > 255 ? unpack('H*', pack 'C0U', $ord ) - : ($ord > 0x1f and $ord < 0x7f) ? sprintf "%c", $ord - : sprintf '\%o', $ord + : (chr $ord =~ /[[:print:]]/) ? sprintf "%c", $ord + : sprintf '\%o', $ord ), ); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Formatter.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Formatter.pm index 93e1c4afeb5..4f3bee0dec8 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Formatter.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/Formatter.pm @@ -2,7 +2,7 @@ package Test::Builder::Formatter; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm index 82b5e0d0dc5..56d3fcbf253 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test/Builder/TodoDiag.pm @@ -2,7 +2,7 @@ package Test::Builder::TodoDiag; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2.pm index 067b1400788..f6d47c47098 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2.pm @@ -2,7 +2,7 @@ package Test2; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; 1; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API.pm index bd287a907c9..68034c29d18 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API.pm @@ -10,7 +10,7 @@ BEGIN { $ENV{TEST2_ACTIVE} = 1; } -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; my $INST; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Breakage.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Breakage.pm index 5364c054f30..50234af864b 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Breakage.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Breakage.pm @@ -2,7 +2,7 @@ package Test2::API::Breakage; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::Util qw/pkg_to_file/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Context.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Context.pm index 983cbf4082e..c6b638d0152 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Context.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Context.pm @@ -2,7 +2,7 @@ package Test2::API::Context; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/confess croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Instance.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Instance.pm index 874fb729675..9a9ef58e3cc 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Instance.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Instance.pm @@ -2,7 +2,7 @@ package Test2::API::Instance; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/; use Carp qw/confess carp/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm index 2e6ae66b801..1d07841f1ca 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Scalar::Util qw/blessed/; use Test2::Util qw/pkg_to_file/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm index 53441b1c617..a93c4fd3c13 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Event.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Event; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use List::Util qw/first/; use Test2::Util qw/pkg_to_file/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm index 2435f3236a9..54589fa5af2 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Facet.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Facet; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm index 1c89970af21..fa0c329a0dd 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Hub.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Hub; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm index 590b367a7ac..670b9c7a992 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/InterceptResult/Squasher.pm @@ -2,7 +2,7 @@ package Test2::API::InterceptResult::Squasher; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/croak/; use List::Util qw/first/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Stack.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Stack.pm index 327e5f69eff..98147b2a960 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Stack.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Stack.pm @@ -2,7 +2,7 @@ package Test2::API::Stack; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::Hub(); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event.pm index 8ba4fb32160..b914bd84cfa 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event.pm @@ -2,7 +2,7 @@ package Test2::Event; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Scalar::Util qw/blessed reftype/; use Carp qw/croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Bail.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Bail.pm index 81a112dfa75..49b8fe06826 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Bail.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Bail.pm @@ -2,7 +2,7 @@ package Test2::Event::Bail; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Diag.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Diag.pm index a3ec9a5c867..5ea440904eb 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Diag.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Diag.pm @@ -2,7 +2,7 @@ package Test2::Event::Diag; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Encoding.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Encoding.pm index 79107c030e6..7f69da1b31c 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Encoding.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Encoding.pm @@ -2,7 +2,7 @@ package Test2::Event::Encoding; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Exception.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Exception.pm index f101c775871..5898dc76b42 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Exception.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Exception.pm @@ -2,7 +2,7 @@ package Test2::Event::Exception; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Fail.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Fail.pm index 398dd9906a5..444c3f6c06e 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Fail.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Fail.pm @@ -2,7 +2,7 @@ package Test2::Event::Fail; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::EventFacet::Info; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Generic.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Generic.pm index e912d98e080..170aa631bde 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Generic.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Generic.pm @@ -5,7 +5,7 @@ use warnings; use Carp qw/croak/; use Scalar::Util qw/reftype/; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } use Test2::Util::HashBase; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Note.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Note.pm index e8fdad58dfc..d8e81eae042 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Note.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Note.pm @@ -2,7 +2,7 @@ package Test2::Event::Note; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Ok.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Ok.pm index d4f5e88ca35..847baede3ca 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Ok.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Ok.pm @@ -2,7 +2,7 @@ package Test2::Event::Ok; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Pass.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Pass.pm index 66e58a66bfc..108ad5a0a27 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Pass.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Pass.pm @@ -2,7 +2,7 @@ package Test2::Event::Pass; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::EventFacet::Info; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Plan.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Plan.pm index 7e0da036246..b40b332c972 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Plan.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Plan.pm @@ -2,7 +2,7 @@ package Test2::Event::Plan; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Skip.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Skip.pm index a9bd06a744c..de73c68ef18 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Skip.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Skip.pm @@ -2,7 +2,7 @@ package Test2::Event::Skip; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Subtest.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Subtest.pm index 2a60e9d4d04..6e8ebc9a09d 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Subtest.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Subtest.pm @@ -2,7 +2,7 @@ package Test2::Event::Subtest; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid start_stamp stop_stamp}; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm index 23ed85ad0c1..f52290fcad5 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/TAP/Version.pm @@ -2,7 +2,7 @@ package Test2::Event::TAP::Version; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/V2.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/V2.pm index f8a40a6a053..f94b76c21ea 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/V2.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/V2.pm @@ -2,7 +2,7 @@ package Test2::Event::V2; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Scalar::Util qw/reftype/; use Carp qw/croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Waiting.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Waiting.pm index 399f9ad5853..d031430b7af 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Waiting.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Event/Waiting.pm @@ -2,7 +2,7 @@ package Test2::Event::Waiting; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet.pm index 38b66b5fd9b..96bf6c5e08a 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet.pm @@ -2,7 +2,7 @@ package Test2::EventFacet; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::Util::HashBase qw/-details/; use Carp qw/croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/About.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/About.pm index 4d88964544e..e0a9ad6d938 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/About.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/About.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::About; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -package -no_display -uuid -eid }; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm index 65d9170eda9..4850aa377df 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Amnesty.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Amnesty; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; sub is_list { 1 } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm index 2d82965db13..52554c9ab5f 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Assert.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Assert; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -pass -no_debug -number }; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm index 7bc200dffba..e8cc63ac3b1 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Control.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Control; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm index ba0722a0bf9..8772e9d4f66 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Error.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Error; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; sub facet_key { 'errors' } sub is_list { 1 } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm index 3c1b2309833..f8f6f3f90b9 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Hub.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Hub; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; sub is_list { 1 } sub facet_key { 'hubs' } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm index a2b26ccfd7b..753344753ad 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Info; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; sub is_list { 1 } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm index 09c7ec855c6..8ed95371b04 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Info/Table.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Info::Table; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/confess/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm index 2381b25403f..59729a1bdb1 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Meta.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Meta; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use vars qw/$AUTOLOAD/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm index 987bf688ba0..aab230c8ca3 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Parent.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Parent; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/confess/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm index 00483f2c5bf..de22be47173 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Plan.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Plan; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } use Test2::Util::HashBase qw{ -count -skip -none }; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm index fd75f4181a7..2a38d1b75e5 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Render.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Render; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; sub is_list { 1 } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm index d60c29e72d6..fbdfa2b70dc 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/EventFacet/Trace.pm @@ -2,7 +2,7 @@ package Test2::EventFacet::Trace; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter.pm index 71ab20affb7..93117a08985 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter.pm @@ -2,7 +2,7 @@ package Test2::Formatter; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; my %ADDED; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm index a60a5f244e0..ae381d7e9df 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Formatter/TAP.pm @@ -2,7 +2,7 @@ package Test2::Formatter::TAP; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::Util qw/clone_io/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub.pm index 7708c7d06d9..5ee50809bf3 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub.pm @@ -2,7 +2,7 @@ package Test2::Hub; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/carp croak confess/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm index 68648b15b9d..c1c86d818d9 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor.pm @@ -2,7 +2,7 @@ package Test2::Hub::Interceptor; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::Hub::Interceptor::Terminator(); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm index 9fba1abe6a2..90c03f91b73 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Interceptor/Terminator.pm @@ -2,7 +2,7 @@ package Test2::Hub::Interceptor::Terminator; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; 1; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm index e5da3ad8ba1..89dde5b432e 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Hub/Subtest.pm @@ -2,7 +2,7 @@ package Test2::Hub::Subtest; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC.pm index eba2ccd3d59..807bd6c6290 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC.pm @@ -2,7 +2,7 @@ package Test2::IPC; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Test2::API::Instance; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver.pm index aa2514e85f7..a00e1ec4c86 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver.pm @@ -2,7 +2,7 @@ package Test2::IPC::Driver; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/confess/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm index d1d3d483136..4edd40c4631 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/IPC/Driver/Files.pm @@ -2,7 +2,7 @@ package Test2::IPC::Driver::Files; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm index 955907aeb97..636ba2f6729 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Tools/Tiny.pm @@ -16,7 +16,7 @@ use Test2::API qw/context run_subtest test2_stack/; use Test2::Hub::Interceptor(); use Test2::Hub::Interceptor::Terminator(); -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util.pm index 3cef5b6a18a..aebfc2fd69e 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util.pm @@ -2,7 +2,7 @@ package Test2::Util; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use POSIX(); use Config qw/%Config/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm index ddfcfb5f4a0..774870c6893 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/ExternalMeta.pm @@ -2,7 +2,7 @@ package Test2::Util::ExternalMeta; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/croak/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm index 11c226d6464..d8d77d52e16 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Facets2Legacy.pm @@ -2,7 +2,7 @@ package Test2::Util::Facets2Legacy; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; use Carp qw/croak confess/; use Scalar::Util qw/blessed/; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/HashBase.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/HashBase.pm index 6af9f9bb5e8..c0c61a1bce8 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/HashBase.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/HashBase.pm @@ -2,7 +2,7 @@ package Test2::Util::HashBase; use strict; use warnings; -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; ################################################################# # # diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Trace.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Trace.pm index 5de2bf2d255..ad80226cae5 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Trace.pm +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Util/Trace.pm @@ -6,7 +6,7 @@ use strict; our @ISA = ('Test2::EventFacet::Trace'); -our $VERSION = '1.302190'; +our $VERSION = '1.302194'; 1; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/More.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/More.t index 68c8a3a091b..b91234a6acd 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/More.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/More.t @@ -8,7 +8,7 @@ BEGIN { } use lib 't/lib'; -use Test::More tests => 54; +use Test::More tests => 57; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -24,7 +24,24 @@ require_ok('Test::More'); ok( 2 eq 2, 'two is two is two is two' ); is( "foo", "foo", 'foo is foo' ); isnt( "foo", "bar", 'foo isnt bar'); -isn::t("foo", "bar", 'foo isn\'t bar'); +{ + use warnings; + my $warning; + local $SIG{__WARN__}= sub { $warning = $_[0] }; + isn::t("foo", "bar", 'foo isn\'t bar'); + is($warning, "Use of apostrophe as package separator was deprecated in Perl 5.37.9,\n" + . "and will be removed in Perl 5.42.0. You should change code that uses\n" + . "Test::More::isn't() to use Test::More::isnt() as a replacement" + . " at t/Legacy/More.t line 31\n", + "Got expected warning from isn::t() under use warnings"); +} +{ + no warnings "deprecated"; + my $warning; + local $SIG{__WARN__}= sub { $warning = $_[0] }; + isn::t("foo", "bar", 'foo isn\'t bar'); + is($warning, undef, "No warnings from isn::t() under no warnings deprecated"); +} #'# like("fooble", '/^foo/', 'foo is like fooble'); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Regression/870-experimental-warnings.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Regression/870-experimental-warnings.t index 9758d242f67..e826f2ba2d5 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Regression/870-experimental-warnings.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Regression/870-experimental-warnings.t @@ -2,12 +2,16 @@ use strict; use warnings; use Test2::Tools::Tiny; -BEGIN { skip_all "Only testing on 5.18+" if $] < 5.018 } +BEGIN { + skip_all "Not testing before 5.18 or after 5.37.10" + if $] < 5.018 or $] >= 5.037010; +} require Test::More; *cmp_ok = \&Test::More::cmp_ok; no warnings "experimental::smartmatch"; +no if !exists $warnings::Offsets{"experimental::smartmatch"}, warnings => 'deprecated'; my $warnings = warnings { cmp_ok(1, "~~", 1) }; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/cmp_ok.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/cmp_ok.t index c9b9f1bf65f..3f38e0e874c 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/cmp_ok.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/cmp_ok.t @@ -60,6 +60,7 @@ Test::More->builder->no_ending(1); require MyOverload; my $cmp = Overloaded::Compare->new("foo", 42); my $ify = Overloaded::Ify->new("bar", 23); +my $part = Overloaded::Partial->new('baz', 0); my @Tests = ( [1, '==', 1], @@ -74,6 +75,8 @@ my @Tests = ( [$ify, 'eq', "bar"], [$ify, "==", 23], + [$part, '!=', 0, 'expected: anything else'], + [1, "=", 0, "= is not a valid comparison operator in cmp_ok()"], [1, "+=", 0, "+= is not a valid comparison operator in cmp_ok()"], ); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/fail-more.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/fail-more.t index d0c0f6da7fc..6abda9f654a 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/fail-more.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/fail-more.t @@ -26,7 +26,7 @@ package My::Test; # Test::Builder's own and the ending diagnostics don't come out right. require Test::Builder; my $TB = Test::Builder->create; -$TB->plan(tests => 80); +$TB->plan(tests => 81); sub like ($$;$) { $TB->like(@_); @@ -41,6 +41,14 @@ sub main::out_ok ($$) { $TB->is_eq( $err->read, shift ); } +sub main::out_warn_ok ($$$) { + $TB->is_eq( $out->read, shift ); + $TB->is_eq( $err->read, shift ); + my $warning_expected = shift; + $warning_expected =~ s/^# //mg; + $TB->is_eq( $main::warning, $warning_expected ); +} + sub main::out_like ($$) { my($output, $failure) = @_; @@ -59,7 +67,7 @@ $out->read; # clear the plan from $out # This should all work in the presence of a __DIE__ handler. local $SIG{__DIE__} = sub { $TB->ok(0, "DIE handler called: ".join "", @_); }; - +local $SIG{__WARN__} = sub { $main::warning = $_[0]; }; my $tb = Test::More->builder; $tb->use_numbers(0); @@ -134,7 +142,7 @@ ERR #line 132 isn::t("foo", "foo",'foo isn\'t foo?' ); -out_ok( <{num}; }; +package Overloaded::Partial; + +our @ISA = qw(Overloaded); +use overload + q{""} => sub { $_[0]->{string} }, + q{!=} => sub { $_[0]->{num} != $_[1] }; + 1; diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/01_compile.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/01_compile.t index a6e91911c72..e62303be7a3 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/01_compile.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/01_compile.t @@ -1,5 +1,3 @@ -#!/usr/bin/perl - use 5.008001; use strict; diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/02_extbrk.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/02_extbrk.t index 5da792f1f04..389636b3d18 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/02_extbrk.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/02_extbrk.t @@ -1,27 +1,12 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..19\n"; } -END {print "not ok 1\n" unless $loaded;} +use Test::More; use Text::Balanced qw ( extract_bracketed ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -34,6 +19,7 @@ while (defined($str = )) if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $orig_str = $str; $str =~ s/\\n/\n/g; debug "\tUsing: $cmd\n"; debug "\t on: [$str]\n"; @@ -41,22 +27,20 @@ while (defined($str = )) my $var = eval "() = $cmd"; debug "\t list got: [$var]\n"; debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); + diag $@ if $@ && $DEBUG; pos $str = 0; $var = eval $cmd; $var = "" unless defined $var; debug "\t scalar got: [$var]\n"; debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); + diag $@ if $@ && $DEBUG; } +done_testing; + __DATA__ # USING: extract_bracketed($str); diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/03_extcbk.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/03_extcbk.t index 398d2771bac..7cbc9fca272 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/03_extcbk.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/03_extcbk.t @@ -1,27 +1,12 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..41\n"; } -END {print "not ok 1\n" unless $loaded;} +use Test::More; use Text::Balanced qw ( extract_codeblock ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -34,30 +19,47 @@ while (defined($str = )) if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $orig_str = $str; $str =~ s/\\n/\n/g; debug "\tUsing: $cmd\n"; debug "\t on: [$str]\n"; my @res; my $var = eval "\@res = $cmd"; - debug "\t Failed: $@ at " . $@+0 .")" if $@; + is $@, '', 'no error'; debug "\t list got: [" . join("|", map {defined $_ ? $_ : ''} @res) . "]\n"; debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); pos $str = 0; $var = eval $cmd; + is $@, '', 'no error'; $var = "" unless defined $var; debug "\t scalar got: [$var]\n"; debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); } +my $grammar = <<'EOF'; +given 2 { when __ < 1 { ok(0) } else { ok(1) } } +EOF +pos $grammar = 8; +my ($out) = Text::Balanced::_match_codeblock(\$grammar,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef); +ok $out, 'Switch error from calling _match_codeblock'; + +$grammar = <<'EOF'; +comment: m/a/ +enum_list: (/b/) +EOF +pos $grammar = 10; +($out) = Text::Balanced::extract_quotelike($grammar); +is $out, 'm/a/', 'PRD error (setup for real error)'; +pos $grammar = 26; +($out) = extract_codeblock($grammar,'{([',undef,'(',1); +is $out, '(/b/)', 'PRD error'; + +done_testing; + __DATA__ # USING: extract_codeblock($str,'(){}',undef,'()'); @@ -65,6 +67,13 @@ __DATA__ # USING: extract_codeblock($str); { $data[4] =~ /['"]/; }; +{1<<2}; +{1<<2};\n +{1<<2};\n\n +{ $a = /\}/; }; +{ sub { $_[0] /= $_[1] } }; # / here +{ 1; }; +{ $a = 1; }; # USING: extract_codeblock($str,'<>'); < %x = ( try => "this") >; @@ -77,13 +86,9 @@ __DATA__ # THIS SHOULD FAIL < %x = do { $try > 10 } >; -# USING: extract_codeblock($str); - -{ $a = /\}/; }; -{ sub { $_[0] /= $_[1] } }; # / here -{ 1; }; -{ $a = 1; }; - +# USING: extract_codeblock($str, '()'); +(($x || 2)); split /z/, $y +(($x // 2)); split /z/, $y # USING: extract_codeblock($str,undef,'=*'); ========{$a=1}; diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/04_extdel.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/04_extdel.t index b2f94cf51cf..30fa59949b2 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/04_extdel.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/04_extdel.t @@ -1,28 +1,13 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; +use Test::More; +use Text::Balanced qw ( extract_delimited extract_multiple ); -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..45\n"; } -END {print "not ok 1\n" unless $loaded;} -use Text::Balanced qw ( extract_delimited ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); +our $DEBUG; sub debug { print "\t>>>",@_ if $DEBUG } -######################### End of black magic. - ## no critic (BuiltinFunctions::ProhibitStringyEval) my $cmd = "print"; @@ -34,29 +19,41 @@ while (defined($str = )) if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $orig_str = $str; $str =~ s/\\n/\n/g; debug "\tUsing: $cmd\n"; debug "\t on: [$str]\n"; my $var = eval "() = $cmd"; + is $@, '', 'no error'; debug "\t list got: [$var]\n"; debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); pos $str = 0; $var = eval $cmd; + is $@, '', 'no error'; $var = "" unless defined $var; debug "\t scalar got: [$var]\n"; debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); } +my $text = 'while($a == "test"){ print "true";}'; +my ($extracted, $remainder) = extract_delimited($text, '#'); +ok '' ne $@, 'string overload should not crash'; + +$text = "a,'x b',c"; +my @fields = extract_multiple($text, + [ + sub { extract_delimited($_[0],q{'"}) }, + qr/([^,]+)/, + ], + undef,1); +is_deeply \@fields, ['a', "'x b'", 'c'] or diag 'got: ', explain \@fields; + +done_testing; + __DATA__ # USING: extract_delimited($str,'/#$',undef,'/#$'); /a/; diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/05_extmul.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/05_extmul.t index 9a9711b4f60..9b612dc253c 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/05_extmul.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/05_extmul.t @@ -1,54 +1,20 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..86\n"; } -END {print "not ok 1\n" unless $loaded;} +use Test::More; use Text::Balanced qw ( :ALL ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } sub expect { - local $^W; my ($l1, $l2) = @_; - - if (@$l1 != @$l2) - { - print "\@l1: ", join(", ", @$l1), "\n"; - print "\@l2: ", join(", ", @$l2), "\n"; - print "not "; - } - else - { - for (my $i = 0; $i < @$l1; $i++) - { - if ($l1->[$i] ne $l2->[$i]) - { - print "field $i: '$l1->[$i]' ne '$l2->[$i]'\n"; - print "not "; - last; - } - } - } - - print "ok $count\n"; - $count++; + is_deeply $l1, $l2 or do { + diag 'got:', explain $l1; + diag 'expected:', explain $l2; + }; } sub divide @@ -66,10 +32,8 @@ sub divide } - my $stdtext1 = q{$var = do {"val" && $val;};}; -# TESTS 2-4 my $text = $stdtext1; expect [ extract_multiple($text,undef,1) ], [ divide $stdtext1 => 4 ]; @@ -77,7 +41,6 @@ expect [ extract_multiple($text,undef,1) ], expect [ pos $text], [ 4 ]; expect [ $text ], [ $stdtext1 ]; -# TESTS 5-7 $text = $stdtext1; expect [ scalar extract_multiple($text,undef,1) ], [ divide $stdtext1 => 4 ]; @@ -86,7 +49,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; -# TESTS 8-10 $text = $stdtext1; expect [ extract_multiple($text,undef,2) ], [ divide($stdtext1 => 4, 10) ]; @@ -94,7 +56,6 @@ expect [ extract_multiple($text,undef,2) ], expect [ pos $text], [ 10 ]; expect [ $text ], [ $stdtext1 ]; -# TESTS 11-13 $text = $stdtext1; expect [ eval{local$^W;scalar extract_multiple($text,undef,2)} ], [ substr($stdtext1,0,4) ]; @@ -103,7 +64,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; -# TESTS 14-16 $text = $stdtext1; expect [ extract_multiple($text,undef,3) ], [ divide($stdtext1 => 4, 10, 26) ]; @@ -111,7 +71,6 @@ expect [ extract_multiple($text,undef,3) ], expect [ pos $text], [ 26 ]; expect [ $text ], [ $stdtext1 ]; -# TESTS 17-19 $text = $stdtext1; expect [ eval{local$^W;scalar extract_multiple($text,undef,3)} ], [ substr($stdtext1,0,4) ]; @@ -120,7 +79,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; -# TESTS 20-22 $text = $stdtext1; expect [ extract_multiple($text,undef,4) ], [ divide($stdtext1 => 4, 10, 26, 27) ]; @@ -128,7 +86,6 @@ expect [ extract_multiple($text,undef,4) ], expect [ pos $text], [ 27 ]; expect [ $text ], [ $stdtext1 ]; -# TESTS 23-25 $text = $stdtext1; expect [ eval{local$^W;scalar extract_multiple($text,undef,4)} ], [ substr($stdtext1,0,4) ]; @@ -137,7 +94,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext1,4) ]; -# TESTS 26-28 $text = $stdtext1; expect [ extract_multiple($text,undef,5) ], [ divide($stdtext1 => 4, 10, 26, 27) ]; @@ -146,7 +102,6 @@ expect [ pos $text], [ 27 ]; expect [ $text ], [ $stdtext1 ]; -# TESTS 29-31 $text = $stdtext1; expect [ eval{local$^W;scalar extract_multiple($text,undef,5)} ], [ substr($stdtext1,0,4) ]; @@ -156,7 +111,6 @@ expect [ $text ], [ substr($stdtext1,4) ]; -# TESTS 32-34 my $stdtext2 = q{$var = "val" && (1,2,3);}; $text = $stdtext2; @@ -166,7 +120,6 @@ expect [ extract_multiple($text) ], expect [ pos $text], [ 24 ]; expect [ $text ], [ $stdtext2 ]; -# TESTS 35-37 $text = $stdtext2; expect [ scalar extract_multiple($text) ], [ substr($stdtext2,0,4) ]; @@ -175,7 +128,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,4) ]; -# TESTS 38-40 $text = $stdtext2; expect [ extract_multiple($text,[\&extract_bracketed]) ], [ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ]; @@ -183,7 +135,6 @@ expect [ extract_multiple($text,[\&extract_bracketed]) ], expect [ pos $text], [ 24 ]; expect [ $text ], [ $stdtext2 ]; -# TESTS 41-43 $text = $stdtext2; expect [ scalar extract_multiple($text,[\&extract_bracketed]) ], [ substr($stdtext2,0,16) ]; @@ -192,7 +143,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,15) ]; -# TESTS 44-46 $text = $stdtext2; expect [ extract_multiple($text,[\&extract_variable]) ], [ substr($stdtext2,0,4), substr($stdtext2,4) ]; @@ -200,7 +150,6 @@ expect [ extract_multiple($text,[\&extract_variable]) ], expect [ pos $text], [ length($text) ]; expect [ $text ], [ $stdtext2 ]; -# TESTS 47-49 $text = $stdtext2; expect [ scalar extract_multiple($text,[\&extract_variable]) ], [ substr($stdtext2,0,4) ]; @@ -209,7 +158,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,4) ]; -# TESTS 50-52 $text = $stdtext2; expect [ extract_multiple($text,[\&extract_quotelike]) ], [ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ]; @@ -217,7 +165,6 @@ expect [ extract_multiple($text,[\&extract_quotelike]) ], expect [ pos $text], [ length($text) ]; expect [ $text ], [ $stdtext2 ]; -# TESTS 53-55 $text = $stdtext2; expect [ scalar extract_multiple($text,[\&extract_quotelike]) ], [ substr($stdtext2,0,7) ]; @@ -226,7 +173,6 @@ expect [ pos $text], [ 0 ]; expect [ $text ], [ substr($stdtext2,6) ]; -# TESTS 56-58 $text = $stdtext2; expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], [ substr($stdtext2,7,5) ]; @@ -234,7 +180,6 @@ expect [ extract_multiple($text,[\&extract_quotelike],2,1) ], expect [ pos $text], [ 23 ]; expect [ $text ], [ $stdtext2 ]; -# TESTS 59-61 $text = $stdtext2; expect [ eval{local$^W;scalar extract_multiple($text,[\&extract_quotelike],2,1)} ], [ substr($stdtext2,7,5) ]; @@ -243,7 +188,6 @@ expect [ pos $text], [ 6 ]; expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; -# TESTS 62-64 $text = $stdtext2; expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], [ substr($stdtext2,7,5) ]; @@ -251,7 +195,6 @@ expect [ extract_multiple($text,[\&extract_quotelike],1,1) ], expect [ pos $text], [ 12 ]; expect [ $text ], [ $stdtext2 ]; -# TESTS 65-67 $text = $stdtext2; expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], [ substr($stdtext2,7,5) ]; @@ -259,7 +202,6 @@ expect [ scalar extract_multiple($text,[\&extract_quotelike],1,1) ], expect [ pos $text], [ 6 ]; expect [ $text ], [ substr($stdtext2,0,6). substr($stdtext2,12) ]; -# TESTS 68-70 my $stdtext3 = "a,b,c"; $_ = $stdtext3; @@ -269,8 +211,6 @@ expect [ extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; -# TESTS 71-73 - $_ = $stdtext3; expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], [ divide($stdtext3 => 1) ]; @@ -278,9 +218,6 @@ expect [ scalar extract_multiple(undef, [ sub { /\G[a-z]/gc && $& } ]) ], expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,1) ]; - -# TESTS 74-76 - $_ = $stdtext3; expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], [ divide($stdtext3 => 1,2,3,4,5) ]; @@ -288,8 +225,6 @@ expect [ extract_multiple(undef, [ qr/\G[a-z]/ ]) ], expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; -# TESTS 77-79 - $_ = $stdtext3; expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], [ divide($stdtext3 => 1) ]; @@ -297,9 +232,6 @@ expect [ scalar extract_multiple(undef, [ qr/\G[a-z]/ ]) ], expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,1) ]; - -# TESTS 80-82 - $_ = $stdtext3; expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], [ qw(a b c) ]; @@ -307,8 +239,6 @@ expect [ extract_multiple(undef, [ q/([a-z]),?/ ]) ], expect [ pos ], [ 5 ]; expect [ $_ ], [ $stdtext3 ]; -# TESTS 83-85 - $_ = $stdtext3; expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], [ divide($stdtext3 => 1) ]; @@ -316,10 +246,134 @@ expect [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ], expect [ pos ], [ 0 ]; expect [ $_ ], [ substr($stdtext3,2) ]; - -# TEST 86 - # Fails in Text-Balanced-1.95 with result ['1 ', '""', '1234'] $_ = q{ ""1234}; expect [ extract_multiple(undef, [\&extract_quotelike]) ], [ ' ', '""', '1234' ]; + +my $not_here_doc = "sub f {\n my \$pa <<= 2;\n}\n\n"; # wrong in 2.04 +expect [ extract_multiple($not_here_doc, [ + { DONT_MATCH => \&extract_quotelike } +]) ], + [ "sub f {\n my \$pa <<= 2;\n}\n\n" ]; + +my $y_falsematch = <<'EOF'; # wrong in 2.04 +my $p = {y => 1}; +{ $pa=ones(3,3,3); my $f = do { my $i=1; my $v=$$p{y}-$i; $pb = $pa(,$i,) }; } +EOF +expect [ extract_multiple($y_falsematch, [ + \&extract_variable, + { DONT_MATCH => \&extract_quotelike } +]) ], + [ 'my ', '$p', " = {y => 1};\n{ ", '$pa', '=ones(3,3,3); my ', '$f', + ' = do { my ', '$i', '=1; my ', '$v', qw(= $$p{y} - $i), '; ', '$pb', + ' = ', '$pa', '(,', '$i', ",) }; }\n", + ]; + +my $slashmatch = <<'EOF'; # wrong in 2.04 +my $var = 10 / 3; if ($var !~ /\./) { decimal() ;} +EOF +my @expect_slash = ('my ', '$var', ' = 10 / 3; if (', '$var', " !~ ", + '/\\./', ") { decimal() ;}\n" +); +expect [ extract_multiple($slashmatch, [ + \&extract_variable, + \&extract_quotelike, +]) ], + \@expect_slash; + +$slashmatch = <<'EOF'; # wrong in 2.04 +my $var = 10 / 3; if ($var =~ /\./) { decimal() ;} +EOF +$expect_slash[4] = " =~ "; +expect [ extract_multiple($slashmatch, [ + \&extract_variable, + \&extract_quotelike, +]) ], + \@expect_slash; + +$slashmatch = <<'EOF'; # wrong in 2.04 +my $var = 10 / 3; if ($var =~ + # a comment + /\./) { decimal() ;} +EOF +my $comment = qr/(?t->(($a))->sever; +wantarray ? 1 : 0; $min = $var ? 0; +EOF +expect [ extract_multiple($slashmatch, [ + \&extract_variable, $id, \&extract_quotelike, +]) ], + [ + '$x->t->(($a))->sever', ";\n", + 'wantarray', ' ? ', '1', ' : ', '0', '; ', + '$min', ' = ', '$var', ' ? ', '0', ";\n", + ]; + +$slashmatch = <<'EOF'; # wrong in 2.04_01 +$var //= 'default'; $x = 1 / 2; +EOF +expect [ extract_multiple($slashmatch, [ + \&extract_variable, \&extract_quotelike, +]) ], + [ + '$var', ' //= ', '\'default\'', '; ', '$x', " = 1 / 2;\n" + ]; + +$slashmatch = <<'EOF'; # wrong in 2.04_01 +$m; return wantarray ? ($m, $i) : $var ? $m : 0; +EOF +expect [ extract_multiple($slashmatch, [ + \&extract_variable, \&extract_quotelike, +]) ], + [ + '$m', + '; return wantarray ? (', '$m', ', ', '$i', ') : ', '$var', ' ? ', '$m', + " : 0;\n" + ]; + +$slashmatch = <<'EOF'; # wrong in 2.05 +$_ = 1 unless defined $_ and /\d\b/; +EOF +expect [ extract_multiple($slashmatch, [ + \&extract_variable, \&extract_quotelike, +]) ], + [ '$_', ' = 1 unless defined ', '$_', ' and ', '/\\d\\b/', ";\n" ]; + +done_testing; diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/06_extqlk.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/06_extqlk.t index e32ca7d1303..d06489ae98f 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/06_extqlk.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/06_extqlk.t @@ -1,30 +1,13 @@ -#! /usr/local/bin/perl -ws -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..95\n"; } -END {print "not ok 1\n" unless $loaded;} +use Test::More; use Text::Balanced qw ( extract_quotelike ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); -#$DEBUG=1; -sub debug { print "\t>>>",@_ if $ENV{DEBUG} } -sub esc { my $x = shift||''; $x =~ s/\n/\\n/gs; $x } -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } +sub esc { my $x = shift||''; $x =~ s/\n/\\n/gs; $x } ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -39,46 +22,49 @@ while (defined($str = )) elsif (!$str || $str =~ /\A#/) { $neg = 0; next } my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : ''; my $tests = 'sl'; + my $orig_str = $str; $str =~ s/\\n/\n/g; my $orig = $str; eval $setup_cmd if $setup_cmd ne ''; + is $@, '', 'no error'; if($tests =~ /l/) { debug "\tUsing: $cmd\n"; debug "\t on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n"; my @res; eval qq{\@res = $cmd; }; + is $@, '', 'no error'; debug "\t got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res); debug "\t left: [" . esc($str) . "]\n"; debug "\t pos: [" . esc(substr($str,pos($str))) . "...]\n"; - print "not " if (substr($str,pos($str),1) eq ';')==$neg; - print "ok ", $count++; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); } eval $setup_cmd if $setup_cmd ne ''; + is $@, '', 'no error'; if($tests =~ /s/) { $str = $orig; debug "\tUsing: scalar $cmd\n"; debug "\t on: [" . esc($str) . "]\n"; my $var = eval $cmd; - print " ($@)" if $@ && $DEBUG; $var = "" unless defined $var; debug "\t scalar got: [" . esc($var) . "]\n"; debug "\t scalar left: [" . esc($str) . "]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); } } # fails in Text::Balanced 1.95 $_ = qq(s{}{}); my @z = extract_quotelike(); -print "not " if $z[0] eq ''; -print "ok ", $count++; -print "\n"; +isnt $z[0], ''; +@z = extract_quotelike("<<, 1; done()\nline1\nline2\n\n and next"); +like $z[1], qr/\A,/, 'implied heredoc with ,' or do { + diag "error: '$@'\ngot: ", explain \@z; +}; + +done_testing; __DATA__ @@ -89,7 +75,6 @@ __DATA__ 'b'; `cc`; - <>>",@_ if $DEBUG } -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -34,30 +19,29 @@ while (defined($str = )) if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $orig_str = $str; $str =~ s/\\n/\n/g; debug "\tUsing: $cmd\n"; debug "\t on: [$str]\n"; my @res; my $var = eval "\@res = $cmd"; + is $@, '', 'no error'; debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); pos $str = 0; $var = eval $cmd; + is $@, '', 'no error'; $var = "" unless defined $var; debug "\t scalar got: [$var]\n"; debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); } +done_testing; + __DATA__ # USING: gen_extract_tagged("BEGIN([A-Z]+)",'END$1',"(?s).*?(?=BEGIN)")->($str); ignore\n this and then BEGINHERE at the ENDHERE; diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/08_extvar.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/08_extvar.t index f527b843e0c..096136af7f7 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/08_extvar.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/08_extvar.t @@ -1,27 +1,12 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..183\n"; } -END {print "not ok 1\n" unless $loaded;} +use Test::More; use Text::Balanced qw ( extract_variable ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -34,30 +19,32 @@ while (defined($str = )) if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; } elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } elsif (!$str || $str =~ /\A#/) { $neg = 0; next } + my $orig_str = $str; $str =~ s/\\n/\n/g; debug "\tUsing: $cmd\n"; debug "\t on: [$str]\n"; my @res; my $var = eval "\@res = $cmd"; + is $@, '', 'no error'; debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); pos $str = 0; $var = eval $cmd; + is $@, '', 'no error'; $var = "" unless defined $var; debug "\t scalar got: [$var]\n"; debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); } +my @res = extract_variable('${a}'); +is $res[0], '${a}' or diag "error was: $@"; + +done_testing; + __DATA__ # USING: extract_variable($str); diff --git a/gnu/usr.bin/perl/cpan/Text-Balanced/t/09_gentag.t b/gnu/usr.bin/perl/cpan/Text-Balanced/t/09_gentag.t index 1a82ae1e211..9b40548235d 100755 --- a/gnu/usr.bin/perl/cpan/Text-Balanced/t/09_gentag.t +++ b/gnu/usr.bin/perl/cpan/Text-Balanced/t/09_gentag.t @@ -1,27 +1,12 @@ -# Before `make install' is performed this script should be runnable with -# `make test'. After `make install' it should work as `perl test.pl' - use 5.008001; use strict; use warnings; - -######################### We start with some black magic to print on failure. - -# Change 1..1 below to 1..last_test_to_print . -# (It may become useful if the test is moved to ./t subdirectory.) - -my $loaded = 0; -BEGIN { $| = 1; print "1..37\n"; } -END {print "not ok 1\n" unless $loaded;} use Text::Balanced qw ( gen_extract_tagged ); -$loaded = 1; -print "ok 1\n"; -my $count=2; -use vars qw( $DEBUG ); -sub debug { print "\t>>>",@_ if $DEBUG } +use Test::More; -######################### End of black magic. +our $DEBUG; +sub debug { print "\t>>>",@_ if $DEBUG } ## no critic (BuiltinFunctions::ProhibitStringyEval) @@ -31,6 +16,7 @@ my $str; while (defined($str = )) { chomp $str; + my $orig_str = $str; $str =~ s/\\n/\n/g; if ($str =~ s/\A# USING://) { @@ -41,6 +27,7 @@ while (defined($str = )) local $SIG{__WARN__} = sub { push @warnings, shift; }; *f = eval $str || die; }; + is $@, '', 'no error'; next; } elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; } @@ -51,24 +38,22 @@ while (defined($str = )) my @res; my $var = eval { @res = f($str) }; + is $@, '', 'no error'; debug "\t list got: [" . join("|",map {defined $_ ? $_ : ''} @res) . "]\n"; debug "\t list left: [$str]\n"; - print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list"); pos $str = 0; $var = eval { scalar f($str) }; + is $@, '', 'no error'; $var = "" unless defined $var; debug "\t scalar got: [$var]\n"; debug "\t scalar left: [$str]\n"; - print "not " if ($str =~ '\A;')==$neg; - print "ok ", $count++; - print " ($@)" if $@ && $DEBUG; - print "\n"; + ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar"); } +done_testing; + __DATA__ # USING: gen_extract_tagged('{','}'); diff --git a/gnu/usr.bin/perl/cpan/autodie/t/exception_class.t b/gnu/usr.bin/perl/cpan/autodie/t/exception_class.t index 127893bcbf7..b15d110f3a1 100755 --- a/gnu/usr.bin/perl/cpan/autodie/t/exception_class.t +++ b/gnu/usr.bin/perl/cpan/autodie/t/exception_class.t @@ -43,7 +43,7 @@ like($@, qr/Bad exception class/, '$@ should contain bad exception class msg'); ### Tests with well-formed exception class (in Klingon) my $open_success3 = eval { - use pujHa'ghach qw(open); #' <-- this makes my editor happy + use pujHa::ghach qw(open); open(my $fh, '<', NO_SUCH_FILE); 1; }; @@ -52,6 +52,6 @@ is($open_success3,undef,"Open should fail"); isnt("$@","",'$@ should not be empty'); -isa_ok($@, "pujHa'ghach::Dotlh", '$@ should be a Klingon exception'); +isa_ok($@, "pujHa::ghach::Dotlh", '$@ should be a Klingon exception'); like($@, qr/lujqu'/, '$@ should contain Klingon text'); diff --git a/gnu/usr.bin/perl/cpan/bignum/lib/Math/BigRat/Trace.pm b/gnu/usr.bin/perl/cpan/bignum/lib/Math/BigRat/Trace.pm index df6e998e72b..e61df01317c 100644 --- a/gnu/usr.bin/perl/cpan/bignum/lib/Math/BigRat/Trace.pm +++ b/gnu/usr.bin/perl/cpan/bignum/lib/Math/BigRat/Trace.pm @@ -10,7 +10,7 @@ use Math::BigRat; our @ISA = qw(Exporter Math::BigRat); -our $VERSION = '0.65'; +our $VERSION = '0.66'; use overload; # inherit overload from Math::BigRat diff --git a/gnu/usr.bin/perl/cpan/bignum/lib/bigfloat.pm b/gnu/usr.bin/perl/cpan/bignum/lib/bigfloat.pm index af26c57e1cd..c1b6111ea94 100644 --- a/gnu/usr.bin/perl/cpan/bignum/lib/bigfloat.pm +++ b/gnu/usr.bin/perl/cpan/bignum/lib/bigfloat.pm @@ -5,7 +5,7 @@ use warnings; use Carp qw< carp croak >; -our $VERSION = '0.65'; +our $VERSION = '0.66'; use Exporter; our @ISA = qw( Exporter ); diff --git a/gnu/usr.bin/perl/cpan/bignum/t/infnan-bignum-mbf.t b/gnu/usr.bin/perl/cpan/bignum/t/infnan-bignum-mbf.t new file mode 100644 index 00000000000..111d76430e1 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/bignum/t/infnan-bignum-mbf.t @@ -0,0 +1,101 @@ +# -*- mode: perl; -*- + +use strict; +use warnings; + +use Test::More tests => 66; + +# Default: upgrade => "Math::BigFloat", downgrade => "Math::BigInt"; +use bignum; + +my $class = "Math::BigInt"; +my $x; + +############################################################################### + +note("inf tests"); + +$x = 1 + inf; +note("\n\n" . $x . "\n\n"); + +$x = 1 + inf; +is(ref($x), $class, "\$x = 1 + inf makes a $class"); +is($x->bstr(), "inf", '$x = 1 + inf; $x->bstr() = "inf"'); + +$x = 1 * inf; +is(ref($x), $class, "\$x = 1 * inf makes a $class"); +is($x->bstr(), "inf", '$x = 1 * inf; $x->bstr() = "inf"'); + +# these don't work without exporting inf() +$x = inf; +is(ref($x), $class, "\$x = inf makes a $class"); +is($x->bstr(), "inf", '$x = inf; $x->bstr() = "inf"'); + +$x = inf + inf; +is(ref($x), $class, "\$x = inf + inf makes a $class"); +is($x->bstr(), "inf", '$x = inf + inf; $x->bstr() = "inf"'); + +$x = inf * inf; +is(ref($x), $class, "\$x = inf * inf makes a $class"); +is($x->bstr(), "inf", '$x = inf * inf; $x->bstr() = "inf"'); + +############################################################################### + +note("NaN tests"); + +$x = 1 + NaN; +is(ref($x), $class, "\$x = 1 + NaN makes a $class"); +is($x->bstr(), "NaN", '$x = 1 + NaN; $x->bstr() = "NaN"'); + +$x = 1 * NaN; +is(ref($x), $class, "\$x = 1 * NaN makes a $class"); +is($x->bstr(), "NaN", '$x = 1 * NaN; $x->bstr() = "NaN"'); + +# these don't work without exporting NaN() +$x = NaN; +is(ref($x), $class, "\$x = NaN makes a $class"); +is($x->bstr(), "NaN", '$x = NaN; $x->bstr() = "NaN"'); + +$x = NaN + NaN; +is(ref($x), $class, "\$x = NaN + NaN makes a $class"); +is($x->bstr(), "NaN", '$x = NaN + NaN; $x->bstr() = "NaN"'); + +$x = NaN * NaN; +is(ref($x), $class, "\$x = NaN * NaN makes a $class"); +is($x->bstr(), "NaN", '$x = NaN * NaN; $x->bstr() = "NaN"'); + +############################################################################### + +note("mixed tests"); + +# these don't work without exporting NaN() or inf() + +$x = NaN + inf; +is(ref($x), $class, "\$x = NaN + inf makes a $class"); +is($x->bstr(), "NaN", '$x = NaN + inf; $x->bstr() = "NaN"'); + +$x = NaN * inf; +is(ref($x), $class, "\$x = NaN * inf makes a $class"); +is($x->bstr(), "NaN", '$x = NaN * inf; $x->bstr() = "NaN"'); + +$x = inf * NaN; +is(ref($x), $class, "\$x = inf * NaN makes a $class"); +is($x->bstr(), "NaN", '$x = inf * NaN; $x->bstr() = "NaN"'); + +############################################################################### +# inf and NaN as strings. + +for my $nan (qw/ nan naN nAn nAN Nan NaN NAn NAN /) { + my $x = 1 + $nan; + is($x->bstr(), "NaN", qq|\$x = 1 + "$nan"|); + is(ref($x), $class, "\$x is a $class"); +} + +for my $inf (qw/ inf inF iNf iNF Inf InF INf INF + infinity Infinity InFiNiTy iNfInItY + /) +{ + my $x = 1 + $inf; + is($x->bstr(), "inf", qq|\$x = 1 + "$inf"|); + is(ref($x), $class, "\$x is a $class"); +} diff --git a/gnu/usr.bin/perl/cpan/bignum/t/infnan-bignum-mbr.t b/gnu/usr.bin/perl/cpan/bignum/t/infnan-bignum-mbr.t new file mode 100644 index 00000000000..aceb138fdeb --- /dev/null +++ b/gnu/usr.bin/perl/cpan/bignum/t/infnan-bignum-mbr.t @@ -0,0 +1,101 @@ +# -*- mode: perl; -*- + +use strict; +use warnings; + +use Test::More tests => 66; + +# Default: upgrade => "Math::BigFloat", downgrade => "Math::BigInt"; +use bignum upgrade => "Math::BigRat"; + +my $class = "Math::BigInt"; +my $x; + +############################################################################### + +note("inf tests"); + +$x = 1 + inf; +note("\n\n" . $x . "\n\n"); + +$x = 1 + inf; +is(ref($x), $class, "\$x = 1 + inf makes a $class"); +is($x->bstr(), "inf", '$x = 1 + inf; $x->bstr() = "inf"'); + +$x = 1 * inf; +is(ref($x), $class, "\$x = 1 * inf makes a $class"); +is($x->bstr(), "inf", '$x = 1 * inf; $x->bstr() = "inf"'); + +# these don't work without exporting inf() +$x = inf; +is(ref($x), $class, "\$x = inf makes a $class"); +is($x->bstr(), "inf", '$x = inf; $x->bstr() = "inf"'); + +$x = inf + inf; +is(ref($x), $class, "\$x = inf + inf makes a $class"); +is($x->bstr(), "inf", '$x = inf + inf; $x->bstr() = "inf"'); + +$x = inf * inf; +is(ref($x), $class, "\$x = inf * inf makes a $class"); +is($x->bstr(), "inf", '$x = inf * inf; $x->bstr() = "inf"'); + +############################################################################### + +note("NaN tests"); + +$x = 1 + NaN; +is(ref($x), $class, "\$x = 1 + NaN makes a $class"); +is($x->bstr(), "NaN", '$x = 1 + NaN; $x->bstr() = "NaN"'); + +$x = 1 * NaN; +is(ref($x), $class, "\$x = 1 * NaN makes a $class"); +is($x->bstr(), "NaN", '$x = 1 * NaN; $x->bstr() = "NaN"'); + +# these don't work without exporting NaN() +$x = NaN; +is(ref($x), $class, "\$x = NaN makes a $class"); +is($x->bstr(), "NaN", '$x = NaN; $x->bstr() = "NaN"'); + +$x = NaN + NaN; +is(ref($x), $class, "\$x = NaN + NaN makes a $class"); +is($x->bstr(), "NaN", '$x = NaN + NaN; $x->bstr() = "NaN"'); + +$x = NaN * NaN; +is(ref($x), $class, "\$x = NaN * NaN makes a $class"); +is($x->bstr(), "NaN", '$x = NaN * NaN; $x->bstr() = "NaN"'); + +############################################################################### + +note("mixed tests"); + +# these don't work without exporting NaN() or inf() + +$x = NaN + inf; +is(ref($x), $class, "\$x = NaN + inf makes a $class"); +is($x->bstr(), "NaN", '$x = NaN + inf; $x->bstr() = "NaN"'); + +$x = NaN * inf; +is(ref($x), $class, "\$x = NaN * inf makes a $class"); +is($x->bstr(), "NaN", '$x = NaN * inf; $x->bstr() = "NaN"'); + +$x = inf * NaN; +is(ref($x), $class, "\$x = inf * NaN makes a $class"); +is($x->bstr(), "NaN", '$x = inf * NaN; $x->bstr() = "NaN"'); + +############################################################################### +# inf and NaN as strings. + +for my $nan (qw/ nan naN nAn nAN Nan NaN NAn NAN /) { + my $x = 1 + $nan; + is($x->bstr(), "NaN", qq|\$x = 1 + "$nan"|); + is(ref($x), $class, "\$x is a $class"); +} + +for my $inf (qw/ inf inF iNf iNF Inf InF INf INF + infinity Infinity InFiNiTy iNfInItY + /) +{ + my $x = 1 + $inf; + is($x->bstr(), "inf", qq|\$x = 1 + "$inf"|); + is(ref($x), $class, "\$x is a $class"); +} diff --git a/gnu/usr.bin/perl/cpan/experimental/lib/stable.pm b/gnu/usr.bin/perl/cpan/experimental/lib/stable.pm new file mode 100644 index 00000000000..7922a2e91b6 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/experimental/lib/stable.pm @@ -0,0 +1,159 @@ +package stable; +$stable::VERSION = '0.031'; +use strict; +use warnings; +use version (); + +use experimental (); +use Carp qw/croak carp/; + +my %allow_at = ( + bitwise => 5.022000, + isa => 5.032000, + lexical_subs => 5.022000, + postderef => 5.020000, +); + +sub import { + my ($self, @pragmas) = @_; + + for my $pragma (@pragmas) { + my $min_ver = $allow_at{$pragma}; + croak "unknown stablized experiment $pragma" unless defined $min_ver; + croak "requested stablized experiment $pragma, which is stable at $min_ver but this is $]" + unless $] >= $min_ver; + } + + experimental->import(@pragmas); + return; +} + +sub unimport { + my ($self, @pragmas) = @_; + + # Look, we could say "You can't unimport stable experiment 'bitwise' on + # 5.20" but it just seems weird. -- rjbs, 2022-03-05 + experimental->unimport(@pragmas); + return; +} + +1; + +#ABSTRACT: Experimental features made easy, once we know they're stable + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +stable - Experimental features made easy, once we know they're stable + +=head1 VERSION + +version 0.031 + +=head1 SYNOPSIS + + use stable 'lexical_subs', 'bitwise'; + my sub is_odd($value) { $value & 1 } + +=head1 DESCRIPTION + +The L pragma makes it easy to turn on experimental while turning +off associated warnings. You should read about it, if you don't already know +what it does. + +Seeing C in code might be scary. In fact, it probably should +be! Code that uses experimental features might break in the future if the perl +development team decides that the experiment needs to be altered. When +experiments become stable, because the developers decide they're a success, the +warnings associated with them go away. When that happens, they can generally +be turned on with C. + +This is great, if you are using a version of perl where the feature you want is +already stable. If you're using an older perl, though, it might be the case +that you want to use an experimental feature that still warns, even though +there's no risk in using it, because subsequent versions of perl have that +feature unchanged and now stable. + +Here's an example: The C feature was added in perl 5.20.0. In perl +5.24.0, it was marked stable. Using it would no longer trigger a warning. The +behavior of the feature didn't change between 5.20.0 and 5.24.0. That means +that it's perfectly safe to use the feature on 5.20 or 5.22, even though +there's a warning. + +In that case, you could very justifiably add C +but the casual reader may still be worried at seeing that. The C +pragma exists to turn on experimental features only when it's known that +their behavior in the running perl is their stable behavior. + +If you try to use an experimental feature that isn't stable or available on +the running version of perl, an exception will be thrown. You should also take +care that you've required the version of C that you need! + +If it's not immediately obvious why, here's a bit of explanation: + +=over 4 + +=item * + +C comes with perl, starting with perl v5.38. + +=item * + +Imagine that v5.38 adds a feature called "florps". It will stop being +experimental in v5.42. + +=item * + +The version of C that comes with perl v5.38 can't know that the +I experiment will succeed, so you can't C on the +version of stable ships with v5.38, because it can't see the future! + +=item * + +You'll need to write C to say that you need version +1.234 of stable, which is when I became known to stable. + +=back + +Sure, it's a little weird, but it's worth it! The documentation of this pragma +will tell you what version of C you need to require in order to use +various features. See below. + +At present there are only a few "stable" features: + +=over 4 + +=item * C - stable as of perl 5.22, available via stable 0.031 + +=item * C - stable as of perl 5.32, available via stable 0.031 + +=item * C - stable as of perl 5.22, available via stable 0.031 + +Lexical subroutines were actually added in 5.18, and their design did not +change, but significant bugs makes them unsafe to use before 5.22. + +=item * C - stable as of perl 5.20, available via stable 0.031 + +=back + +=head1 SEE ALSO + +L contains more information about experimental features. + +=head1 AUTHOR + +Leon Timmermans + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2013 by Leon Timmermans. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/gnu/usr.bin/perl/cpan/parent/t/parent-classfromclassfile.t b/gnu/usr.bin/perl/cpan/parent/t/parent-classfromclassfile.t index 6d92e2ddf3c..0aa7e54295a 100755 --- a/gnu/usr.bin/perl/cpan/parent/t/parent-classfromclassfile.t +++ b/gnu/usr.bin/perl/cpan/parent/t/parent-classfromclassfile.t @@ -18,4 +18,4 @@ use_ok('parent'); # and does not get treated as a file: eval q{package Test1; require Dummy; use parent -norequire, 'Dummy::InlineChild'; }; is $@, '', "Loading an unadorned class works"; -isn't $INC{"Dummy.pm"}, undef, 'We loaded Dummy.pm'; +isnt $INC{"Dummy.pm"}, undef, 'We loaded Dummy.pm'; diff --git a/gnu/usr.bin/perl/cpan/parent/t/parent-classfromfile.t b/gnu/usr.bin/perl/cpan/parent/t/parent-classfromfile.t index 13dbcc15a4e..7afabe95685 100755 --- a/gnu/usr.bin/perl/cpan/parent/t/parent-classfromfile.t +++ b/gnu/usr.bin/perl/cpan/parent/t/parent-classfromfile.t @@ -20,6 +20,6 @@ my $base = './t'; # and does not get treated as a file: eval sprintf q{package Test2; require '%s/lib/Dummy2.plugin'; use parent -norequire, 'Dummy2::InlineChild' }, $base; is $@, '', "Loading a class from a file works"; -isn't $INC{"$base/lib/Dummy2.plugin"}, undef, "We loaded the plugin file"; +isnt $INC{"$base/lib/Dummy2.plugin"}, undef, "We loaded the plugin file"; my $o = bless {}, 'Test2'; isa_ok $o, 'Dummy2::InlineChild'; diff --git a/gnu/usr.bin/perl/cpan/podlators/docs/docknot.yaml b/gnu/usr.bin/perl/cpan/podlators/docs/docknot.yaml new file mode 100644 index 00000000000..02496375016 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/docs/docknot.yaml @@ -0,0 +1,145 @@ +# Package metadata for podlators. +# +# This file contains configuration for DocKnot used to generate +# documentation files (like README.md) and web pages. Other documentation +# in this package is generated automatically from these files as part of +# the release process. For more information, see DocKnot's documentation. +# +# DocKnot is available from . +# +# Copyright 1999-2010, 2012-2022 Russ Allbery +# +# SPDX-License-Identifier: MIT + +format: v1 + +name: podlators +maintainer: Russ Allbery +version: '5.01' +synopsis: format POD source into various output formats + +license: + name: Perl +copyrights: + - holder: Russ Allbery + years: 1999-2010, 2012-2022 + +build: + type: ExtUtils::MakeMaker +distribution: + cpan: podlators + section: perl + tarname: podlators + version: podlators +support: + email: rra@cpan.org + github: rra/podlators + web: https://www.eyrie.org/~eagle/software/podlators/ +vcs: + browse: https://git.eyrie.org/?p=perl/podlators.git + github: rra/podlators + openhub: https://www.openhub.net/p/podlators + status: + workflow: build + type: Git + url: https://git.eyrie.org/git/perl/podlators.git + +quote: + author: Robert Fripp + text: | + We move from making unnecessary efforts, the exertions of force, to making + necessary efforts: the direction of effortlessness. In this the prime + maxim is: honor necessity, honor sufficiency. + work: '"The Road to Graceland"' +docs: + api: + - name: pod-man + title: Pod::Man + - name: pod-text + title: Pod::Text + - name: pod-text-color + title: Pod::Text::Color + - name: pod-text-overstrike + title: Pod::Text::Overstrike + - name: pod-text-termcap + title: Pod::Text::Termcap + developer: + - name: todo + title: To-do list + user: + - name: perlpodstyle + title: POD style guide + - name: pod2man + title: pod2man documentation + - name: pod2text + title: pod2text documentation + - name: thanks + title: Thanks and credits + +blurb: | + podlators contains Pod::Man and Pod::Text modules which convert POD input to + *roff source output, suitable for man pages, or plain text. It also + includes several subclasses of Pod::Text for formatted output to terminals + with various capabilities. It is the source package for the Pod::Man and + Pod::Text modules included with Perl. + +description: | + POD is the Plain Old Documentation format, the documentation language used + for all of Perl's documentation. I learned it to document Perl modules, + started using it for Perl scripts as well, and discovered it was the most + convenient way I've found to write program documentation. It's extremely + simple, well-designed for writing Unix manual pages (and I'm a + traditionalist who thinks that any program should have a regular manual + page), and easily readable in the raw format by humans. + + The translators into text and nroff (for manual pages) included in the Perl + distribution had various bugs, however, and used their own ad hoc parsers, + so when I started running into those bugs and when a new generic parser + (Pod::Parser) was written, I decided to rewrite the two translators that I + use the most and fix the bugs that were bothering me. This package is the + result. + + podlators contains two main modules, Pod::Man and Pod::Text. The former + converts POD into nroff/troff source and the latter into plain text (with + various options controlling some of the formatting). There are also several + subclasses of Pod::Text for generating slightly formatted text using color + or other terminal control escapes, and a general utility module, + Pod::ParseLink, for parsing the POD `L<>` formatting sequences. Also + included in this package are the `pod2text` and `pod2man` driver scripts. + + Both Pod::Text and Pod::Man provide a variety of options for fine-tuning + their output. Pod::Man also tries to massage input text where appropriate + to produce better output when run through nroff or troff, such as + distinguishing between different types of hyphens. + + As of Perl 5.6.0, my implementation was included in Perl core, and each + release of Perl will have the at-the-time most current version of podlators + included. You therefore only need to install this package yourself if you + need a newer version than came with Perl (to get some bug fixes, for + example). + +requirements: | + This module requires Perl 5.10 or later and Pod::Simple 3.26 or later. + (Pod::Simple 3.26 was included in Perl 5.17.10.) + + The troff/nroff generated by Pod::Man should be compatible with any troff or + nroff implementation with the `-man` macro set, including mandoc. It is + primarily tested by me under GNU groff, but Perl users send bug reports for + a wide variety of implementations and Pod::Man is used to generate all of + Perl's own manual pages, so hopefully most of the bugs have been weeded out. + +test: + lancaster: true + suffix: | + The following additional Perl modules will be used by the test suite if + present: + + * Test::CPAN::Changes (part of CPAN-Changes) + * Test::MinimumVersion + * Test::Pod + * Test::Spelling + * Test::Strict + * Test::Synopsis + + All are available on CPAN. Those tests will be skipped if the modules are + not available. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.groff b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.groff new file mode 100644 index 00000000000..649ffdd03e5 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.groff @@ -0,0 +1,87 @@ +.\" +.\" Standard preamble: +.\" ======================================================================== +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft CW +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. +.ie n \{\ +. ds C` "" +. ds C' "" +'br\} +.el\{\ +. ds C` +. ds C' +'br\} +.\" +.\" Escape single quotes in literal strings from groff's Unicode transform. +.ie \n(.g .ds Aq \(aq +.el .ds Aq ' +.\" +.\" If the F register is >0, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.\" +.\" Avoid warning from groff about undefined register 'F'. +.de IX +.. +.nr rF 0 +.if \n(.g .if rF .nr rF 1 +.if (\n(rF:(\n(.g==0)) \{\ +. if \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. if !\nF==2 \{\ +. nr % 0 +. nr F 2 +. \} +. \} +.\} +.rr rF +.\" ======================================================================== +.\" +.IX Title "ENCODING 1" +.TH ENCODING 1 2022-09-25 testing podlators +.\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\" way too many mistakes in technical documents. +.if n .ad l +.nh +.SH "ENCODING TESTS" +.IX Header "ENCODING TESTS" +This POD source is intended to test encoding behavior with different +pod2man encoding options. The resulting *roff output files can be copied +to various systems to test with the local nroff or man implementations. +.PP +ISO 8859\-1 character: na\[u00EF]ve +.PP +ISO 8859\-1 escape: na\[u00EF]ve, na\[u00EF]ve +.PP +Combining accent: nai\[u0308]ve +.PP +SMP plane character: \[u1F600] +.PP +Non-breaking space: foo\ bar, foo\ bar +.PP +Soft hyphen: fac\%tory +.SH LICENSE +.IX Header "LICENSE" +Copyright 2022 Russ Allbery +.PP +Copying and distribution of this file, with or without modification, are +permitted in any medium without royalty provided the copyright notice and +this notice are preserved. This file is offered as-is, without any +warranty. +.PP +SPDX-License-Identifier: FSFAP diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.pod b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.pod new file mode 100644 index 00000000000..e8b46b21148 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.pod @@ -0,0 +1,30 @@ +=encoding utf-8 + +=head1 ENCODING TESTS + +This POD source is intended to test encoding behavior with different +pod2man encoding options. The resulting *roff output files can be copied +to various systems to test with the local nroff or man implementations. + +ISO 8859-1 character: naïve + +ISO 8859-1 escape: naEve, naE<0xEF>ve + +Combining accent: naïve + +SMP plane character: 😀 + +Non-breaking space: foo bar, S + +Soft hyphen: fac­tory + +=head1 LICENSE + +Copyright 2022 Russ Allbery + +Copying and distribution of this file, with or without modification, are +permitted in any medium without royalty provided the copyright notice and +this notice are preserved. This file is offered as-is, without any +warranty. + +SPDX-License-Identifier: FSFAP diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.roff b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.roff new file mode 100644 index 00000000000..68152431efc --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.roff @@ -0,0 +1,149 @@ +.\" +.\" Standard preamble: +.\" ======================================================================== +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft CW +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. +.ie n \{\ +. ds C` "" +. ds C' "" +'br\} +.el\{\ +. ds C` +. ds C' +'br\} +.\" +.\" Escape single quotes in literal strings from groff's Unicode transform. +.ie \n(.g .ds Aq \(aq +.el .ds Aq ' +.\" +.\" If the F register is >0, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.\" +.\" Avoid warning from groff about undefined register 'F'. +.de IX +.. +.nr rF 0 +.if \n(.g .if rF .nr rF 1 +.if (\n(rF:(\n(.g==0)) \{\ +. if \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. if !\nF==2 \{\ +. nr % 0 +. nr F 2 +. \} +. \} +.\} +.rr rF +.\" +.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). +.\" Fear. Run. Save yourself. No user-serviceable parts. +. \" fudge factors for nroff and troff +.if n \{\ +. ds #H 0 +. ds #V .8m +. ds #F .3m +. ds #[ \f1 +. ds #] \fP +.\} +.if t \{\ +. ds #H ((1u-(\\\\n(.fu%2u))*.13m) +. ds #V .6m +. ds #F 0 +. ds #[ \& +. ds #] \& +.\} +. \" simple accents for nroff and troff +.if n \{\ +. ds ' \& +. ds ` \& +. ds ^ \& +. ds , \& +. ds ~ ~ +. ds / +.\} +.if t \{\ +. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h'|\\n:u' +. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' +. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' +. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' +. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' +. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' +.\} +. \" troff and (daisy-wheel) nroff accents +.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' +.ds 8 \h'\*(#H'\(*b\h'-\*(#H' +.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] +.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' +.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' +.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] +.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] +.ds ae a\h'-(\w'a'u*4/10)'e +.ds Ae A\h'-(\w'A'u*4/10)'E +. \" corrections for vroff +.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' +.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' +. \" for low resolution devices (crt and lpr) +.if \n(.H>23 .if \n(.V>19 \ +\{\ +. ds : e +. ds 8 ss +. ds o a +. ds d- d\h'-1'\(ga +. ds D- D\h'-1'\(hy +. ds th \o'bp' +. ds Th \o'LP' +. ds ae ae +. ds Ae AE +.\} +.rm #[ #] #H #V #F C +.\" ======================================================================== +.\" +.IX Title "ENCODING 1" +.TH ENCODING 1 2022-09-25 testing podlators +.\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\" way too many mistakes in technical documents. +.if n .ad l +.nh +.SH "ENCODING TESTS" +.IX Header "ENCODING TESTS" +This POD source is intended to test encoding behavior with different +pod2man encoding options. The resulting *roff output files can be copied +to various systems to test with the local nroff or man implementations. +.PP +ISO 8859\-1 character: nai\*:ve +.PP +ISO 8859\-1 escape: nai\*:ve, nai\*:ve +.PP +Combining accent: naiXve +.PP +SMP plane character: X +.PP +Non-breaking space: foo\ bar, foo\ bar +.PP +Soft hyphen: fac\%tory +.SH LICENSE +.IX Header "LICENSE" +Copyright 2022 Russ Allbery +.PP +Copying and distribution of this file, with or without modification, are +permitted in any medium without royalty provided the copyright notice and +this notice are preserved. This file is offered as-is, without any +warranty. +.PP +SPDX-License-Identifier: FSFAP diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.utf8 b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.utf8 new file mode 100644 index 00000000000..077028a33f3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/man/encoding.utf8 @@ -0,0 +1,88 @@ +.\" -*- mode: troff; coding: utf-8 -*- +.\" +.\" Standard preamble: +.\" ======================================================================== +.de Sp \" Vertical space (when we can't use .PP) +.if t .sp .5v +.if n .sp +.. +.de Vb \" Begin verbatim text +.ft CW +.nf +.ne \\$1 +.. +.de Ve \" End verbatim text +.ft R +.fi +.. +.\" \*(C` and \*(C' are quotes in nroff, nothing in troff, for use with C<>. +.ie n \{\ +. ds C` "" +. ds C' "" +'br\} +.el\{\ +. ds C` +. ds C' +'br\} +.\" +.\" Escape single quotes in literal strings from groff's Unicode transform. +.ie \n(.g .ds Aq \(aq +.el .ds Aq ' +.\" +.\" If the F register is >0, we'll generate index entries on stderr for +.\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index +.\" entries marked with X<> in POD. Of course, you'll have to process the +.\" output yourself in some meaningful fashion. +.\" +.\" Avoid warning from groff about undefined register 'F'. +.de IX +.. +.nr rF 0 +.if \n(.g .if rF .nr rF 1 +.if (\n(rF:(\n(.g==0)) \{\ +. if \nF \{\ +. de IX +. tm Index:\\$1\t\\n%\t"\\$2" +.. +. if !\nF==2 \{\ +. nr % 0 +. nr F 2 +. \} +. \} +.\} +.rr rF +.\" ======================================================================== +.\" +.IX Title "ENCODING 1" +.TH ENCODING 1 2022-09-25 testing podlators +.\" For nroff, turn off justification. Always turn off hyphenation; it makes +.\" way too many mistakes in technical documents. +.if n .ad l +.nh +.SH "ENCODING TESTS" +.IX Header "ENCODING TESTS" +This POD source is intended to test encoding behavior with different +pod2man encoding options. The resulting *roff output files can be copied +to various systems to test with the local nroff or man implementations. +.PP +ISO 8859\-1 character: naïve +.PP +ISO 8859\-1 escape: naïve, naïve +.PP +Combining accent: naïve +.PP +SMP plane character: 😀 +.PP +Non-breaking space: foo\ bar, foo\ bar +.PP +Soft hyphen: fac\%tory +.SH LICENSE +.IX Header "LICENSE" +Copyright 2022 Russ Allbery +.PP +Copying and distribution of this file, with or without modification, are +permitted in any medium without royalty provided the copyright notice and +this notice are preserved. This file is offered as-is, without any +warranty. +.PP +SPDX-License-Identifier: FSFAP diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/perlcriticrc b/gnu/usr.bin/perl/cpan/podlators/t/data/perlcriticrc new file mode 100644 index 00000000000..46436834c31 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/perlcriticrc @@ -0,0 +1,125 @@ +# -*- conf -*- +# +# Default configuration for perlcritic. Be sure to copy this into the source +# for packages that run perlcritic tests automatically during the build for +# reproducible test results. +# +# This file has been updated to match perlcritic 1.134. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2018-2022 Russ Allbery +# Copyright 2011-2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# 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 + +severity = 1 +verbose = %f:%l:%c: [%p] %m (%e, Severity: %s)\n + +# I prefer this policy (a lot, actually), but other people in my group at +# Stanford really didn't like it, so this is my compromise to agree with a +# group coding style. +[-CodeLayout::ProhibitParensWithBuiltins] + +# This conflicts with Subroutines::ProhibitExplicitReturnUndef and +# Subroutines::RequireFinalReturn, and I prefer the brevity of the simple +# return statement. I don't think the empty list versus undef behavior is +# that confusing. +# +# This should be Community::EmptyReturn, which is the new name of the module, +# but currently ignores have to use the Freenode::EmptyReturn name instead. +[-Community::EmptyReturn] +[-Freenode::EmptyReturn] + +# This recommends using given/when, but Perl has marked those as experimental +# and cautions against using when. +[-ControlStructures::ProhibitCascadingIfElse] + +# Stanford's coding style allows postfix unless for flow control. There +# doesn't appear to be any way to allow it only for flow control (the logic +# for "if" and "when" appears to be special-cased), so we have to allow unless +# globally. +[ControlStructures::ProhibitPostfixControls] +allow = unless + +# This is handled with a separate test case that uses Test::Spelling. +[-Documentation::PodSpelling] + +# The POD sections Perl::Critic wants are incompatible with the POD template +# from perlpodstyle, which is what I use for my POD documentation. +[-Documentation::RequirePodSections] + +# This problem was fixed in Perl 5.14, which now properly preserves the value +# of $@ even if destructors run at exit from the eval block. +[-ErrorHandling::RequireCheckingReturnValueOfEval] + +# The default of 9 is too small and forces weird code contortions. After some +# experimentation, I've never found this helpful in driving useful refactors. +[-InputOutput::RequireBriefOpen] + +# This is correct 80% of the time, but it isn't correct for a lot of scripts +# inside packages, where maintaining $VERSION isn't worth the effort. +# Unfortunately, there's no way to override it, so it gets turned off +# globally. +[-Modules::RequireVersionVar] + +# This sounds interesting but is actually useless. Any large blocks of +# literal text, which does not add to the complexity of the regex, will set it +# off. +[-RegularExpressions::ProhibitComplexRegexes] + +# Produces false positives currently with postfix dereferencing (introduced in +# Perl 5.20). See https://github.com/Perl-Critic/Perl-Critic/issues/578. +[-References::ProhibitDoubleSigils] + +# Five arguments to a method has seemed reasonable at least once: a pair of +# input file data and path, a pair of output file descriptor and path, and +# a dict of additional arguments. +[Subroutines::ProhibitManyArgs] +skip_object = 1 + +# I generally don't want to require Readonly as a prerequisite for all my Perl +# modules. +[-ValuesAndExpressions::ProhibitConstantPragma] + +# A good idea, but there are too many places where this would be more +# confusing than helpful. Pull out numbers if one might change them +# independent of the algorithm, but don't do so for mathematical formulae. +[-ValuesAndExpressions::ProhibitMagicNumbers] + +# This has never triggered on anything useful and keeps telling me to add +# underscores to UNIX timestamps and port numbers, which is just silly. +[-ValuesAndExpressions::RequireNumberSeparators] + +# IO::Uncompress::Gunzip puts the error message in a package variable. +# Text::Wrap has a broken interface that requires use of package variables. +# YAML::XS also cannot be configured without package variables. +[Variables::ProhibitPackageVars] +add_packages = IO::Uncompress::Gunzip Text::Wrap YAML::XS + +# use English was one of the worst ideas in the history of Perl. It makes the +# code slightly more readable for amateurs at the cost of confusing +# experienced Perl programmers and sending people in futile quests for where +# these magical global variables are defined. +[-Variables::ProhibitPunctuationVars] diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/perltidyrc b/gnu/usr.bin/perl/cpan/podlators/t/data/perltidyrc new file mode 100644 index 00000000000..dc3a2f74fee --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/perltidyrc @@ -0,0 +1,30 @@ +# -*- conf -*- +# +# Default options for perltidy for proper Perl code reformatting. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at . +# +# Written by Russ Allbery +# Copyright 2021-2022 Russ Allbery +# Copyright 2012-2013 +# The Board of Trustees of the Leland Stanford Junior University +# +# Copying and distribution of this file, with or without modification, are +# permitted in any medium without royalty provided the copyright notice and +# this notice are preserved. This file is offered as-is, without any +# warranty. +# +# SPDX-License-Identifier: FSFAP + +-bbao # put line breaks before any operator +-nbbc # don't force blank lines before comments (bad for else blocks) +-boc # do not re-break lists, since perltidy is awful at this +-ce # cuddle braces around else +-l=79 # usually use 78, but don't want 79-long lines reformatted +-nlop # disable vertical alignment of logical and ternary expressions +-pt=2 # don't add extra whitespace around parentheses +-sbt=2 # ...or square brackets +-nsfs # no space before semicolon in for (not that I use this form) +-nvc # disable vertical alignment of = and similar symbols +-xci # improve indentation of nested structures diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/regenerate-data b/gnu/usr.bin/perl/cpan/podlators/t/data/regenerate-data new file mode 100644 index 00000000000..d118afbc637 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/regenerate-data @@ -0,0 +1,108 @@ +#!/usr/bin/perl +# +# Development helper program to regenerate test data. +# +# The snippet tests are designed to keep the output fairly stable, but there +# are a few tests that use complete output with some customization. This +# helper program regenerates those files using the local installation of +# podlators. The output can then be reviewed with normal Git tools. +# +# Copyright 2022 Russ Allbery +# +# 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 lib 'blib/lib'; + +use File::Spec; +use Pod::Man; +use Pod::Text; +use Pod::Text::Color; +use Pod::Text::Overstrike; +use Pod::Text::Termcap; + +# Hard-code configuration for Term::Cap to get predictable results. +#<<< +local $ENV{COLUMNS} = 80; +local $ENV{TERM} = 'xterm'; +local $ENV{TERMPATH} = File::Spec->catfile('t', 'data', 'termcap'); +local $ENV{TERMCAP} = 'xterm:co=#80:do=^J:md=\\E[1m:us=\\E[4m:me=\\E[m'; +#>>> + +# Map of translators to the file containing the formatted output for the +# general/basic.t test. +#<<< +my %output = ( + 'Pod::Man' => File::Spec->catfile('t', 'data', 'basic.man'), + 'Pod::Text' => File::Spec->catfile('t', 'data', 'basic.txt'), + 'Pod::Text::Color' => File::Spec->catfile('t', 'data', 'basic.clr'), + 'Pod::Text::Overstrike' => File::Spec->catfile('t', 'data', 'basic.ovr'), + 'Pod::Text::Termcap' => File::Spec->catfile('t', 'data', 'basic.cap'), +); +#>>> + +# Regenerate those output files. +my $input = File::Spec->catfile('t', 'data', 'basic.pod'); +for my $module (keys(%output)) { + my $parser = $module->new(); + + # Run the formatting module. + my $output; + $parser->output_string(\$output); + $parser->parse_file($input); + + # If the test module is Pod::Man, strip off the header. This test does + # not attempt to compare it, since it contains version numbers that + # change. + if ($module eq 'Pod::Man') { + $output =~ s{ \A .* \n [.]nh \n }{}xms; + } + + # Overwrite the output. + open(my $fh, '>', $output{$module}) + or die "cannot create $output{$module}: $!\n"; + print {$fh} $output + or die "cannot write to $output{$module}: $!\n"; + close($fh) + or die "cannot write to $output{$module}: $!\n"; +} + +# Now switch to the files for the man/encoding.t test. +$input = File::Spec->catfile('t', 'data', 'man', 'encoding.pod'); +#<<< +%output = ( + groff => File::Spec->catfile('t', 'data', 'man', 'encoding.groff'), + roff => File::Spec->catfile('t', 'data', 'man', 'encoding.roff'), + utf8 => File::Spec->catfile('t', 'data', 'man', 'encoding.utf8'), +); +#>>> + +# For each encoding, load the input, generate the output, and check that the +# output matches. +for my $encoding (keys(%output)) { + my $parser = Pod::Man->new( + encoding => $encoding, + center => 'podlators', + release => 'testing', + ); + my $output; + $parser->output_string(\$output); + $parser->parse_file($input); + + # Strip off the version line. + $output =~ s{ ^ [^\n]+ Automatically [ ] generated [ ] by [^\n]+ \n }{}xms; + + # Overwrite the output. + open(my $fh, '>', $output{$encoding}) + or die "cannot create $output{$encoding}: $!\n"; + print {$fh} $output + or die "cannot write to $output{$encoding}: $!\n"; + close($fh) + or die "cannot write to $output{$encoding}: $!\n"; +} diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/README.md b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/README.md new file mode 100644 index 00000000000..92ccc64c56b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/README.md @@ -0,0 +1,51 @@ +# Test snippets + +The files in this directory are used by the test suite to exercise various +behavior of Pod::Man or Pod::Text. They use a pseudo-ini-file syntax with +free-form sections, normally an input and an output section and possibly +others. + +Sections start with the section type in `[]`. The contents are normally +free-form text. The exception is an `[options]` section, where the +contents are key/value pairs, where the key is separated from the value +with whitespace. + +Valid sections are: + +``` + [name] + The name of this test for status reporting + + [options] + key value + key value + + [input] + POD input source. + + [output] + The results of running some formatter on the input. + + [errors] + Errors reported to standard error when running some formatter on the + input. + + [exception] + The text of an exception (with the file and line number information + stripped) thrown by running some formatter on the input. +``` + +Files are organized into subdirectories named after the formatter, namely +man (Pod::Man), text (Pod::Text), color (Pod::Text::Color), overstrike +(Pod::Text::Overstrike), and termcap (Pod::Text::Termcap). + +## Copyright and license + +Copyright 2015, 2018, 2022 Russ Allbery + +Copying and distribution of this file, with or without modification, are +permitted in any medium without royalty provided the copyright notice and +this notice are preserved. This file is offered as-is, without any +warranty. + +SPDX-License-Identifier: FSFAP diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/agrave b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/agrave index c1ec02655ae..1f1f0db5e6a 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/agrave +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/agrave @@ -1,12 +1,15 @@ [name] E +[options] +encoding roff + [input] =head1 agrave Open E la shell. Previous versions mapped it wrong. [output] -.SH "agrave" +.SH agrave .IX Header "agrave" Open a\*` la shell. Previous versions mapped it wrong. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullet-after-nonbullet b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullet-after-nonbullet index f98302add6d..31baf553248 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullet-after-nonbullet +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullet-after-nonbullet @@ -18,8 +18,8 @@ Also not a bullet. =back [output] -.IP "foo" 4 +.IP foo 4 .IX Item "foo" Not a bullet. -.IP "*" 4 +.IP * 4 Also not a bullet. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullets b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullets index 8cab7e9e521..3d280d5d9d5 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullets +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/bullets @@ -17,9 +17,9 @@ Another bullet. =back [output] -.IP "\(bu" 4 +.IP \(bu 4 A bullet. -.IP "\(bu" 4 +.IP \(bu 4 Another bullet. -.IP "\(bu" 4 +.IP \(bu 4 Also a bullet. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/c-in-name b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/c-in-name index e17952d0d5a..f8f93fc22d9 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/c-in-name +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/c-in-name @@ -7,5 +7,5 @@ C<> in NAME test - C [output] -.SH "NAME" +.SH NAME test \- "test" diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/cpp b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/cpp index 177aeeeb89d..c21515cc729 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/cpp +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/cpp @@ -13,8 +13,8 @@ Other mentions of C++. =cut [output] -.SH "NAME" +.SH NAME gcc \- GNU project C and C++ compiler -.SH "\*(C+ NOTES" -.IX Header " NOTES" -Other mentions of \*(C+. +.SH "C++ NOTES" +.IX Header "C++ NOTES" +Other mentions of C++. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/dollar-magic b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/dollar-magic index 26347329713..d5546eac5b9 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/dollar-magic +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/dollar-magic @@ -17,8 +17,8 @@ price is $100." .IX Header "MAGIC MONEY" These should be identical. .PP -Bippity boppity boo \*(L"The -price is \f(CW$100\fR.\*(R" +Bippity boppity boo "The +price is \f(CW$100\fR." .PP -Bippity boppity boo \*(L"The -price is \f(CW$100\fR.\*(R" +Bippity boppity boo "The +price is \f(CW$100\fR." diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-die b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-die index 48b9cac7950..9458d07f71b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-die +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-die @@ -14,10 +14,10 @@ Bar. =head1 NEXT [output] -.IP "Foo" 4 +.IP Foo 4 .IX Item "Foo" Bar. -.SH "NEXT" +.SH NEXT .IX Header "NEXT" [errors] diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-none b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-none index 0636c3c4767..f760e023d95 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-none +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-none @@ -16,8 +16,8 @@ Bar. =head1 NEXT [output] -.IP "Foo" 4 +.IP Foo 4 .IX Item "Foo" Bar. -.SH "NEXT" +.SH NEXT .IX Header "NEXT" diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-normal b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-normal index cdd5d40e00b..364fc55cebf 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-normal +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-normal @@ -11,10 +11,10 @@ Bar. =head1 NEXT [output] -.IP "Foo" 4 +.IP Foo 4 .IX Item "Foo" Bar. -.SH "NEXT" +.SH NEXT .IX Header "NEXT" .SH "POD ERRORS" .IX Header "POD ERRORS" diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-pod b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-pod index 44056539a47..d8c8f028b77 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-pod +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-pod @@ -14,10 +14,10 @@ Bar. =head1 NEXT [output] -.IP "Foo" 4 +.IP Foo 4 .IX Item "Foo" Bar. -.SH "NEXT" +.SH NEXT .IX Header "NEXT" .SH "POD ERRORS" .IX Header "POD ERRORS" diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr index 9effc9eef97..7d163a6deda 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr @@ -14,10 +14,10 @@ Bar. =head1 NEXT [output] -.IP "Foo" 4 +.IP Foo 4 .IX Item "Foo" Bar. -.SH "NEXT" +.SH NEXT .IX Header "NEXT" [errors] diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr-opt b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr-opt index e4e0cf8e195..549adee483f 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr-opt +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/error-stderr-opt @@ -14,10 +14,10 @@ Bar. =head1 NEXT [output] -.IP "Foo" 4 +.IP Foo 4 .IX Item "Foo" Bar. -.SH "NEXT" +.SH NEXT .IX Header "NEXT" [errors] diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/eth b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/eth index 6583ccb1fda..835b45b9092 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/eth +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/eth @@ -1,6 +1,9 @@ [name] E +[options] +encoding roff + [input] =pod diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font index f0b8524e715..19b8aaf26a2 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font @@ -15,4 +15,4 @@ C> I> [output] .SH "FIXED FONTS" .IX Header "FIXED FONTS" -\&\f(CR\*(C`foo \f(CYbar \f(CXbaz\f(CY\f(CR \f(CWbay\f(CR\*(C'\fR +\&\f(CR\*(C`foo \fR\f(CYbar \fR\f(CXbaz\fR\f(CR \fR\f(CWbay\fR\f(CR\*(C'\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font-in-item b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font-in-item index e096fd4cd61..523ac7326ab 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font-in-item +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/fixed-font-in-item @@ -4,8 +4,8 @@ Fixed-width font in item [input] =head1 Fixed-width Fonts in =item -The nroff portion should not use fixed-width fonts. In podlators 4.06 and -earlier, italic was terminated with \f(CW, which didn't properly stop italic. +In podlators 4.06 and earlier, italic was terminated with \f(CW, which +didn't properly stop italic. =over 2 @@ -18,12 +18,12 @@ earlier, italic was terminated with \f(CW, which didn't properly stop italic. [output] .SH "Fixed-width Fonts in =item" .IX Header "Fixed-width Fonts in =item" -The nroff portion should not use fixed-width fonts. In podlators 4.06 and -earlier, italic was terminated with \ef(\s-1CW,\s0 which didn't properly stop italic. -.ie n .IP """tar \fIoption\fP... [\fIname\fP]...""" 2 -.el .IP "\f(CWtar \f(CIoption\f(CW... [\f(CIname\f(CW]...\fR" 2 +In podlators 4.06 and earlier, italic was terminated with \ef(CW, which +didn't properly stop italic. +.ie n .IP """tar \fIoption\fR... [\fIname\fR]...""" 2 +.el .IP "\f(CWtar \fR\f(CIoption\fR\f(CW... [\fR\f(CIname\fR\f(CW]...\fR" 2 .IX Item "tar option... [name]..." .PD 0 -.ie n .IP """tar \fIletter\fP... [\fIargument\fP]... [\fIoption\fP]... [\fIname\fP]...""" 2 -.el .IP "\f(CWtar \f(CIletter\f(CW... [\f(CIargument\f(CW]... [\f(CIoption\f(CW]... [\f(CIname\f(CW]...\fR" 2 +.ie n .IP """tar \fIletter\fR... [\fIargument\fR]... [\fIoption\fR]... [\fIname\fR]...""" 2 +.el .IP "\f(CWtar \fR\f(CIletter\fR\f(CW... [\fR\f(CIargument\fR\f(CW]... [\fR\f(CIoption\fR\f(CW]... [\fR\f(CIname\fR\f(CW]...\fR" 2 .IX Item "tar letter... [argument]... [option]... [name]..." diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork new file mode 100644 index 00000000000..ff9a46248cb --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork @@ -0,0 +1,24 @@ +[name] +Non-quoting guesswork applied by default + +[input] +=head1 GUESSWORK + +The hyphens-in-compound-words shouldn't be escaped, but e-mail should be. + +Function: foo(), bar::baz(), _private::_stuff() + +Manpage: foo(1), Pod::Man(3perl), git-rebase(1) + +Variables: $foo, @bar::baz, %Pod::Blah + +[output] +.SH GUESSWORK +.IX Header "GUESSWORK" +The hyphens-in-compound-words shouldn't be escaped, but e\-mail should be. +.PP +Function: \fBfoo()\fR, \fBbar::baz()\fR, \fB_private::_stuff()\fR +.PP +Manpage: \fBfoo\fR\|(1), \fBPod::Man\fR\|(3perl), \fBgit\-rebase\fR\|(1) +.PP +Variables: \f(CW$foo\fR, \f(CW@bar::baz\fR, \f(CW%Pod::Blah\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-all b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-all new file mode 100644 index 00000000000..536d5ae3e7c --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-all @@ -0,0 +1,27 @@ +[name] +Guesswork with all + +[options] +guesswork all + +[input] +=head1 GUESSWORK + +The hyphens-in-compound-words shouldn't be escaped, but e-mail should be. + +Function: foo(), bar::baz(), _private::_stuff() + +Manpage: foo(1), Pod::Man(3perl), git-rebase(1) + +Variables: $foo, @bar::baz, %Pod::Blah + +[output] +.SH GUESSWORK +.IX Header "GUESSWORK" +The hyphens-in-compound-words shouldn't be escaped, but e\-mail should be. +.PP +Function: \fBfoo()\fR, \fBbar::baz()\fR, \fB_private::_stuff()\fR +.PP +Manpage: \fBfoo\fR\|(1), \fBPod::Man\fR\|(3perl), \fBgit\-rebase\fR\|(1) +.PP +Variables: \f(CW$foo\fR, \f(CW@bar::baz\fR, \f(CW%Pod::Blah\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-no-quoting b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-no-quoting new file mode 100644 index 00000000000..71954f456a9 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-no-quoting @@ -0,0 +1,57 @@ +[name] +Disable quoting guesswork + +[options] +guesswork none + +[input] +=head1 QUOTING + +Suppress quotes: +C<"foo">, +C<'foo'>, +C<`foo`>, +C<`foo'>, + +All these should now be quoted: +C<$#f>, +C<$foo[4]>, +C<$foo{bar}>, +C<%foo>, +C<@foo>, +C<&foo>, +C<*foo>, +C<< $foo->("bar") >>, +C<&foo::baz("bar")>, +C<&foo()>, +C, +C<-1000>, +C<132.123>, +C<5e-7>, +C<0xdeadbeef> + +[output] +.SH QUOTING +.IX Header "QUOTING" +Suppress quotes: +\&\f(CW"foo"\fR, +\&\f(CW\*(Aqfoo\*(Aq\fR, +\&\f(CW\`foo\`\fR, +\&\f(CW\`foo\*(Aq\fR, +.PP +All these should now be quoted: +\&\f(CW\*(C`$#f\*(C'\fR, +\&\f(CW\*(C`$foo[4]\*(C'\fR, +\&\f(CW\*(C`$foo{bar}\*(C'\fR, +\&\f(CW\*(C`%foo\*(C'\fR, +\&\f(CW\*(C`@foo\*(C'\fR, +\&\f(CW\*(C`&foo\*(C'\fR, +\&\f(CW\*(C`*foo\*(C'\fR, +\&\f(CW\*(C`$foo\->("bar")\*(C'\fR, +\&\f(CW\*(C`&foo::baz("bar")\*(C'\fR, +\&\f(CW\*(C`&foo()\*(C'\fR, +\&\f(CW\*(C`foo( "bar" )\*(C'\fR, +\&\f(CW\*(C`\-1000\*(C'\fR, +\&\f(CW\*(C`132.123\*(C'\fR, +\&\f(CW\*(C`5e\-7\*(C'\fR, +\&\f(CW\*(C`0xdeadbeef\*(C'\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-none b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-none new file mode 100644 index 00000000000..51876060878 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-none @@ -0,0 +1,27 @@ +[name] +Non-quoting guesswork disabled + +[options] +guesswork none + +[input] +=head1 GUESSWORK + +The hyphens-in-compound-words shouldn't be escaped, but e-mail should be. + +Function: foo(), bar::baz(), _private::_stuff() + +Manpage: foo(1), Pod::Man(3perl), git-rebase(1) + +Variables: $foo, @bar::baz, %Pod::Blah + +[output] +.SH GUESSWORK +.IX Header "GUESSWORK" +The hyphens-in-compound-words shouldn't be escaped, but e\-mail should be. +.PP +Function: foo(), bar::baz(), _private::_stuff() +.PP +Manpage: foo(1), Pod::Man(3perl), git\-rebase(1) +.PP +Variables: $foo, @bar::baz, %Pod::Blah diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-partial b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-partial new file mode 100644 index 00000000000..b90e1b9da21 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-partial @@ -0,0 +1,27 @@ +[name] +Some guesswork configured + +[options] +guesswork functions,variables + +[input] +=head1 GUESSWORK + +The hyphens-in-compound-words shouldn't be escaped, but e-mail should be. + +Function: foo(), bar::baz(), _private::_stuff() + +Manpage: foo(1), Pod::Man(3perl), git-rebase(1) + +Variables: $foo, @bar::baz, %Pod::Blah + +[output] +.SH GUESSWORK +.IX Header "GUESSWORK" +The hyphens-in-compound-words shouldn't be escaped, but e\-mail should be. +.PP +Function: \fBfoo()\fR, \fBbar::baz()\fR, \fB_private::_stuff()\fR +.PP +Manpage: foo(1), Pod::Man(3perl), git\-rebase(1) +.PP +Variables: \f(CW$foo\fR, \f(CW@bar::baz\fR, \f(CW%Pod::Blah\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-quoting b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-quoting new file mode 100644 index 00000000000..dcd0a7bb44f --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/guesswork-quoting @@ -0,0 +1,54 @@ +[name] +Quoting guesswork applied by default + +[input] +=head1 QUOTING + +Suppress quotes: +C<"foo">, +C<'foo'>, +C<`foo`>, +C<`foo'>, +C<$^F>, +C<$">, +C<$#f>, +C<$foo[4]>, +C<$foo{bar}>, +C<%foo>, +C<@foo>, +C<&foo>, +C<*foo>, +C<< $foo->("bar") >>, +C<&foo::baz("bar")>, +C<&foo()>, +C, +C<-1000>, +C<132.123>, +C<5e-7>, +C<0xdeadbeef> + +[output] +.SH QUOTING +.IX Header "QUOTING" +Suppress quotes: +\&\f(CW"foo"\fR, +\&\f(CW\*(Aqfoo\*(Aq\fR, +\&\f(CW\`foo\`\fR, +\&\f(CW\`foo\*(Aq\fR, +\&\f(CW$^F\fR, +\&\f(CW$"\fR, +\&\f(CW$#f\fR, +\&\f(CW$foo[4]\fR, +\&\f(CW$foo{bar}\fR, +\&\f(CW%foo\fR, +\&\f(CW@foo\fR, +\&\f(CW&foo\fR, +\&\f(CW*foo\fR, +\&\f(CW$foo\->("bar")\fR, +\&\f(CW&foo::baz("bar")\fR, +\&\f(CW&foo()\fR, +\&\f(CWfoo( "bar" )\fR, +\&\f(CW\-1000\fR, +\&\f(CW132.123\fR, +\&\f(CW5e\-7\fR, +\&\f(CW0xdeadbeef\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/hyphen-in-s b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/hyphen-in-s index dbadd44a5f0..754ae167f1b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/hyphen-in-s +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/hyphen-in-s @@ -10,5 +10,5 @@ $-0.13 should have a real hyphen. [output] .SH "Hyphen in S<>" .IX Header "Hyphen in S<>" -Don't transform\ even-this\ hyphen. This \*(L"one's-fine!\*(R", as well. However, +Don't transform\ even-this\ hyphen. This "one's-fine!", as well. However, $\-0.13 should have a real hyphen. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1 b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1 index 6486e7741ec..4454d09ca6c 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1 +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1 @@ -1,6 +1,9 @@ [name] ISO-8859-1 encoding +[options] +encoding iso-8859-1 + [input] =encoding iso-8859-1 @@ -15,14 +18,14 @@ Beyonc Older versions didn't convert Beyoncé in verbatim. [output] -.SH "ACCENTS" +.SH ACCENTS .IX Header "ACCENTS" -Beyonce\*'! Beyonce\*'! Beyonce\*'!! +Beyoncé! Beyoncé! Beyoncé!! .PP .Vb 3 -\& Beyonce\*'! Beyonce\*'! -\& Beyonce\*'! Beyonce\*'! -\& Beyonce\*'! Beyonce\*'! +\& Beyoncé! Beyoncé! +\& Beyoncé! Beyoncé! +\& Beyoncé! Beyoncé! .Ve .PP -Older versions didn't convert Beyonce\*' in verbatim. +Older versions didn't convert Beyoncé in verbatim. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-error-die b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-error-die new file mode 100644 index 00000000000..e7761d3d7e5 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-error-die @@ -0,0 +1,30 @@ +[name] +ISO-8859-1 encoding with invalid character (die) + +[options] +errors die +encoding iso-8859-1 + +[input] +=encoding UTF-8 + +=head1 INVALID + +This character cannot be represented in ISO-8859-1, so should produce an +error. + +☺ + +[output] +.SH INVALID +.IX Header "INVALID" +This character cannot be represented in ISO\-8859\-1, so should produce an +error. +.PP +? + +[errors] +Pod input around line 8: "\x{38790}" does not map to iso-8859-1 + +[exception] +POD document had syntax errors diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-error-pod b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-error-pod new file mode 100644 index 00000000000..304e0c8545d --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-error-pod @@ -0,0 +1,29 @@ +[name] +ISO-8859-1 encoding with invalid character + +[options] +encoding iso-8859-1 + +[input] +=encoding UTF-8 + +=head1 INVALID + +This character cannot be represented in ISO-8859-1, so should produce an +error. + +☺ + +[output] +.SH INVALID +.IX Header "INVALID" +This character cannot be represented in ISO\-8859\-1, so should produce an +error. +.PP +? +.SH "POD ERRORS" +.IX Header "POD ERRORS" +Hey! \fBThe above document had some coding errors, which are explained below:\fR +.IP "Around line 8:" 4 +.IX Item "Around line 8:" +"\ex{38790}" does not map to iso\-8859\-1 diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-roff b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-roff new file mode 100644 index 00000000000..c0294811382 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/iso-8859-1-roff @@ -0,0 +1,31 @@ +[name] +ISO-8859-1 encoding with *roff output + +[options] +encoding roff + +[input] +=encoding iso-8859-1 + +=head1 ACCENTS + +Beyoncé! Beyoncé! Beyoncé!! + + Beyoncé! Beyoncé! + Beyoncé! Beyoncé! + Beyoncé! Beyoncé! + +Older versions didn't convert Beyoncé in verbatim. + +[output] +.SH ACCENTS +.IX Header "ACCENTS" +Beyonce\*'! Beyonce\*'! Beyonce\*'!! +.PP +.Vb 3 +\& Beyonce\*'! Beyonce\*'! +\& Beyonce\*'! Beyonce\*'! +\& Beyonce\*'! Beyonce\*'! +.Ve +.PP +Older versions didn't convert Beyonce\*' in verbatim. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/language b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/language new file mode 100644 index 00000000000..03342a9b4e3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/language @@ -0,0 +1,19 @@ +[name] +Hyphenation language + +[options] +language ja + +[input] +=encoding utf-8 + +=head1 JAPANESE + +Perl 自身は Unicode で動作します。Perl スクリプト内の文字列リテラルや正規表現は Unicode を前提としています。そして入出力のためには、これまで使われてきたさまざまな文字コードに対応するモジュール、「 Encode 」が標準装備されており、Unicode とこれらの文字コードの相互変換も簡単に行えるようになっています。 + +[output] +.mso ja.tmac +.hla ja +.SH JAPANESE +.IX Header "JAPANESE" +Perl 自身は Unicode で動作します。Perl スクリプト内の文字列リテラルや正規表現は Unicode を前提としています。そして入出力のためには、これまで使われてきたさまざまな文字コードに対応するモジュール、「 Encode 」が標準装備されており、Unicode とこれらの文字コードの相互変換も簡単に行えるようになっています。 diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/link-to-url b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/link-to-url index 7f81e3c7f82..e8b08a1247f 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/link-to-url +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/link-to-url @@ -16,7 +16,7 @@ L<[perl #12345]|https://rt.cpan.org/12345> [output] .SH "LINK TO URL" .IX Header "LINK TO URL" -This is a link to a \s-1URL.\s0 +This is a link to a URL. .PP The newest version of this document is also available on the World Wide Web at . diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/long-quote b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/long-quote index 589dcb99eaf..e324ee5d5ea 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/long-quote +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/long-quote @@ -2,7 +2,7 @@ Long quotes option [options] -quotes \(lq"\(rq" +quotes "\(lq\(rq" [input] =head1 FOO C BAZ @@ -10,7 +10,7 @@ quotes \(lq"\(rq" Foo C baz. [output] -.ie n .SH "FOO \(lq""BAR\(rq"" BAZ" +.ie n .SH "FOO ""\(lqBAR\(rq"" BAZ" .el .SH "FOO \f(CWBAR\fP BAZ" .IX Header "FOO BAR BAZ" Foo \f(CW\*(C`bar\*(C'\fR baz. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/markup-in-name b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/markup-in-name index de27acddf17..2408c437a4b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/markup-in-name +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/markup-in-name @@ -7,5 +7,5 @@ Various markup in NAME test - B I F [output] -.SH "NAME" +.SH NAME test \- test italics file diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/naive b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/naive new file mode 100644 index 00000000000..e36b8b4fdef --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/naive @@ -0,0 +1,14 @@ +[name] +Handling of E<> Unicode escape + +[input] +=head1 perlfaq4 SNIPPET + +The trick to this problem is avoiding accidental autovivification. If +you want to check three keys deep, you might naE<0xEF>vely try this: + +[output] +.SH "perlfaq4 SNIPPET" +.IX Header "perlfaq4 SNIPPET" +The trick to this problem is avoiding accidental autovivification. If +you want to check three keys deep, you might naïvely try this: diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/naive-groff b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/naive-groff new file mode 100644 index 00000000000..d169412981e --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/naive-groff @@ -0,0 +1,17 @@ +[name] +Handling of E<> Unicode escape + +[options] +encoding groff + +[input] +=head1 perlfaq4 SNIPPET + +The trick to this problem is avoiding accidental autovivification. If +you want to check three keys deep, you might naE<0xEF>vely try this: + +[output] +.SH "perlfaq4 SNIPPET" +.IX Header "perlfaq4 SNIPPET" +The trick to this problem is avoiding accidental autovivification. If +you want to check three keys deep, you might na\[u00EF]vely try this: diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-guesswork b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-guesswork index 6eecd9a36ef..547545d573b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-guesswork +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-guesswork @@ -4,15 +4,15 @@ No guesswork in NAME [input] =head1 NAME -"Stuff" (no guesswork) +function() - man(1) $variable =head2 THINGS -Oboy, is this C++ "fun" yet! (guesswork) +function() - man(1) $variable [output] -.SH "NAME" -"Stuff" (no guesswork) -.SS "\s-1THINGS\s0" +.SH NAME +function() \- man(1) $variable +.SS THINGS .IX Subsection "THINGS" -Oboy, is this \*(C+ \*(L"fun\*(R" yet! (guesswork) +\&\fBfunction()\fR \- \fBman\fR\|(1) \f(CW$variable\fR diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-quotes b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-quotes new file mode 100644 index 00000000000..7bdc06d59b1 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-quotes @@ -0,0 +1,15 @@ +[name] +Honor quote settings in NAME + +[options] +lquote ' +rquote ' + +[input] +=head1 NAME + +C - config file for I + +[output] +.SH NAME +\&'/etc/blah' \- config file for blah(1) diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-quotes-none b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-quotes-none new file mode 100644 index 00000000000..87e184aee70 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/name-quotes-none @@ -0,0 +1,14 @@ +[name] +Honor quote settings in NAME + +[options] +quotes none + +[input] +=head1 NAME + +C - config file for I + +[output] +.SH NAME +/etc/blah \- config file for blah(1) diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nested-lists b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nested-lists index 45d4a58095a..769dc95e8ff 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nested-lists +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nested-lists @@ -23,7 +23,7 @@ Should be a bullet. .IX Item "First level" Blah blah blah.... .RS 4 -.IP "\(bu" 4 +.IP \(bu 4 Should be a bullet. .RE .RS 4 diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/non-ascii b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/non-ascii index 739690f9acc..9e9fdccaf64 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/non-ascii +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/non-ascii @@ -1,12 +1,15 @@ [name] Non-ASCII character +[options] +encoding roff + [input] =head1 YEN It cost me E<165>12345! That should be an X. [output] -.SH "YEN" +.SH YEN .IX Header "YEN" It cost me X12345! That should be an X. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nonbreaking-space-l b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nonbreaking-space-l new file mode 100644 index 00000000000..2f48619c0e7 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/nonbreaking-space-l @@ -0,0 +1,28 @@ +[name] +S<> wrapping L<> + +[input] +=head1 URLS + +SZ<><> wrapping LZ<><> should make the space between the anchor and URL +non-breaking and thus keep them together. + +L L L L +S> +S> +S> +S> +S> + +[output] +.SH URLS +.IX Header "URLS" +S<> wrapping L<> should make the space between the anchor and URL +non-breaking and thus keep them together. +.PP +perl Net::DNS Net::DNS::RR Net::DNS::SEC +RFC2535\ +RFC2536\ +RFC2931\ +RFC3110\ +RFC4034\ diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/not-bullet b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/not-bullet index 8b468f0f02b..dfa2ea742d0 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/not-bullet +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/not-bullet @@ -11,5 +11,5 @@ Not bullet. =back [output] -.IP "*" 4 +.IP * 4 Not bullet. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/periods b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/periods index afdea425d2c..bc841db41ad 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/periods +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/periods @@ -7,6 +7,6 @@ Quoted periods This C<.> should be quoted. [output] -.SH "PERIODS" +.SH PERIODS .IX Header "PERIODS" This \f(CW\*(C`.\*(C'\fR should be quoted. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/true-false b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/true-false index 6f0e4e0f3cf..6671cca1de0 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/true-false +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/true-false @@ -11,6 +11,6 @@ code and got it wrong. [output] .SH "TRUE (1)" .IX Header "TRUE (1)" -podlators prior to 4.08 misrendered \s-1TRUE\s0 (1) and \s-1FALSE\s0 (0) with escaped nroff +podlators prior to 4.08 misrendered TRUE (1) and FALSE (0) with escaped nroff in the output because it tried to apply both small caps and man page reference code and got it wrong. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-nonbreaking b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-nonbreaking index 8198a77ece0..378397ddc0b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-nonbreaking +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-nonbreaking @@ -2,7 +2,7 @@ UTF-8 non-breaking space [options] -utf8 1 +encoding utf-8 [input] =encoding utf-8 @@ -14,4 +14,4 @@ This is S. [output] .SH "S<> output with UTF\-8" .IX Header "S<> output with UTF-8" -This is non-breaking output. +This is non-breaking\ output. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-verbatim b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-verbatim index 0eea4ccb53f..50447c48327 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-verbatim +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/utf8-verbatim @@ -18,7 +18,7 @@ Beyoncé! Beyoncé! Beyoncé!! Older versions did not convert Beyoncé in verbatim. [output] -.SH "BEYONCÉ" +.SH BEYONCÉ .IX Header "BEYONCÉ" Beyoncé! Beyoncé! Beyoncé!! .PP diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/x-whitespace-entry b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/x-whitespace-entry index 8ec01ace0bd..52732ee3526 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/x-whitespace-entry +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/x-whitespace-entry @@ -7,7 +7,7 @@ X<> matching whitespace Index entry matching a whitespace escape.X<\n> [output] -.SH "INDEX" +.SH INDEX .IX Header "INDEX" Index entry matching a whitespace escape. .IX Xref "\\n" diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/zero-width-space b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/zero-width-space new file mode 100644 index 00000000000..3911f9c4e26 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/man/zero-width-space @@ -0,0 +1,10 @@ +[name] +Zero-width spaces + +[input] +=pod + +BIvnameE>=IrrdfileE>:Ids-nameE>:ICFE>[:step=IstepE>][:start=ItimeE>]E<0x200B>[:end=ItimeE>]E<0x200B>[:reduce=IBE>]E<0x200B>[:daemon=IaddressE>] + +[output] +\&\fBDEF:\fR\fI\fR=\fI\fR:\fI\fR:\fI\fR[:step=\fI\fR][:start=\fI