diff options
Diffstat (limited to 'gnu/usr.bin/perl/cpan')
197 files changed, 7478 insertions, 1379 deletions
diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/t/02_methods.t b/gnu/usr.bin/perl/cpan/Archive-Tar/t/02_methods.t index b7405942033..4006d4eb314 100755 --- a/gnu/usr.bin/perl/cpan/Archive-Tar/t/02_methods.t +++ b/gnu/usr.bin/perl/cpan/Archive-Tar/t/02_methods.t @@ -99,9 +99,11 @@ my $TARX = $Class->new; my $TAR_FILE = File::Spec->catfile( @ROOT, 'bar.tar' ); my $TGZ_FILE = File::Spec->catfile( @ROOT, 'foo.tgz' ); my $TBZ_FILE = File::Spec->catfile( @ROOT, 'foo.tbz' ); +my $TXZ_FILE = File::Spec->catfile( @ROOT, 'foo.txz' ); my $OUT_TAR_FILE = File::Spec->catfile( @ROOT, 'out.tar' ); my $OUT_TGZ_FILE = File::Spec->catfile( @ROOT, 'out.tgz' ); my $OUT_TBZ_FILE = File::Spec->catfile( @ROOT, 'out.tbz' ); +my $OUT_TXZ_FILE = File::Spec->catfile( @ROOT, 'out.txz' ); my $COMPRESS_FILE = 'copy'; $^O eq 'VMS' and $COMPRESS_FILE .= '.'; @@ -110,8 +112,8 @@ chmod 0644, $COMPRESS_FILE; ### done setting up environment ### -### check for zlib/bzip2 support -{ for my $meth ( qw[has_zlib_support has_bzip2_support] ) { +### check for zlib/bzip2/xz support +{ for my $meth ( qw[has_zlib_support has_bzip2_support has_xz_support] ) { can_ok( $Class, $meth ); } } @@ -167,6 +169,7 @@ chmod 0644, $COMPRESS_FILE; { my @to_try = ($TAR_FILE); push @to_try, $TGZ_FILE if $Class->has_zlib_support; push @to_try, $TBZ_FILE if $Class->has_bzip2_support; + push @to_try, $TXZ_FILE if $Class->has_xz_support; for my $type( @to_try ) { @@ -462,6 +465,7 @@ SKIP: { ### pesky warnings { my @out; push @out, [ $OUT_TGZ_FILE => 1 ] if $Class->has_zlib_support; push @out, [ $OUT_TBZ_FILE => COMPRESS_BZIP ] if $Class->has_bzip2_support; + push @out, [ $OUT_TXZ_FILE => COMPRESS_XZ ] if $Class->has_xz_support; for my $entry ( @out ) { @@ -786,8 +790,14 @@ sub slurp_compressed_file { my $file = shift; my $fh; + ### xz + if( $file =~ /.txz$/ ) { + require IO::Uncompress::UnXz; + $fh = IO::Uncompress::UnXz->new( $file ) + or warn( "Error opening '$file' with IO::Uncompress::UnXz" ), return + ### bzip2 - if( $file =~ /.tbz$/ ) { + } elsif( $file =~ /.tbz$/ ) { require IO::Uncompress::Bunzip2; $fh = IO::Uncompress::Bunzip2->new( $file ) or warn( "Error opening '$file' with IO::Uncompress::Bunzip2" ), return diff --git a/gnu/usr.bin/perl/cpan/Archive-Tar/t/09_roundtrip.t b/gnu/usr.bin/perl/cpan/Archive-Tar/t/09_roundtrip.t index 8fb72a80233..3e612ef9c8a 100644 --- a/gnu/usr.bin/perl/cpan/Archive-Tar/t/09_roundtrip.t +++ b/gnu/usr.bin/perl/cpan/Archive-Tar/t/09_roundtrip.t @@ -43,6 +43,8 @@ push @file_only_archives, [qw( src short foo.tgz )] if Archive::Tar->has_zlib_support; push @file_only_archives, [qw( src short foo.tbz )] if Archive::Tar->has_bzip2_support; +push @file_only_archives, [qw( src short foo.txz )] + if Archive::Tar->has_xz_support; @file_only_archives = map File::Spec->catfile(@$_), @file_only_archives; @@ -74,6 +76,7 @@ for my $archive_name (@file_only_archives) { my @compress = $ext =~ /t?gz$/ ? (COMPRESS_GZIP) : $ext =~ /(tbz|bz2?)$/ ? (COMPRESS_BZIP) + : $ext =~ /(t?xz)$/ ? (COMPRESS_XZ) : (); my ( $fh, $filename ) = tempfile( UNLINK => 1 ); diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/Makefile.PL b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/Makefile.PL index 246259d3350..d6034541015 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Bzip2/Makefile.PL @@ -50,11 +50,33 @@ WriteMakefile( INSTALLDIRS => ($] > 5.010 && $] < 5.011 ? 'perl' : 'site'), - META_MERGE => { - no_index => { - directory => [ 't', 'private' ], - }, - }, + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ? ( META_MERGE => { + + "meta-spec" => { version => 2 }, + + no_index => { + directory => [ 't', 'private' ], + }, + + resources => { + + bugtracker => { + web => 'https://github.com/pmqs/Compress-Raw-Bzip2/issues' + }, + + homepage => 'https://github.com/pmqs/Compress-Raw-Bzip2', + + repository => { + type => 'git', + url => 'git://github.com/pmqs/Compress-Raw-Bzip2.git', + web => 'https://github.com/pmqs/Compress-Raw-Bzip2', + }, + }, + } + ) + : () + ), ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : ()), diff --git a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/Makefile.PL b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/Makefile.PL index 31f3197be8d..67c28d606f7 100644 --- a/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Compress-Raw-Zlib/Makefile.PL @@ -94,11 +94,33 @@ WriteMakefile( INSTALLDIRS => ($] >= 5.009 && $] < 5.011 ? 'perl' : 'site'), - META_MERGE => { - no_index => { - directory => [ 't', 'private' ], - }, - }, + ( eval { ExtUtils::MakeMaker->VERSION(6.46) } + ? ( META_MERGE => { + + "meta-spec" => { version => 2 }, + + no_index => { + directory => [ 't', 'private' ], + }, + + resources => { + + bugtracker => { + web => 'https://github.com/pmqs/Compress-Raw-Zlib/issues' + }, + + homepage => 'https://github.com/pmqs/Compress-Raw-Zlib', + + repository => { + type => 'git', + url => 'git://github.com/pmqs/Compress-Raw-Zlib.git', + web => 'https://github.com/pmqs/Compress-Raw-Zlib', + }, + }, + } + ) + : () + ), ((ExtUtils::MakeMaker->VERSION() gt '6.30') ? ('LICENSE' => 'perl') : ()), diff --git a/gnu/usr.bin/perl/cpan/DB_File/config.in b/gnu/usr.bin/perl/cpan/DB_File/config.in index 292b09a5fb3..d79a9505e9f 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/config.in +++ b/gnu/usr.bin/perl/cpan/DB_File/config.in @@ -1,6 +1,6 @@ # Filename: config.in # -# written by Paul Marquess <Paul.Marquess@btinternet.com> +# written by Paul Marquess <pmqs@cpan.org> # last modified 9th Sept 1997 # version 1.55 diff --git a/gnu/usr.bin/perl/cpan/DB_File/dbinfo b/gnu/usr.bin/perl/cpan/DB_File/dbinfo index e8abc974b3b..c2842f6cfa8 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/dbinfo +++ b/gnu/usr.bin/perl/cpan/DB_File/dbinfo @@ -1,13 +1,13 @@ -#!/usr/local/bin/perl +#!/usr/bin/perl -# Name: dbinfo -- identify berkeley DB version used to create -# a database file +# Name: dbinfo -- identify berkeley DB version used to create +# a database file # -# Author: Paul Marquess <Paul.Marquess@btinternet.com> -# Version: 1.06 -# Date 27th March 2008 +# Author: Paul Marquess <pmqs@cpan.org> +# Version: 1.07 +# Date 2nd April 2011 # -# Copyright (c) 1998-2012 Paul Marquess. All rights reserved. +# Copyright (c) 1998-2020 Paul Marquess. All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. @@ -17,51 +17,59 @@ use strict ; my %Data = - ( - 0x053162 => # DB_BTREEMAGIC + ( + 0x053162 => # DB_BTREEMAGIC { - Type => "Btree", - Versions => # DB_BTREEVERSION - { - 1 => [0, "Unknown (older than 1.71)"], - 2 => [0, "Unknown (older than 1.71)"], - 3 => [0, "1.71 -> 1.85, 1.86"], - 4 => [0, "Unknown"], - 5 => [0, "2.0.0 -> 2.3.0"], - 6 => [0, "2.3.1 -> 2.7.7"], - 7 => [0, "3.0.x"], - 8 => [0, "3.1.x -> 4.0.x"], - 9 => [1, "4.1.x or greater"], - } - }, - 0x061561 => # DB_HASHMAGIC + Type => "Btree", + Versions => # DB_BTREEVERSION + { + 1 => [0, "Unknown (older than 1.71)"], + 2 => [0, "Unknown (older than 1.71)"], + 3 => [0, "1.71 -> 1.85, 1.86"], + 4 => [0, "Unknown"], + 5 => [0, "2.0.0 -> 2.3.0"], + 6 => [0, "2.3.1 -> 2.7.7"], + 7 => [0, "3.0.x"], + 8 => [0, "3.1.x -> 4.0.x"], + 9 => [1, "4.1.x or greater"], + } + }, + 0x061561 => # DB_HASHMAGIC { - Type => "Hash", - Versions => # DB_HASHVERSION - { - 1 => [0, "Unknown (older than 1.71)"], - 2 => [0, "1.71 -> 1.85"], - 3 => [0, "1.86"], - 4 => [0, "2.0.0 -> 2.1.0"], - 5 => [0, "2.2.6 -> 2.7.7"], - 6 => [0, "3.0.x"], - 7 => [0, "3.1.x -> 4.0.x"], - 8 => [1, "4.1.x or greater"], - 9 => [1, "4.6.x or greater"], - } - }, - 0x042253 => # DB_QAMMAGIC + Type => "Hash", + Versions => # DB_HASHVERSION + { + 1 => [0, "Unknown (older than 1.71)"], + 2 => [0, "1.71 -> 1.85"], + 3 => [0, "1.86"], + 4 => [0, "2.0.0 -> 2.1.0"], + 5 => [0, "2.2.6 -> 2.7.7"], + 6 => [0, "3.0.x"], + 7 => [0, "3.1.x -> 4.0.x"], + 8 => [1, "4.1.x or greater"], + 9 => [1, "4.6.x or greater"], + } + }, + 0x042253 => # DB_QAMMAGIC { - Type => "Queue", - Versions => # DB_QAMVERSION - { - 1 => [0, "3.0.x"], - 2 => [0, "3.1.x"], - 3 => [0, "3.2.x -> 4.0.x"], - 4 => [1, "4.1.x or greater"], - } - }, - ) ; + Type => "Queue", + Versions => # DB_QAMVERSION + { + 1 => [0, "3.0.x"], + 2 => [0, "3.1.x"], + 3 => [0, "3.2.x -> 4.0.x"], + 4 => [1, "4.1.x or greater"], + } + }, + 0x074582 => # DB_HEAPMAGIC + { + Type => "Heap", + Versions => # DB_HEAPVERSION + { + 1 => [1, "5.2.x"], + } + }, + ) ; die "Usage: dbinfo file\n" unless @ARGV == 1 ; @@ -120,11 +128,11 @@ if ( defined $type->{Versions}{$version} ) } print <<EOM ; -File Type: Berkeley DB $type->{Type} file. -File Version ID: $version -Built with Berkeley DB: $ver_string -Byte Order: $endian -Magic: $magic +File Type: Berkeley DB $type->{Type} file. +File Version ID: $version +Built with Berkeley DB: $ver_string +Byte Order: $endian +Magic: $magic Encryption: $encrypt EOM diff --git a/gnu/usr.bin/perl/cpan/DB_File/t/db-btree.t b/gnu/usr.bin/perl/cpan/DB_File/t/db-btree.t index 4ff405e51d0..86cfb0c627d 100755 --- a/gnu/usr.bin/perl/cpan/DB_File/t/db-btree.t +++ b/gnu/usr.bin/perl/cpan/DB_File/t/db-btree.t @@ -16,11 +16,11 @@ BEGIN { BEGIN { if ($^O eq 'darwin' - && (split(/\./, $Config{osvers}))[0] < 7 # Mac OS X 10.3 == Darwin 7 - && $Config{db_version_major} == 1 - && $Config{db_version_minor} == 0 - && $Config{db_version_patch} == 0) { - warn <<EOM; + && (split(/\./, $Config{osvers}))[0] < 7 # Mac OS X 10.3 == Darwin 7 + && $Config{db_version_major} == 1 + && $Config{db_version_minor} == 0 + && $Config{db_version_patch} == 0) { + warn <<EOM; # # This test is known to crash in Mac OS X versions 10.2 (or earlier) # because of the buggy Berkeley DB version included with the OS. @@ -69,17 +69,17 @@ sub lexical { my $class = shift ; my $filename = shift ; - my $fh = gensym ; - open ($fh, ">$filename") || die "Cannot open $filename: $!" ; - my $real_stdout = select($fh) ; - return bless [$fh, $real_stdout ] ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; } sub DESTROY { my $self = shift ; - close $self->[0] ; - select($self->[1]) ; + close $self->[0] ; + select($self->[1]) ; } } @@ -124,7 +124,7 @@ sub safeUntie my $db185mode = ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ; my $null_keys_allowed = ($DB_File::db_ver < 2.004010 - || $DB_File::db_ver >= 3.1 ); + || $DB_File::db_ver >= 3.1 ); my $TEMPDIR = tempdir( CLEANUP => 1 ); chdir $TEMPDIR; @@ -263,8 +263,8 @@ ok(25, $#keys == 29 && $#values == 29) ; $i = 0 ; while (($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; } } @@ -412,7 +412,7 @@ ok(61, $key eq 'replace key' ); ok(62, $value eq 'replace value' ); $status = $X->get('y', $value) ; ok(63, 1) ; # hard-wire to always pass. the previous test ($status == 1) - # only worked because of a bug in 1.85/6 + # only worked because of a bug in 1.85/6 # use seq to walk forwards through a file @@ -520,7 +520,7 @@ ok(82, keys %smith == 1 && $smith{'John'}) ; my %wall = $YY->get_dup('Wall', 1) ; ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 - && $wall{'Brick'} == 2); + && $wall{'Brick'} == 2); undef $YY ; untie %hh ; @@ -534,8 +534,8 @@ my $Dfile3 = "btree3" ; my $dbh1 = new DB_File::BTREEINFO ; $dbh1->{compare} = sub { - no warnings 'numeric' ; - $_[0] <=> $_[1] } ; + no warnings 'numeric' ; + $_[0] <=> $_[1] } ; my $dbh2 = new DB_File::BTREEINFO ; $dbh2->{compare} = sub { $_[0] cmp $_[1] } ; @@ -647,37 +647,37 @@ unlink $Dfile1 ; @EXPORT = @DB_File::EXPORT ; sub STORE { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::STORE($key, $value * 2) ; } sub FETCH { - my $self = shift ; + my $self = shift ; my $key = shift ; $self->SUPER::FETCH($key) - 1 ; } sub put { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::put($key, $value * 3) ; } sub get { - my $self = shift ; + my $self = shift ; $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; + $_[1] -= 2 ; } sub A_new_method { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = $self->FETCH($key) ; - return "[[$value]]" ; + return "[[$value]]" ; } 1 ; @@ -691,8 +691,8 @@ EOM my %h ; my $X ; eval ' - $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); - ' ; + $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE ); + ' ; main::ok(92, $@ eq "") ; @@ -732,8 +732,8 @@ EOM my($fk, $sk, $fv, $sv) = @_ ; return $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; } ok(101, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) ); @@ -761,13 +761,13 @@ EOM # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; + (sub { $_ = lc $_ ; $store_key = $_ }) ; my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; + (sub { s/o/x/g; $store_value = $_ }) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"Fred"} = "Joe" ; @@ -840,13 +840,13 @@ EOM sub Closure { my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; + my $count = 0 ; + my @kept = () ; - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } } $db->filter_store_key(Closure("store key")) ; @@ -887,7 +887,7 @@ EOM undef $db ; untie %h; unlink $Dfile; -} +} { # DBM Filter recursion detection @@ -986,7 +986,7 @@ EOM $DB_BTREE->{'flags'} = R_DUP ; tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; # Add some key/value pairs to the file $h{'Wall'} = 'Larry' ; @@ -998,7 +998,7 @@ EOM # iterate through the associative array # and print each key/value pair. foreach (keys %h) - { print "$_ -> $h{$_}\n" } + { print "$_ -> $h{$_}\n" } untie %h ; @@ -1006,17 +1006,17 @@ EOM } ok(148, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Brick -mouse -> mickey +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Brick +mouse -> mickey EOM -Smith -> John -Wall -> Larry -Wall -> Larry -Wall -> Larry -mouse -> mickey +Smith -> John +Wall -> Larry +Wall -> Larry +Wall -> Larry +mouse -> mickey EOM { @@ -1038,7 +1038,7 @@ EOM $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; # Add some key/value pairs to the file $h{'Wall'} = 'Larry' ; @@ -1053,7 +1053,7 @@ EOM for ($status = $x->seq($key, $value, R_FIRST) ; $status == 0 ; $status = $x->seq($key, $value, R_NEXT) ) - { print "$key -> $value\n" } + { print "$key -> $value\n" } undef $x ; @@ -1061,17 +1061,17 @@ EOM } ok(149, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ; -Smith -> John -Wall -> Brick -Wall -> Brick -Wall -> Larry -mouse -> mickey +Smith -> John +Wall -> Brick +Wall -> Brick +Wall -> Larry +mouse -> mickey EOM -Smith -> John -Wall -> Larry -Wall -> Brick -Wall -> Brick -mouse -> mickey +Smith -> John +Wall -> Larry +Wall -> Brick +Wall -> Brick +mouse -> mickey EOM @@ -1093,7 +1093,7 @@ EOM $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; my $cnt = $x->get_dup("Wall") ; print "Wall occurred $cnt times\n" ; @@ -1103,13 +1103,13 @@ EOM print "There are $hash{'Brick'} Brick Walls\n" ; my @list = sort $x->get_dup("Wall") ; - print "Wall => [@list]\n" ; + print "Wall => [@list]\n" ; @list = $x->get_dup("Smith") ; - print "Smith => [@list]\n" ; + print "Smith => [@list]\n" ; @list = $x->get_dup("Dog") ; - print "Dog => [@list]\n" ; + print "Dog => [@list]\n" ; undef $x ; untie %h ; @@ -1119,9 +1119,9 @@ EOM Wall occurred 3 times Larry is there There are 2 Brick Walls -Wall => [Brick Brick Larry] -Smith => [John] -Dog => [] +Wall => [Brick Brick Larry] +Smith => [John] +Dog => [] EOM { @@ -1142,7 +1142,7 @@ EOM $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; print "Larry Wall is $found there\n" ; @@ -1177,7 +1177,7 @@ EOM $DB_BTREE->{'flags'} = R_DUP ; $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE - or die "Cannot open $filename: $!\n"; + or die "Cannot open $filename: $!\n"; $x->del_dup("Wall", "Larry") ; @@ -1213,7 +1213,7 @@ EOM my $value = 0; my $orig_key = $key ; $x->seq($key, $value, R_CURSOR) ; - print "$orig_key\t-> $key\t-> $value\n" ; + print "$orig_key -> $key -> $value\n" ; } $filename = "tree" ; @@ -1232,10 +1232,10 @@ EOM $key = $value = 0 ; print "IN ORDER\n" ; for ($st = $x->seq($key, $value, R_FIRST) ; - $st == 0 ; + $st == 0 ; $st = $x->seq($key, $value, R_NEXT) ) - - { print "$key -> $value\n" } + + { print "$key -> $value\n" } print "\nPARTIAL MATCH\n" ; @@ -1252,15 +1252,15 @@ EOM ok(153, docat_del($file) eq <<'EOM') ; IN ORDER -Smith -> John -Wall -> Larry -Walls -> Brick -mouse -> mickey +Smith -> John +Wall -> Larry +Walls -> Brick +mouse -> mickey PARTIAL MATCH -Wa -> Wall -> Larry -A -> Smith -> John -a -> mouse -> mickey +Wa -> Wall -> Larry +A -> Smith -> John +a -> mouse -> mickey EOM } @@ -1280,7 +1280,7 @@ EOM local $SIG{__WARN__} = sub {$a = $_[0]} ; tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; + or die "Can't open file: $!\n" ; $h{ABC} = undef; ok(154, $a eq "") ; untie %h ; @@ -1300,7 +1300,7 @@ EOM local $SIG{__WARN__} = sub {$a = $_[0]} ; tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE - or die "Can't open file: $!\n" ; + or die "Can't open file: $!\n" ; %h = (); ; ok(155, $a eq "") ; untie %h ; @@ -1373,9 +1373,9 @@ EOM # my (%h); # ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); # -# eval { $hash{1} = 2; -# $hash{4} = 5; -# }; +# eval { $hash{1} = 2; +# $hash{4} = 5; +# }; # # ok(165, $@ =~ /^DB_File btree_compare: recursion detected/); # { diff --git a/gnu/usr.bin/perl/cpan/DB_File/t/db-hash.t b/gnu/usr.bin/perl/cpan/DB_File/t/db-hash.t index 97b77fcfd7d..79ffe93a892 100755 --- a/gnu/usr.bin/perl/cpan/DB_File/t/db-hash.t +++ b/gnu/usr.bin/perl/cpan/DB_File/t/db-hash.t @@ -40,17 +40,17 @@ sub ok { my $class = shift ; my $filename = shift ; - my $fh = gensym ; - open ($fh, ">$filename") || die "Cannot open $filename: $!" ; - my $real_stdout = select($fh) ; - return bless [$fh, $real_stdout ] ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; } sub DESTROY { my $self = shift ; - close $self->[0] ; - select($self->[1]) ; + close $self->[0] ; + select($self->[1]) ; } } @@ -89,7 +89,7 @@ chdir $TEMPDIR; my $Dfile = "dbhash.tmp"; my $Dfile2 = "dbhash2.tmp"; my $null_keys_allowed = ($DB_File::db_ver < 2.004010 - || $DB_File::db_ver >= 3.1 ); + || $DB_File::db_ver >= 3.1 ); unlink $Dfile; @@ -225,8 +225,8 @@ ok(23, $#keys == 29 && $#values == 29) ; $i = 0 ; while (($key,$value) = each(%h)) { if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) { - $key =~ y/a-z/A-Z/; - $i++ if $key eq $value; + $key =~ y/a-z/A-Z/; + $i++ if $key eq $value; } } @@ -427,37 +427,37 @@ untie %h ; @EXPORT = @DB_File::EXPORT ; sub STORE { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::STORE($key, $value * 2) ; } sub FETCH { - my $self = shift ; + my $self = shift ; my $key = shift ; $self->SUPER::FETCH($key) - 1 ; } sub put { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::put($key, $value * 3) ; } sub get { - my $self = shift ; + my $self = shift ; $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; + $_[1] -= 2 ; } sub A_new_method { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = $self->FETCH($key) ; - return "[[$value]]" ; + return "[[$value]]" ; } 1 ; @@ -471,8 +471,8 @@ EOM my %h ; my $X ; eval ' - $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); - ' ; + $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH ); + ' ; main::ok(54, $@ eq "") ; @@ -525,8 +525,8 @@ EOM return $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; } ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) ); @@ -558,13 +558,13 @@ EOM # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key - (sub { $_ = uc $_ ; $fetch_key = $_ }) ; + (sub { $_ = uc $_ ; $fetch_key = $_ }) ; my ($old_sk) = $db->filter_store_key - (sub { $_ = lc $_ ; $store_key = $_ }) ; + (sub { $_ = lc $_ ; $store_key = $_ }) ; my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; + (sub { s/o/x/g; $store_value = $_ }) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h{"Fred"} = "Joe" ; @@ -649,13 +649,13 @@ EOM sub Closure { my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; + my $count = 0 ; + my @kept = () ; - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } } $db->filter_store_key(Closure("store key")) ; @@ -696,7 +696,7 @@ EOM undef $db ; untie %h; unlink $Dfile; -} +} { # DBM Filter recursion detection @@ -868,9 +868,9 @@ EOM # # ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ); # -# eval { $hash{1} = 2; -# $hash{4} = 5; -# }; +# eval { $hash{1} = 2; +# $hash{4} = 5; +# }; # # ok(128, $@ =~ /^DB_File hash callback: recursion detected/); # { diff --git a/gnu/usr.bin/perl/cpan/DB_File/t/db-recno.t b/gnu/usr.bin/perl/cpan/DB_File/t/db-recno.t index 18b7e9e287d..08a89fff229 100755 --- a/gnu/usr.bin/perl/cpan/DB_File/t/db-recno.t +++ b/gnu/usr.bin/perl/cpan/DB_File/t/db-recno.t @@ -50,17 +50,17 @@ sub ok { my $class = shift ; my $filename = shift ; - my $fh = gensym ; - open ($fh, ">$filename") || die "Cannot open $filename: $!" ; - my $real_stdout = select($fh) ; - return bless [$fh, $real_stdout ] ; + my $fh = gensym ; + open ($fh, ">$filename") || die "Cannot open $filename: $!" ; + my $real_stdout = select($fh) ; + return bless [$fh, $real_stdout ] ; } sub DESTROY { my $self = shift ; - close $self->[0] ; - select($self->[1]) ; + close $self->[0] ; + select($self->[1]) ; } } @@ -95,23 +95,23 @@ sub safeUntie sub bad_one { unless ($bad_ones++) { - print STDERR <<EOM ; + print STDERR <<EOM ; # # Some older versions of Berkeley DB version 1 will fail db-recno # tests 61, 63, 64 and 65. EOM if ($^O eq 'darwin' - && $Config{db_version_major} == 1 - && $Config{db_version_minor} == 0 - && $Config{db_version_patch} == 0) { - print STDERR <<EOM ; + && $Config{db_version_major} == 1 + && $Config{db_version_minor} == 0 + && $Config{db_version_patch} == 0) { + print STDERR <<EOM ; # # For example Mac OS X 10.2 (or earlier) has such an old # version of Berkeley DB. EOM - } + } - print STDERR <<EOM ; + print STDERR <<EOM ; # # You can safely ignore the errors if you're never going to use the # broken functionality (recno databases with a modified bval). @@ -205,7 +205,7 @@ ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; my %noMode = map { $_, 1} qw( amigaos MSWin32 NetWare cygwin ) ; ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MacOS') ? 0666 : 0640) - || $noMode{$^O} ); + || $noMode{$^O} ); #my $l = @h ; my $l = $X->length ; @@ -429,37 +429,37 @@ unlink $Dfile; @EXPORT = @DB_File::EXPORT ; sub STORE { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::STORE($key, $value * 2) ; } sub FETCH { - my $self = shift ; + my $self = shift ; my $key = shift ; $self->SUPER::FETCH($key) - 1 ; } sub put { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = shift ; $self->SUPER::put($key, $value * 3) ; } sub get { - my $self = shift ; + my $self = shift ; $self->SUPER::get($_[0], $_[1]) ; - $_[1] -= 2 ; + $_[1] -= 2 ; } sub A_new_method { - my $self = shift ; + my $self = shift ; my $key = shift ; my $value = $self->FETCH($key) ; - return "[[$value]]" ; + return "[[$value]]" ; } 1 ; @@ -473,8 +473,8 @@ EOM my @h ; my $X ; eval ' - $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); - ' ; + $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); + ' ; die "Could not tie: $!" unless $X; main::ok(73, $@ eq "") ; @@ -586,8 +586,8 @@ EOM return $fetch_key eq $fk && $store_key eq $sk && - $fetch_value eq $fv && $store_value eq $sv && - $_ eq 'original' ; + $fetch_value eq $fv && $store_value eq $sv && + $_ eq 'original' ; } ok(99, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); @@ -615,13 +615,13 @@ EOM # replace the filters, but remember the previous set my ($old_fk) = $db->filter_fetch_key - (sub { ++ $_ ; $fetch_key = $_ }) ; + (sub { ++ $_ ; $fetch_key = $_ }) ; my ($old_sk) = $db->filter_store_key - (sub { $_ *= 2 ; $store_key = $_ }) ; + (sub { $_ *= 2 ; $store_key = $_ }) ; my ($old_fv) = $db->filter_fetch_value - (sub { $_ = "[$_]"; $fetch_value = $_ }) ; + (sub { $_ = "[$_]"; $fetch_value = $_ }) ; my ($old_sv) = $db->filter_store_value - (sub { s/o/x/g; $store_value = $_ }) ; + (sub { s/o/x/g; $store_value = $_ }) ; ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; $h[1] = "Joe" ; @@ -694,13 +694,13 @@ EOM sub Closure { my ($name) = @_ ; - my $count = 0 ; - my @kept = () ; + my $count = 0 ; + my @kept = () ; - return sub { ++$count ; - push @kept, $_ ; - $result{$name} = "$name - $count: [@kept]" ; - } + return sub { ++$count ; + push @kept, $_ ; + $result{$name} = "$name - $count: [@kept]" ; + } } $db->filter_store_key(Closure("store key")) ; @@ -741,7 +741,7 @@ EOM undef $db ; ok(144, safeUntie \@h); unlink $Dfile; -} +} { # DBM Filter recursion detection @@ -944,7 +944,7 @@ EOM local $SIG{__WARN__} = sub {$a = $_[0]} ; tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; + or die "Can't open file: $!\n" ; $h[0] = undef; ok(150, $a eq "") ; ok(151, safeUntie \@h); @@ -964,7 +964,7 @@ EOM my @h ; tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; + or die "Can't open file: $!\n" ; @h = (); ; ok(152, $a eq "") ; ok(153, safeUntie \@h); @@ -1170,7 +1170,7 @@ EOM $value = '' ; $status = $db->get(undef, $value) ; ok 178, $status == 0 - or print "# get failed - status $status\n" ; + or print "# get failed - status $status\n" ; ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ; ok 180, $value eq 'fred' or print "# got [$value]\n" ; ok 181, $warned eq '' @@ -1202,7 +1202,7 @@ exit unless $FA ; my @tied ; tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO - or die "Can't open file: $!\n" ; + or die "Can't open file: $!\n" ; # uninitialized offset use warnings; @@ -1271,52 +1271,52 @@ exit unless $FA ; # Perl's built-in splice(). # my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion', - 'rarely', 'paleness' ], - -4, -2, - [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], - 'void' ], - - [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], - - [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], - 0, -4, - [ 'maids' ], - 'void' ], - - [ [ 'visibility', 'pocketful', 'rectangles' ], - -10, 0, - [ 'garbages' ], - 'void' ], - - [ [ 'sleeplessly' ], - 8, -4, - [ 'Margery', 'clearing', 'repercussion', 'clubs', - 'arise' ], - 'void' ], - - [ [ 'chastises', 'recalculates' ], - 0, 0, - [ 'momentariness', 'mediates', 'accents', 'toils', - 'regaled' ], - 'void' ], - - [ [ 'b', '' ], - 9, 8, - [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], - 'scalar' ], - - [ [ 'b', '' ], - undef, undef, - [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], - 'scalar' ], - - [ [ 'riheb' ], -8, undef, [], 'void' ], - - [ [ 'uft', 'qnxs', '' ], - 6, -2, - [ 'znp', 'mhnkh', 'bn' ], - 'void' ], - ); + 'rarely', 'paleness' ], + -4, -2, + [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ], + 'void' ], + + [ [ 'a' ], -2, 1, [ 'B' ], 'void' ], + + [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ], + 0, -4, + [ 'maids' ], + 'void' ], + + [ [ 'visibility', 'pocketful', 'rectangles' ], + -10, 0, + [ 'garbages' ], + 'void' ], + + [ [ 'sleeplessly' ], + 8, -4, + [ 'Margery', 'clearing', 'repercussion', 'clubs', + 'arise' ], + 'void' ], + + [ [ 'chastises', 'recalculates' ], + 0, 0, + [ 'momentariness', 'mediates', 'accents', 'toils', + 'regaled' ], + 'void' ], + + [ [ 'b', '' ], + 9, 8, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'b', '' ], + undef, undef, + [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ], + 'scalar' ], + + [ [ 'riheb' ], -8, undef, [], 'void' ], + + [ [ 'uft', 'qnxs', '' ], + 6, -2, + [ 'znp', 'mhnkh', 'bn' ], + 'void' ], + ); my $testnum = 194; my $failed = 0; @@ -1324,10 +1324,10 @@ my $tmp = "dbr$$"; foreach my $test (@tests) { my $err = test_splice(@$test); if (defined $err) { - print STDERR "# failed: ", Dumper($test); - print STDERR "# error: $err\n"; - $failed = 1; - ok($testnum++, 0); + print STDERR "# failed: ", Dumper($test); + print STDERR "# error: $err\n"; + $failed = 1; + ok($testnum++, 0); } else { ok($testnum++, 1) } } @@ -1341,15 +1341,15 @@ else { $failed = 0; srand(0); foreach (0 .. 1000 - 1) { - my $test = rand_test(); - my $err = test_splice(@$test); - if (defined $err) { - print STDERR "# failed: ", Dumper($test); - print STDERR "# error: $err\n"; - $failed = 1; - print STDERR "# skipping any remaining random tests\n"; - last; - } + my $test = rand_test(); + my $err = test_splice(@$test); + if (defined $err) { + print STDERR "# failed: ", Dumper($test); + print STDERR "# error: $err\n"; + $failed = 1; + print STDERR "# skipping any remaining random tests\n"; + last; + } } ok($testnum++, not $failed); @@ -1403,77 +1403,77 @@ sub test_splice { my $gather_warning = sub { push @s_warnings, $_[0] }; if ($context eq 'list') { - my @r; - eval { - local $SIG{__WARN__} = $gather_warning; - @r = splice @array, $offset, $length, @list; - }; - $s_error = $@; - $s_r = \@r; + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = \@r; } elsif ($context eq 'scalar') { - my $r; - eval { - local $SIG{__WARN__} = $gather_warning; - $r = splice @array, $offset, $length, @list; - }; - $s_error = $@; - $s_r = [ $r ]; + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = [ $r ]; } elsif ($context eq 'void') { - eval { - local $SIG{__WARN__} = $gather_warning; - splice @array, $offset, $length, @list; - }; - $s_error = $@; - $s_r = []; + eval { + local $SIG{__WARN__} = $gather_warning; + splice @array, $offset, $length, @list; + }; + $s_error = $@; + $s_r = []; } else { - die "bad context $context"; + die "bad context $context"; } foreach ($s_error, @s_warnings) { - chomp; - s/ at \S+ line \d+\.$//; - # only built-in splice identifies name of uninit value - s/(uninitialized value) \$\w+/$1/; + chomp; + s/ at \S+ line \d+\.$//; + # only built-in splice identifies name of uninit value + s/(uninitialized value) \$\w+/$1/; } # Now do the same for DB_File's version of splice my ($ms_r, $ms_error, @ms_warnings); $gather_warning = sub { push @ms_warnings, $_[0] }; if ($context eq 'list') { - my @r; - eval { - local $SIG{__WARN__} = $gather_warning; - @r = splice @h, $offset, $length, @list; - }; - $ms_error = $@; - $ms_r = \@r; + my @r; + eval { + local $SIG{__WARN__} = $gather_warning; + @r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = \@r; } elsif ($context eq 'scalar') { - my $r; - eval { - local $SIG{__WARN__} = $gather_warning; - $r = splice @h, $offset, $length, @list; - }; - $ms_error = $@; - $ms_r = [ $r ]; + my $r; + eval { + local $SIG{__WARN__} = $gather_warning; + $r = splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = [ $r ]; } elsif ($context eq 'void') { - eval { - local $SIG{__WARN__} = $gather_warning; - splice @h, $offset, $length, @list; - }; - $ms_error = $@; - $ms_r = []; + eval { + local $SIG{__WARN__} = $gather_warning; + splice @h, $offset, $length, @list; + }; + $ms_error = $@; + $ms_r = []; } else { - die "bad context $context"; + die "bad context $context"; } foreach ($ms_error, @ms_warnings) { - chomp; + chomp; s/ at \S+(\s+\S+)*? line \d+\.?.*//s; } @@ -1485,26 +1485,26 @@ sub test_splice { if list_diff(\@array, \@h); if ((scalar @s_warnings) != (scalar @ms_warnings)) { - return 'different number of warnings'; + return 'different number of warnings'; } while (@s_warnings) { - my $sw = shift @s_warnings; - my $msw = shift @ms_warnings; - - if (defined $sw and defined $msw) { - $msw =~ s/ \(.+\)$//; - $msw =~ s/ in splice$// if $] < 5.006; - if ($sw ne $msw) { - return "different warning: '$sw' vs '$msw'"; - } - } - elsif (not defined $sw and not defined $msw) { - # Okay. - } - else { - return "one warning defined, another undef"; - } + my $sw = shift @s_warnings; + my $msw = shift @ms_warnings; + + if (defined $sw and defined $msw) { + $msw =~ s/ \(.+\)$//; + $msw =~ s/ in splice$// if $] < 5.006; + if ($sw ne $msw) { + return "different warning: '$sw' vs '$msw'"; + } + } + elsif (not defined $sw and not defined $msw) { + # Okay. + } + else { + return "one warning defined, another undef"; + } } undef $H; @@ -1514,7 +1514,7 @@ sub test_splice { @h = <TEXT>; normalise @h; chomp @h; close TEXT or die "cannot close $tmp: $!"; return('list is different when re-read from disk: ' - . Dumper(\@array) . ' vs ' . Dumper(\@h)) + . Dumper(\@array) . ' vs ' . Dumper(\@h)) if list_diff(\@array, \@h); unlink $tmp; @@ -1543,16 +1543,16 @@ sub list_diff { my @a = @$a; my @b = @$b; return 1 if (scalar @a) != (scalar @b); for (my $i = 0; $i < @a; $i++) { - my ($ae, $be) = ($a[$i], $b[$i]); - if (defined $ae and defined $be) { - return 1 if $ae ne $be; - } - elsif (not defined $ae and not defined $be) { - # Two undefined values are 'equal' - } - else { - return 1; - } + my ($ae, $be) = ($a[$i], $b[$i]); + if (defined $ae and defined $be) { + return 1 if $ae ne $be; + } + elsif (not defined $ae and not defined $be) { + # Two undefined values are 'equal' + } + else { + return 1; + } } return 0; } @@ -1569,10 +1569,10 @@ sub rand_test { my @contexts = qw<list scalar void>; my $context = $contexts[int(rand @contexts)]; return [ rand_list(), - (rand() < 0.5) ? (int(rand(20)) - 10) : undef, - (rand() < 0.5) ? (int(rand(20)) - 10) : undef, - rand_list(), - $context ]; + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + (rand() < 0.5) ? (int(rand(20)) - 10) : undef, + rand_list(), + $context ]; } @@ -1581,7 +1581,7 @@ sub rand_list { my @r; while (rand() > 0.1 * (scalar @r + 1)) { - push @r, rand_word(); + push @r, rand_word(); } return \@r; } @@ -1592,7 +1592,7 @@ sub rand_word { my $r = ''; my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>; while (rand() > 0.1 * (length($r) + 1)) { - $r .= $chars[int(rand(scalar @chars))]; + $r .= $chars[int(rand(scalar @chars))]; } return $r; } diff --git a/gnu/usr.bin/perl/cpan/DB_File/typemap b/gnu/usr.bin/perl/cpan/DB_File/typemap index c46b6851d76..2cfed9710e3 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/typemap +++ b/gnu/usr.bin/perl/cpan/DB_File/typemap @@ -1,6 +1,6 @@ # typemap for Perl 5 interface to Berkeley # -# written by Paul Marquess <Paul.Marquess@btinternet.com> +# written by Paul Marquess <pmqs@cpan.org> # last modified 20th June 2004 # version 1.809 # @@ -8,50 +8,50 @@ # # -u_int T_U_INT -DB_File T_PTROBJ -DBT T_dbtdatum -DBTKEY T_dbtkeydatum +u_int T_U_INT +DB_File T_PTROBJ +DBT T_dbtdatum +DBTKEY T_dbtkeydatum INPUT T_dbtkeydatum { - SV * my_sv = $arg; - DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\"); - DBT_clear($var) ; - SvGETMAGIC(my_sv) ; + SV * my_sv = $arg; + DBM_ckFilter(my_sv, filter_store_key, \"filter_store_key\"); + DBT_clear($var) ; + SvGETMAGIC(my_sv) ; if (db->type == DB_RECNO) { - if (SvOK(my_sv)) - Value = GetRecnoKey(aTHX_ db, SvIV(my_sv)) ; + if (SvOK(my_sv)) + Value = GetRecnoKey(aTHX_ db, SvIV(my_sv)) ; else - Value = 1 ; - $var.data = & Value; - $var.size = (int)sizeof(recno_t); + Value = 1 ; + $var.data = & Value; + $var.size = (int)sizeof(recno_t); } else if (SvOK(my_sv)) { - STRLEN len; - $var.data = SvPVbyte(my_sv, len); - $var.size = (int)len; - } + STRLEN len; + $var.data = SvPVbyte(my_sv, len); + $var.size = (int)len; + } } T_dbtdatum { - SV * my_sv = $arg; - DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\"); - DBT_clear($var) ; - SvGETMAGIC(my_sv) ; - if (SvOK(my_sv)) { - STRLEN len; - $var.data = SvPVbyte(my_sv, len); - $var.size = (int)len; - } + SV * my_sv = $arg; + DBM_ckFilter(my_sv, filter_store_value, \"filter_store_value\"); + DBT_clear($var) ; + SvGETMAGIC(my_sv) ; + if (SvOK(my_sv)) { + STRLEN len; + $var.data = SvPVbyte(my_sv, len); + $var.size = (int)len; + } } OUTPUT T_dbtkeydatum - OutputKey($arg, $var) + OutputKey($arg, $var) T_dbtdatum - OutputValue($arg, $var) + OutputValue($arg, $var) T_PTROBJ sv_setref_pv($arg, dbtype, (void*)$var); diff --git a/gnu/usr.bin/perl/cpan/DB_File/version.c b/gnu/usr.bin/perl/cpan/DB_File/version.c index e01f6f6fa3d..ecf73de4e1c 100644 --- a/gnu/usr.bin/perl/cpan/DB_File/version.c +++ b/gnu/usr.bin/perl/cpan/DB_File/version.c @@ -2,7 +2,7 @@ version.c -- Perl 5 interface to Berkeley DB - written by Paul Marquess <Paul.Marquess@btinternet.com> + written by Paul Marquess <pmqs@cpan.org> last modified 2nd Jan 2002 version 1.802 @@ -14,7 +14,7 @@ Changes: 1.71 - Support for Berkeley DB version 3. - Support for Berkeley DB 2/3's backward compatibility mode. + Support for Berkeley DB 2/3's backward compatibility mode. 1.72 - No change. 1.73 - Added support for threading 1.74 - Added Perl core patch 7801. @@ -36,7 +36,7 @@ __getBerkeleyDBInfo(void) __getBerkeleyDBInfo() #endif { -#ifdef dTHX +#ifdef dTHX dTHX; #endif SV * version_sv = perl_get_sv("DB_File::db_version", GV_ADD|GV_ADDMULTI) ; @@ -50,16 +50,16 @@ __getBerkeleyDBInfo() /* Check that the versions of db.h and libdb.a are the same */ if (Major != DB_VERSION_MAJOR || Minor != DB_VERSION_MINOR ) - /* || Patch != DB_VERSION_PATCH) */ + /* || Patch != DB_VERSION_PATCH) */ - croak("\nDB_File was build with libdb version %d.%d.%d,\nbut you are attempting to run it with libdb version %d.%d.%d\n", - DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, - Major, Minor, Patch) ; + croak("\nDB_File was build with libdb version %d.%d.%d,\nbut you are attempting to run it with libdb version %d.%d.%d\n", + DB_VERSION_MAJOR, DB_VERSION_MINOR, DB_VERSION_PATCH, + Major, Minor, Patch) ; /* check that libdb is recent enough -- we need 2.3.4 or greater */ if (Major == 2 && (Minor < 3 || (Minor == 3 && Patch < 4))) - croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", - Major, Minor, Patch) ; + croak("DB_File needs Berkeley DB 2.3.4 or greater, you have %d.%d.%d\n", + Major, Minor, Patch) ; { char buffer[40] ; diff --git a/gnu/usr.bin/perl/cpan/Encode/Encode/encode.h b/gnu/usr.bin/perl/cpan/Encode/Encode/encode.h index 5d7663d5b55..ba884d42d1a 100644 --- a/gnu/usr.bin/perl/cpan/Encode/Encode/encode.h +++ b/gnu/usr.bin/perl/cpan/Encode/Encode/encode.h @@ -280,6 +280,14 @@ S_new_msg_hv(const char * const message, /* The message text */ # define PERL_UNUSED_ARG(x) ((void)x) # endif +# ifndef memGT +# define memGT(s1,s2,l) (memcmp(s1,s2,l) > 0) +# endif + +# ifndef MIN +# define MIN(a,b) ((a) < (b) ? (a) : (b)) +# endif + static const char malformed_text[] = "Malformed UTF-8 character"; static char * diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/03-xsstatic.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/03-xsstatic.t index bfe3dc96c38..faf56e33398 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/03-xsstatic.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/03-xsstatic.t @@ -20,7 +20,7 @@ plan skip_all => "ExtUtils::CBuilder not installed or couldn't find a compiler" unless have_compiler(); plan skip_all => 'Shared perl library' if $Config{useshrplib} eq 'true'; plan skip_all => $^O if $^O =~ m!^(MSWin32|cygwin|haiku|darwin)$!; -plan skip_all => 'Skipped when not PERL_CORE or in git repo' unless $ENV{PERL_CORE} or $release; +plan skip_all => 'Skipped when not PERL_CORE nor in git repo' unless $ENV{PERL_CORE} or $release; my @tests = list_static(); plan skip_all => "No tests" unless @tests; plan tests => 6 * @tests; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Cygwin.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Cygwin.t index 4e7336c1eda..a37cb627657 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Cygwin.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/MM_Cygwin.t @@ -80,7 +80,7 @@ like( $res, qr/manifypods.*foo.*foo.1/s, '... should add MAN3PODS targets' ); # init_linker { my $libperl = $Config{libperl} || 'libperl.a'; - $libperl =~ s/\.a/.dll.a/ if $] >= 5.006002; + $libperl =~ s/\.a/.dll.a/ if "$]" >= 5.006002; $libperl = "\$(PERL_INC)/$libperl"; my $export = ''; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/fixin.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/fixin.t index 061e4562470..1357a2d8d33 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/fixin.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/fixin.t @@ -9,7 +9,7 @@ BEGIN { use File::Spec; -use Test::More tests => 22; +use Test::More tests => 30; use Config; use TieOut; @@ -123,3 +123,35 @@ END } ); } + +SKIP: { + eval { chmod(0755, "usrbin/interp") } + or skip "no chmod", 8; + skip "Not relevant on VMS or MSWin32", 8 if $^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'cygwin'; + + my $dir = getcwd(); + local $ENV{PATH} = join $Config{path_sep}, map "$dir/$_", qw(usrbin bin); + + test_fixin(<<END, +#!$dir/bin/interp + +blah blah blah +END + sub { + is $_[0], "#!$dir/usrbin/interp\n", 'interpreter updated to one found in PATH'; + } + ); + + eval { symlink("../usrbin/interp", "bin/interp") } + or skip "no symlinks", 4; + + test_fixin(<<END, +#!$dir/bin/interp + +blah blah blah +END + sub { + is $_[0], "#!$dir/bin/interp\n", 'symlinked interpreter later in PATH not mangled'; + } + ); +} diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm index 3d093fcfbd6..cfe49e54659 100644 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/lib/MakeMaker/Test/Setup/BFD.pm @@ -54,6 +54,9 @@ program - this is a program 1; END + 'Big-Dummy/usrbin/interp' => <<'END', +This is a dummy interpreter +END 'Big-Dummy/test.pl' => <<'END', print "1..1\n"; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/pod2man.t b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/pod2man.t index d206e0bc956..e3bc00dd401 100755 --- a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/pod2man.t +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/pod2man.t @@ -19,7 +19,7 @@ use Test::More tests => 3; pod2man("--perm_rw"); - like $warnings, qr/^Option perm_rw requires an argument/; + like $warnings, qr/Option perm_rw requires an argument/; }; diff --git a/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/testrules.yml b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/testrules.yml new file mode 100644 index 00000000000..97fad8cf199 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/ExtUtils-MakeMaker/t/testrules.yml @@ -0,0 +1,11 @@ +--- +# TAP::Harness test rules +# "t\02-xsdynamic.t" (and possibly "t\03-xsstatic.t") should *not* be run in parallel +# ... allowing overlap of these tests causes race conditions which lead to intermittent failures +seq: + - seq: + # serialize all tests in files matching "t/0*.t" + - t{\\,/}0*.t + - par: + # run all other tests in parallel + - ** diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip b/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip new file mode 100644 index 00000000000..1a34fef2950 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/bin/streamzip @@ -0,0 +1,212 @@ +#!/usr/bin/perl + +# Streaming zip + +use strict; +use warnings; + +use IO::Compress::Zip qw(zip + ZIP_CM_STORE + ZIP_CM_DEFLATE + ZIP_CM_BZIP2 + ZIP_CM_LZMA ); +use Getopt::Long; + +my $VERSION = '1.0'; + +my $compression_method = ZIP_CM_DEFLATE; +my $stream = 0; +my $zipfile = '-'; +my $memberName = '-' ; +my $zip64 = 0 ; + +GetOptions("zip64" => \$zip64, + "method=s" => \&lookupMethod, + "stream" => \$stream, + "zipfile=s" => \$zipfile, + "member-name=s" => \$memberName, + 'version' => sub { print "$VERSION\n"; exit 0 }, + 'help' => \&Usage, + ) + or Usage(); + +Usage() + if @ARGV; + + +zip '-' => $zipfile, + Name => $memberName, + Zip64 => $zip64, + Method => $compression_method, + Stream => $stream + or die "Error creating zip file '$zipfile': $\n" ; + +exit 0; + +sub lookupMethod +{ + my $name = shift; + my $value = shift ; + + my %valid = ( store => ZIP_CM_STORE, + deflate => ZIP_CM_DEFLATE, + bzip2 => ZIP_CM_BZIP2, + lzma => ZIP_CM_LZMA, + ); + + my $method = $valid{ lc $value }; + + Usage("Unknown method '$value'") + if ! defined $method; + + # If LZMA was rquested, check that it is available + if ($method == ZIP_CM_LZMA) + { + eval ' use IO::Compress::Adapter::Lzma'; + die "Method =. LZMA needs IO::Compress::Adapter::Lzma\n" + if ! defined $IO::Compress::Lzma::VERSION; + } + + $compression_method = $method; +} + +sub Usage +{ + die <<EOM; +streamzip [OPTIONS] + +Stream data from stdin, compress into a Zip container, and stream to stdout. + +OPTIONS + + -zipfile=F Write zip container to the filename F + -member-name=M member name [Default '-'] + -zip64 Create a Zip64-compliant zip file [Default: No] + Use Zip64 if input is greater than 4Gig. + -stream Write a streamed zip file + Only applies when 'zipfile' option is used. [Default: No] + Always enabled when writing to stdout. + -method=M Compress using method "M". + Valid methods are + store Store without compression + deflate Use Deflate compression [Deflault] + bzip2 Use Bzip2 compression + lzma Use LZMA compression [needs IO::Compress::Lzma] + Lzma needs IO::Compress::Lzma to be installed. + -version Display version number [$VERSION] + +Copyright (c) 2019 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +EOM +} + + +__END__ +=head1 NAME + +streamzip - create a zip file from stdin + +=head1 SYNOPSIS + + producer | streamzip [opts] | consumer + producer | streamzip [opts] -zipfile=output.zip + +=head1 DESCRIPTION + +This program will read data from stdin, compress it into a zip container and, +by default, write a I<streamed> zip file to stdout. No temporary files are created. + +The zip container written to stdout is, by necessity, written in streaming +format. Most programs that read Zip files can cope with a streamed zip file, +but if interoperability is important, and your workflow allows you to write the +zip file directly to disk you can create a non-streamed zip file using the C<zipfile> option. + +=head2 OPTIONS + +=over 5 + +=item -zip64 + +Create a Zip64-compliant zip container. +Use this option if the input is greater than 4Gig. + +Default is disabled. + +=item -zipfile=F + +Write zip container to the filename F. + +Use the C<Stream> option to enable the creation of a streamed zip file. + +=item -member-name=M + +This option is used to name the "file" in the zip container. + +Default is '-'. + +=item -stream + +Ignored when writing to stdout. + +If the C<zipfile> option is specified, including this option +will trigger the creation of a streamed zip file. + +Default: Always enabled when writing to stdout, otherwise disabled. + +=item -method=M + +Compress using method "M". + +Valid method names are + + * store Store without compression + * deflate Use Deflate compression [Deflault] + * bzip2 Use Bzip2 compression + * lzma Use LZMA compression + +Note that Lzma compress needs IO::Compress::Lzma to be installed. + +Default is deflate. + +=item -version + +Display version number [$VERSION] + +=item -help + +Display help + +=back + +=head2 When to use a Streamed Zip File + +A Zip file created with streaming mode enabled allows you to create a zip file +in situations where you cannot seek backwards/forwards in the file. + +A good examples is when you are +serving dynamic content from a Web Server straight into a socket +without needing to create a temporary zip file in the filesystsm. + +Similarly if your workfow uses a Linux pipelined commands. + +=head1 SUPPORT + +General feedback/questions/bug reports should be sent to +L<https://github.com/pmqs/IO-Compress/issues> (preferred) or +L<https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Compress>. + + +=head1 AUTHOR + +Paul Marquess F<pmqs@cpan.org>. + +=head1 COPYRIGHT + +Copyright (c) 2019 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/006zip.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/006zip.t index 33afa8e7236..cfc53d79ab2 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/006zip.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/006zip.t @@ -19,7 +19,7 @@ BEGIN { $extra = 1 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - plan tests => 101 + $extra ; + plan tests => 108 + $extra ; use_ok('IO::Compress::Zip', qw(:all)) ; use_ok('IO::Uncompress::Unzip', qw(unzip $UnzipError)) ; @@ -360,3 +360,45 @@ for my $method (ZIP_CM_DEFLATE, ZIP_CM_STORE, ZIP_CM_BZIP2) is $u->getHeaderInfo()->{Name}, "0", "Name is '0'"; } + +{ + title "nexStream regression"; + # https://github.com/pmqs/IO-Compress/issues/3 + + my $lex = new LexFile my $file1; + + my $content1 = qq["organisation_path","collection_occasion_key","episode_key"\n] ; + + my $zip = new IO::Compress::Zip $file1, + Name => "one"; + isa_ok $zip, "IO::Compress::Zip"; + + print $zip $content1; + + $zip->newStream(Name=> "two"); + + my $content2 = <<EOM; +"key","value" +"version","2" +"type","PMHC" +EOM + print $zip $content2; + + ok $zip->close(), "closed"; + + + my $u = new IO::Uncompress::Unzip $file1, Append => 1, @_ + or die "Cannot open $file1: $UnzipError"; + + isa_ok $u, "IO::Uncompress::Unzip"; + + my $name = $u->getHeaderInfo()->{Name}; + + is $u->getHeaderInfo()->{Name}, "one", "Name is 'one'"; + + ok $u->nextStream(), "nextStream OK"; + + my $line = <$u>; + + is $line, qq["key","value"\n], "got line 1 from second member"; +}
\ No newline at end of file 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 new file mode 100644 index 00000000000..df3fbfb0fd8 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/011-streamzip.t @@ -0,0 +1,118 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); + +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; +use IO::Uncompress::Unzip 'unzip' ; + +BEGIN +{ + plan(skip_all => "Needs Perl 5.005 or better - you have Perl $]" ) + if $] < 5.005 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 8 + $extra ; +} + + +my $Inc = join " ", map qq["-I$_"] => @INC; +$Inc = '"-MExtUtils::testlib"' + if ! $ENV{PERL_CORE} && eval " require ExtUtils::testlib; " ; + +my $Perl = ($ENV{'FULLPERL'} or $^X or 'perl') ; +$Perl = qq["$Perl"] if $^O eq 'MSWin32' ; + +$Perl = "$Perl $Inc -w" ; +#$Perl .= " -Mblib " ; +my $binDir = $ENV{PERL_CORE} ? "../ext/IO-Compress/bin/" + : "./bin/"; + +my $hello1 = <<EOM ; +hello +this is +a test +message +x ttttt +xuuuuuu +the end +EOM + + + + +my $lex = new LexFile my $stderr ; + + +sub check +{ + my $command = shift ; + my $expected = shift ; + + my $lex = new LexFile my $stderr ; + + my $cmd = "$command 2>$stderr"; + my $stdout = `$cmd` ; + + my $aok = 1 ; + + $aok &= is $?, 0, " exit status is 0" ; + + $aok &= is readFile($stderr), '', " no stderr" ; + + $aok &= is $stdout, $expected, " expected content is ok" + if defined $expected ; + + if (! $aok) { + diag "Command line: $cmd"; + my ($file, $line) = (caller)[1,2]; + diag "Test called from $file, line $line"; + } + + 1 while unlink $stderr; +} + + +# streamzip +# ######## + +{ + title "streamzip" ; + + my ($infile, $outfile); + my $lex = new LexFile $infile, $outfile ; + + writeFile($infile, $hello1) ; + check "$Perl ${binDir}/streamzip <$infile >$outfile"; + + my $uncompressed ; + unzip $outfile => \$uncompressed; + is $uncompressed, $hello1; +} + +{ + title "streamzip" ; + + my ($infile, $outfile); + my $lex = new LexFile $infile, $outfile ; + + writeFile($infile, $hello1) ; + check "$Perl ${binDir}/streamzip -zipfile=$outfile <$infile"; + + my $uncompressed ; + unzip $outfile => \$uncompressed; + is $uncompressed, $hello1; +} diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/050interop-gzip.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/050interop-gzip.t index f3cb1a39119..ae019c87acf 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/050interop-gzip.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/050interop-gzip.t @@ -56,7 +56,7 @@ sub readWithGzip return 1 } - diag "'$comp' failed: $?"; + diag "'$comp' failed: \$?=$? \$!=$!"; return 0 ; } @@ -80,7 +80,7 @@ sub writeWithGzip return 1 if system($comp) == 0 ; - diag "'$comp' failed: $?"; + diag "'$comp' failed: \$?=$? \$!=$!"; return 0 ; } diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/105oneshot-zip-only.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/105oneshot-zip-only.t index 94676eb5dd6..7611da3774e 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/105oneshot-zip-only.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/105oneshot-zip-only.t @@ -24,7 +24,7 @@ BEGIN { $extra = 1 if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; - plan tests => 219 + $extra ; + plan tests => 227 + $extra ; #use_ok('IO::Compress::Zip', qw(zip $ZipError :zip_method)) ; use_ok('IO::Compress::Zip', qw(:all)) ; @@ -162,6 +162,55 @@ sub zipGetHeader is $hdr->{Name}, File::Spec->catfile("", "fred", "jim"), " Name is '/fred/jim'" ; } +{ + title "Detect encrypted zip file"; + + my $files = "./t/" ; + $files = "./" if $ENV{PERL_CORE} ; + $files .= "files/"; + + my $zipfile = "$files/encrypt-standard.zip" ; + my $output; + + ok ! unzip "$files/encrypt-standard.zip" => \$output ; + like $UnzipError, qr/Encrypted content not supported/ ; + + ok ! unzip "$files/encrypt-aes.zip" => \$output ; + like $UnzipError, qr/Encrypted content not supported/ ; +} + +{ + title "jar file with deflated directory"; + + # Create Jar as follow + # echo test > file && jar c file > jar.zip + + # Note the deflated directory META-INF with length 0 & size 2 + # + # $ unzip -vl t/files/jar.zip + # Archive: t/files/jar.zip + # Length Method Size Cmpr Date Time CRC-32 Name + # -------- ------ ------- ---- ---------- ----- -------- ---- + # 0 Defl:N 2 0% 2019-09-07 22:35 00000000 META-INF/ + # 54 Defl:N 53 2% 2019-09-07 22:35 934e49ff META-INF/MANIFEST.MF + # 5 Defl:N 7 -40% 2019-09-07 22:35 3bb935c6 file + # -------- ------- --- ------- + # 59 62 -5% 3 files + + + my $files = "./t/" ; + $files = "./" if $ENV{PERL_CORE} ; + $files .= "files/"; + + my $zipfile = "$files/jar.zip" ; + my $output; + + ok unzip $zipfile => \$output ; + + is $output, "" ; + +} + for my $stream (0, 1) { for my $zip64 (0, 1) diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/107multi-zip-only.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/107multi-zip-only.t new file mode 100644 index 00000000000..40c7fef5e2a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/107multi-zip-only.t @@ -0,0 +1,102 @@ + +use strict; +use warnings; + +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); + + +use Test::More ; +use CompTestUtils; + +BEGIN { + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 21 + $extra ; + + use_ok('IO::Compress::Zip', qw(zip $ZipError)) ; + + use_ok('IO::Uncompress::Unzip', qw($UnzipError)) ; + use_ok('IO::Uncompress::AnyUncompress', qw($AnyUncompressError)) ; + +} + + my @buffers ; + push @buffers, <<EOM ; +hello world +this is a test +some more stuff on this line +ad finally... +EOM + + push @buffers, <<EOM ; +some more stuff +line 2 +EOM + + push @buffers, <<EOM ; +even more stuff +EOM + + +my $name = "n1"; +my $lex = new LexFile my $zipfile ; + +my $x = new IO::Compress::Zip($zipfile, Name => $name++, AutoClose => 1); +isa_ok $x, 'IO::Compress::Zip', ' $x' ; + + +foreach my $buffer (@buffers) { + ok $x->write($buffer), " Write OK" ; + # this will add an extra "empty" stream + ok $x->newStream(Name => $name ++), " newStream OK" ; +} +ok $x->close, " Close ok" ; + +push @buffers, undef; + +{ + open F, ">>$zipfile"; + print F "trailing"; + close F; +} + +my $u = new IO::Uncompress::Unzip $zipfile, Transparent => 1, MultiStream => 0 + or die "Cannot open $zipfile: $UnzipError"; + +my @names ; +my $status; +my $expname = "n1"; +my $ix = 0; + +for my $ix (1 .. 4) +{ + local $/ ; + + my $n = $u->getHeaderInfo()->{Name}; + is $n, $expname , "name is $expname"; + is <$u>, $buffers[$ix-1], "payload ok"; + ++ $expname; + + $status = $u->nextStream() +} + +{ + local $/ ; + + my $n = $u->getHeaderInfo()->{Name}; + is $n, undef , "name is undef"; + is <$u>, "trailing", "payload ok"; +} + +die "Error processing $zipfile: $!\n" + if $status < 0 ;
\ No newline at end of file diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/112utf8-zip.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/112utf8-zip.t new file mode 100644 index 00000000000..f90a3cb7d61 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/112utf8-zip.t @@ -0,0 +1,220 @@ +BEGIN { + if ($ENV{PERL_CORE}) { + chdir 't' if -d 't'; + @INC = ("../lib", "lib/compress"); + } +} + +use lib qw(t t/compress); +use strict; +use warnings; +use bytes; + +use Test::More ; +use CompTestUtils; +use Data::Dumper; + +use IO::Compress::Zip qw($ZipError); +use IO::Uncompress::Unzip qw($UnzipError); + +BEGIN { + plan skip_all => "Encode is not available" + if $] < 5.006 ; + + eval { require Encode; Encode->import(); }; + + plan skip_all => "Encode is not available" + if $@ ; + + plan skip_all => "Encode not woking in perl $]" + if $] >= 5.008 && $] < 5.008004 ; + + # use Test::NoWarnings, if available + my $extra = 0 ; + $extra = 1 + if eval { require Test::NoWarnings ; import Test::NoWarnings; 1 }; + + plan tests => 28 + $extra; +} + +{ + title "EFS set in zip: Create a simple zip - language encoding flag set"; + + my $lex = new LexFile my $file1; + + my @names = ( 'alpha \N{GREEK SMALL LETTER ALPHA}', + 'beta \N{GREEK SMALL LETTER BETA}', + 'gamma \N{GREEK SMALL LETTER GAMMA}', + 'delta \N{GREEK SMALL LETTER DELTA}' + ) ; + + my @encoded = map { Encode::encode_utf8($_) } @names; + + my @n = @names; + + my $zip = new IO::Compress::Zip $file1, + Name => $names[0], Efs => 1; + + my $content = 'Hello, world!'; + ok $zip->print($content), "print"; + $zip->newStream(Name => $names[1], Efs => 1); + ok $zip->print($content), "print"; + $zip->newStream(Name => $names[2], Efs => 1); + ok $zip->print($content), "print"; + $zip->newStream(Name => $names[3], Efs => 1); + ok $zip->print($content), "print"; + ok $zip->close(), "closed"; + + { + my $u = new IO::Uncompress::Unzip $file1, Efs => 1 + or die "Cannot open $file1: $UnzipError"; + + my $status; + my @efs; + my @unzip_names; + for ($status = 1; $status > 0; $status = $u->nextStream(Efs => 1)) + { + push @efs, $u->getHeaderInfo()->{efs}; + push @unzip_names, $u->getHeaderInfo()->{Name}; + } + + die "Error processing $file1: $status $!\n" + if $status < 0; + + is_deeply \@efs, [1, 1, 1, 1], "language encoding flag set" + or diag "Got " . Dumper(\@efs); + is_deeply \@unzip_names, [@names], "Names round tripped" + or diag "Got " . Dumper(\@unzip_names); + } + + { + my $u = new IO::Uncompress::Unzip $file1, Efs => 0 + or die "Cannot open $file1: $UnzipError"; + + my $status; + my @efs; + my @unzip_names; + for ($status = 1; $status > 0; $status = $u->nextStream(Efs => 0)) + { + push @efs, $u->getHeaderInfo()->{efs}; + push @unzip_names, $u->getHeaderInfo()->{Name}; + } + + die "Error processing $file1: $status $!\n" + if $status < 0; + + is_deeply \@efs, [1, 1, 1, 1], "language encoding flag set" + or diag "Got " . Dumper(\@efs); + is_deeply \@unzip_names, [@names], "Names round tripped" + or diag "Got " . Dumper(\@unzip_names); + } +} + + +{ + title "Create a simple zip - language encoding flag not set"; + + my $lex = new LexFile my $file1; + + my @names = ( 'alpha \N{GREEK SMALL LETTER ALPHA}', + 'beta \N{GREEK SMALL LETTER BETA}', + 'gamma \N{GREEK SMALL LETTER GAMMA}', + 'delta \N{GREEK SMALL LETTER DELTA}' + ) ; + + my @n = @names; + + my $zip = new IO::Compress::Zip $file1, + Name => $names[0], Efs => 0; + + my $content = 'Hello, world!'; + ok $zip->print($content), "print"; + $zip->newStream(Name => $names[1], Efs => 0); + ok $zip->print($content), "print"; + $zip->newStream(Name => $names[2], Efs => 0); + ok $zip->print($content), "print"; + $zip->newStream(Name => $names[3]); + ok $zip->print($content), "print"; + ok $zip->close(), "closed"; + + my $u = new IO::Uncompress::Unzip $file1, Efs => 0 + or die "Cannot open $file1: $UnzipError"; + + my $status; + my @efs; + my @unzip_names; + for ($status = 1; $status > 0; $status = $u->nextStream()) + { + push @efs, $u->getHeaderInfo()->{efs}; + push @unzip_names, $u->getHeaderInfo()->{Name}; + } + + die "Error processing $file1: $status $!\n" + if $status < 0; + + is_deeply \@efs, [0, 0, 0, 0], "language encoding flag set" + or diag "Got " . Dumper(\@efs); + is_deeply \@unzip_names, [@names], "Names round tripped" + or diag "Got " . Dumper(\@unzip_names); +} + +{ + title "zip: EFS => 0 filename not valid utf8 - language encoding flag not set"; + + my $lex = new LexFile my $file1; + + # Invalid UTF8 + my $name = "a\xFF\x{100}"; + + my $zip = new IO::Compress::Zip $file1, + Name => $name, Efs => 0 ; + + ok $zip->print("abcd"), "print"; + ok $zip->close(), "closed"; + + my $u = new IO::Uncompress::Unzip $file1 + or die "Cannot open $file1: $UnzipError"; + + ok $u->getHeaderInfo()->{Name} eq $name, "got bad filename"; +} + +{ + title "unzip: EFS => 0 filename not valid utf8 - language encoding flag set"; + + my $filename = "t/files/bad-efs.zip" ; + my $name = "\xF0\xA4\xAD"; + + my $u = new IO::Uncompress::Unzip $filename, efs => 0 + or die "Cannot open $filename: $UnzipError"; + + ok $u->getHeaderInfo()->{Name} eq $name, "got bad filename"; +} + +{ + title "unzip: EFS => 1 filename not valid utf8 - language encoding flag set"; + + my $filename = "t/files/bad-efs.zip" ; + my $name = "\xF0\xA4\xAD"; + + eval { my $u = new IO::Uncompress::Unzip $filename, efs => 1 + or die "Cannot open $filename: $UnzipError" }; + + like $@, qr/Zip Filename not UTF-8/, + " Zip Filename not UTF-8" ; + +} + +{ + title "EFS => 1 - filename not valid utf8 - catch bad content writing to zip"; + + my $lex = new LexFile my $file1; + + # Invalid UTF8 + my $name = "a\xFF\x{100}"; + + eval { my $zip = new IO::Compress::Zip $file1, + Name => $name, Efs => 1 } ; + + like $@, qr/Wide character in zip filename/, + " wide characters in zip filename"; +}
\ No newline at end of file diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/compress/multi.pl b/gnu/usr.bin/perl/cpan/IO-Compress/t/compress/multi.pl index 4d587fbdd4a..48129a7c452 100644 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/compress/multi.pl +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/compress/multi.pl @@ -216,7 +216,8 @@ EOM ok $gz->eof(), " eof()"; is $gz->streamCount(), $stream, " streamCount is $stream" or diag "Stream count is " . $gz->streamCount(); - ok $un eq $buff, " expected output" ; + is $un, $buff, " expected output" + or diag "Stream count is " . $gz->streamCount(); ; #is $gz->tell(), length $buff, " tell is ok"; is $gz->nextStream(), 1, " nextStream ok"; is $gz->tell(), 0, " tell is 0"; diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-14gzopen.t b/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-14gzopen.t index 01d2d65a2bc..3d6a0626ee7 100755 --- a/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-14gzopen.t +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/cz-14gzopen.t @@ -439,7 +439,7 @@ foreach my $stdio ( ['-', '-'], [*STDIN, *STDOUT]) # missing parameters eval ' $fil = gzopen() ' ; - like $@, mkEvalErr('Not enough arguments for Compress::Zlib::gzopen'), + like $@, mkEvalErr('Not enough arguments .*? Compress::Zlib::gzopen'), ' gzopen with missing mode fails' ; # unknown parameters diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/files/bad-efs.zip b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/bad-efs.zip Binary files differnew file mode 100644 index 00000000000..642830e4bd6 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/bad-efs.zip diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/files/encrypt-aes.zip b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/encrypt-aes.zip Binary files differnew file mode 100644 index 00000000000..7a303da87f2 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/encrypt-aes.zip diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/files/encrypt-standard.zip b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/encrypt-standard.zip Binary files differnew file mode 100644 index 00000000000..ba07a08e587 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/encrypt-standard.zip diff --git a/gnu/usr.bin/perl/cpan/IO-Compress/t/files/jar.zip b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/jar.zip Binary files differnew file mode 100644 index 00000000000..e471d42c464 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/IO-Compress/t/files/jar.zip 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 8b98c95c2f4..8ef6949daf6 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 @@ -10,7 +10,7 @@ overload::import('overload', fallback => 1, ); -$JSON::PP::Boolean::VERSION = '4.02'; +$JSON::PP::Boolean::VERSION = '4.04'; 1; 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 883f31f4c93..fde281297fb 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.999816'; +our $VERSION = '1.999818'; use Carp; @@ -251,13 +251,6 @@ use overload ; -# Do we need api_version() at all, now that we have a virtual parent class that -# will provide any missing methods? Fixme! - -sub api_version () { - croak "@{[(caller 0)[3]]} method not implemented"; -} - sub _new { croak "@{[(caller 0)[3]]} method not implemented"; } @@ -386,6 +379,20 @@ sub _digit { substr($class ->_str($x), -($n+1), 1); } +sub _digitsum { + my ($class, $x) = @_; + + my $len = $class -> _len($x); + my $sum = $class -> _zero(); + for (my $i = 0 ; $i < $len ; ++$i) { + my $digit = $class -> _digit($x, $i); + $digit = $class -> _new($digit); + $sum = $class -> _add($sum, $digit); + } + + return $sum; +} + sub _zeros { my ($class, $x) = @_; my $str = $class -> _str($x); @@ -1428,16 +1435,20 @@ sub _to_base { if (@_) { $collseq = shift(); } else { - if ($class -> _acmp($base, $class -> _new("62")) <= 0) { - $collseq = '0123456789' . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - . 'abcdefghijklmnopqrstuvwxyz'; + if ($class -> _acmp($base, $class -> _new("94")) <= 0) { + $collseq = '0123456789' # 48 .. 57 + . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' # 65 .. 90 + . 'abcdefghijklmnopqrstuvwxyz' # 97 .. 122 + . '!"#$%&\'()*+,-./' # 33 .. 47 + . ':;<=>?@' # 58 .. 64 + . '[\\]^_`' # 91 .. 96 + . '{|}~'; # 123 .. 126 } else { - croak "When base > 62, a collation sequence must be given"; + croak "When base > 94, a collation sequence must be given"; } } my @collseq = split '', $collseq; - my %collseq = map { $_ => $collseq[$_] } 0 .. $#collseq; my $str = ''; my $tmp = $class -> _copy($x); @@ -1573,11 +1584,16 @@ sub _from_base { if ($class -> _acmp($base, $class -> _new("36")) <= 0) { $str = uc $str; $collseq = '0123456789' . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; - } elsif ($class -> _acmp($base, $class -> _new("62")) <= 0) { - $collseq = '0123456789' . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - . 'abcdefghijklmnopqrstuvwxyz'; + } elsif ($class -> _acmp($base, $class -> _new("94")) <= 0) { + $collseq = '0123456789' # 48 .. 57 + . 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' # 65 .. 90 + . 'abcdefghijklmnopqrstuvwxyz' # 97 .. 122 + . '!"#$%&\'()*+,-./' # 33 .. 47 + . ':;<=>?@' # 58 .. 64 + . '[\\]^_`' # 91 .. 96 + . '{|}~'; # 123 .. 126 } else { - croak "When base > 62, a collation sequence must be given"; + croak "When base > 94, a collation sequence must be given"; } $collseq = substr $collseq, 0, $class -> _num($base); } @@ -1920,11 +1936,8 @@ comparison routines. =item CLASS-E<gt>api_version() -Return API version as a Perl scalar, 1 for Math::BigInt v1.70, 2 for -Math::BigInt v1.83. - -This method is no longer used. Methods that are not implemented by a subclass -will be inherited from this class. +This method is no longer used and can be omitted. Methods that are not +implemented by a subclass will be inherited from this class. =back @@ -1986,10 +1999,20 @@ COLLSEQ. Each character in STR represents a numerical value identical to the character's position in COLLSEQ. All characters in STR must be present in COLLSEQ. -If BASE is less than or equal to 62, and a collation sequence is not specified, -a default collation sequence consisting of the 62 characters 0..9, A..Z, and -a..z is used. If the default collation sequence is used, and the BASE is less -than or equal to 36, the letter case in STR is ignored. +If BASE is less than or equal to 94, and a collation sequence is not specified, +the following default collation sequence is used. It contains of all the 94 +printable ASCII characters except space/blank: + + 0123456789 # ASCII 48 to 57 + ABCDEFGHIJKLMNOPQRSTUVWXYZ # ASCII 65 to 90 + abcdefghijklmnopqrstuvwxyz # ASCII 97 to 122 + !"#$%&'()*+,-./ # ASCII 33 to 47 + :;<=>?@ # ASCII 58 to 64 + [\]^_` # ASCII 91 to 96 + {|}~ # ASCII 123 to 126 + +If the default collation sequence is used, and the BASE is less than or equal +to 36, the letter case in STR is ignored. For instance, with base 3 and collation sequence "-/|", the character "-" represents 0, "/" represents 1, and "|" represents 2. So if STR is "/|-", the @@ -2005,10 +2028,12 @@ conversion. All examples return 250. Some more examples, all returning 250: - $x = $class -> _from_base("100021", 3, "012") - $x = $class -> _from_base("3322", 4, "0123") - $x = $class -> _from_base("2000", 5, "01234") + $x = $class -> _from_base("100021", 3) + $x = $class -> _from_base("3322", 4) + $x = $class -> _from_base("2000", 5) $x = $class -> _from_base("caaa", 5, "abcde") + $x = $class -> _from_base("42", 62) + $x = $class -> _from_base("2!", 94) =back @@ -2301,6 +2326,10 @@ from the left (most significant digit). If $obj represents the number 123, then CLASS->_digit($obj, 2) # returns 1 CLASS->_digit($obj, -1) # returns 1 +=item CLASS-E<gt>_digitsum(OBJ) + +Returns the sum of the base 10 digits. + =item CLASS-E<gt>_check(OBJ) Returns true if the object is invalid and false otherwise. Preferably, the true @@ -2394,11 +2423,11 @@ L<http://annocpan.org/dist/Math-BigInt> =item * CPAN Ratings -L<http://cpanratings.perl.org/dist/Math-BigInt> +L<https://cpanratings.perl.org/dist/Math-BigInt> -=item * Search CPAN +=item * MetaCPAN -L<http://search.cpan.org/dist/Math-BigInt/> +L<https://metacpan.org/release/Math-BigInt> =item * CPAN Testers Matrix diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Lib/Minimal.pm b/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Lib/Minimal.pm index 73b79d94fbb..f521e52e238 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Lib/Minimal.pm +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/Math/BigInt/Lib/Minimal.pm @@ -17,11 +17,6 @@ my $BASE_LEN = 9; my $BASE = 0 + ("1" . ("0" x $BASE_LEN)); my $MAX_VAL = $BASE - 1; -# Do we need api_version() at all, now that we have a virtual parent class that -# will provide any missing methods? Fixme! - -sub api_version () { 2; } - sub _new { my ($class, $str) = @_; croak "Invalid input string '$str'" unless $str =~ /^([1-9]\d*|0)\z/; @@ -490,529 +485,4 @@ sub _check { return 0; } -############################################################################## -############################################################################## - 1; - -__END__ - -=pod - -=head1 NAME - -Math::BigInt::Calc - Pure Perl module to support Math::BigInt - -=head1 SYNOPSIS - -This library provides support for big integer calculations. It is not -intended to be used by other modules. Other modules which support the same -API (see below) can also be used to support Math::BigInt, like -Math::BigInt::GMP and Math::BigInt::Pari. - -=head1 DESCRIPTION - -In this library, the numbers are represented in base B = 10**N, where N is -the largest possible value that does not cause overflow in the intermediate -computations. The base B elements are stored in an array, with the least -significant element stored in array element zero. There are no leading zero -elements, except a single zero element when the number is zero. - -For instance, if B = 10000, the number 1234567890 is represented internally -as [3456, 7890, 12]. - -=head1 THE Math::BigInt API - -In order to allow for multiple big integer libraries, Math::BigInt was -rewritten to use a plug-in library for core math routines. Any module which -conforms to the API can be used by Math::BigInt by using this in your program: - - use Math::BigInt lib => 'libname'; - -'libname' is either the long name, like 'Math::BigInt::Pari', or only the short -version, like 'Pari'. - -=head2 General Notes - -A library only needs to deal with unsigned big integers. Testing of input -parameter validity is done by the caller, so there is no need to worry about -underflow (e.g., in C<_sub()> and C<_dec()>) nor about division by zero (e.g., -in C<_div()>) or similar cases. - -For some methods, the first parameter can be modified. That includes the -possibility that you return a reference to a completely different object -instead. Although keeping the reference and just changing its contents is -preferred over creating and returning a different reference. - -Return values are always objects, strings, Perl scalars, or true/false for -comparison routines. - -=head2 API version 1 - -The following methods must be defined in order to support the use by -Math::BigInt v1.70 or later. - -=head3 API version - -=over 4 - -=item I<api_version()> - -Return API version as a Perl scalar, 1 for Math::BigInt v1.70, 2 for -Math::BigInt v1.83. - -=back - -=head3 Constructors - -=over 4 - -=item I<_new(STR)> - -Convert a string representing an unsigned decimal number to an object -representing the same number. The input is normalize, i.e., it matches -C<^(0|[1-9]\d*)$>. - -=item I<_zero()> - -Return an object representing the number zero. - -=item I<_one()> - -Return an object representing the number one. - -=item I<_two()> - -Return an object representing the number two. - -=item I<_ten()> - -Return an object representing the number ten. - -=item I<_from_bin(STR)> - -Return an object given a string representing a binary number. The input has a -'0b' prefix and matches the regular expression C<^0[bB](0|1[01]*)$>. - -=item I<_from_oct(STR)> - -Return an object given a string representing an octal number. The input has a -'0' prefix and matches the regular expression C<^0[1-7]*$>. - -=item I<_from_hex(STR)> - -Return an object given a string representing a hexadecimal number. The input -has a '0x' prefix and matches the regular expression -C<^0x(0|[1-9a-fA-F][\da-fA-F]*)$>. - -=back - -=head3 Mathematical functions - -Each of these methods may modify the first input argument, except I<_bgcd()>, -which shall not modify any input argument, and I<_sub()> which may modify the -second input argument. - -=over 4 - -=item I<_add(OBJ1, OBJ2)> - -Returns the result of adding OBJ2 to OBJ1. - -=item I<_mul(OBJ1, OBJ2)> - -Returns the result of multiplying OBJ2 and OBJ1. - -=item I<_div(OBJ1, OBJ2)> - -Returns the result of dividing OBJ1 by OBJ2 and truncating the result to an -integer. - -=item I<_sub(OBJ1, OBJ2, FLAG)> - -=item I<_sub(OBJ1, OBJ2)> - -Returns the result of subtracting OBJ2 by OBJ1. If C<flag> is false or omitted, -OBJ1 might be modified. If C<flag> is true, OBJ2 might be modified. - -=item I<_dec(OBJ)> - -Decrement OBJ by one. - -=item I<_inc(OBJ)> - -Increment OBJ by one. - -=item I<_mod(OBJ1, OBJ2)> - -Return OBJ1 modulo OBJ2, i.e., the remainder after dividing OBJ1 by OBJ2. - -=item I<_sqrt(OBJ)> - -Return the square root of the object, truncated to integer. - -=item I<_root(OBJ, N)> - -Return Nth root of the object, truncated to int. N is E<gt>= 3. - -=item I<_fac(OBJ)> - -Return factorial of object (1*2*3*4*...). - -=item I<_pow(OBJ1, OBJ2)> - -Return OBJ1 to the power of OBJ2. By convention, 0**0 = 1. - -=item I<_modinv(OBJ1, OBJ2)> - -Return modular multiplicative inverse, i.e., return OBJ3 so that - - (OBJ3 * OBJ1) % OBJ2 = 1 % OBJ2 - -The result is returned as two arguments. If the modular multiplicative -inverse does not exist, both arguments are undefined. Otherwise, the -arguments are a number (object) and its sign ("+" or "-"). - -The output value, with its sign, must either be a positive value in the -range 1,2,...,OBJ2-1 or the same value subtracted OBJ2. For instance, if the -input arguments are objects representing the numbers 7 and 5, the method -must either return an object representing the number 3 and a "+" sign, since -(3*7) % 5 = 1 % 5, or an object representing the number 2 and "-" sign, -since (-2*7) % 5 = 1 % 5. - -=item I<_modpow(OBJ1, OBJ2, OBJ3)> - -Return modular exponentiation, (OBJ1 ** OBJ2) % OBJ3. - -=item I<_rsft(OBJ, N, B)> - -Shift object N digits right in base B and return the resulting object. This is -equivalent to performing integer division by B**N and discarding the remainder, -except that it might be much faster, depending on how the number is represented -internally. - -For instance, if the object $obj represents the hexadecimal number 0xabcde, -then C<< $obj->_rsft(2, 16) >> returns an object representing the number 0xabc. -The "remainer", 0xde, is discarded and not returned. - -=item I<_lsft(OBJ, N, B)> - -Shift the object N digits left in base B. This is equivalent to multiplying by -B**N, except that it might be much faster, depending on how the number is -represented internally. - -=item I<_log_int(OBJ, B)> - -Return integer log of OBJ to base BASE. This method has two output arguments, -the OBJECT and a STATUS. The STATUS is Perl scalar; it is 1 if OBJ is the exact -result, 0 if the result was truncted to give OBJ, and undef if it is unknown -whether OBJ is the exact result. - -=item I<_gcd(OBJ1, OBJ2)> - -Return the greatest common divisor of OBJ1 and OBJ2. - -=back - -=head3 Bitwise operators - -Each of these methods may modify the first input argument. - -=over 4 - -=item I<_and(OBJ1, OBJ2)> - -Return bitwise and. If necessary, the smallest number is padded with leading -zeros. - -=item I<_or(OBJ1, OBJ2)> - -Return bitwise or. If necessary, the smallest number is padded with leading -zeros. - -=item I<_xor(OBJ1, OBJ2)> - -Return bitwise exclusive or. If necessary, the smallest number is padded -with leading zeros. - -=back - -=head3 Boolean operators - -=over 4 - -=item I<_is_zero(OBJ)> - -Returns a true value if OBJ is zero, and false value otherwise. - -=item I<_is_one(OBJ)> - -Returns a true value if OBJ is one, and false value otherwise. - -=item I<_is_two(OBJ)> - -Returns a true value if OBJ is two, and false value otherwise. - -=item I<_is_ten(OBJ)> - -Returns a true value if OBJ is ten, and false value otherwise. - -=item I<_is_even(OBJ)> - -Return a true value if OBJ is an even integer, and a false value otherwise. - -=item I<_is_odd(OBJ)> - -Return a true value if OBJ is an even integer, and a false value otherwise. - -=item I<_acmp(OBJ1, OBJ2)> - -Compare OBJ1 and OBJ2 and return -1, 0, or 1, if OBJ1 is less than, equal -to, or larger than OBJ2, respectively. - -=back - -=head3 String conversion - -=over 4 - -=item I<_str(OBJ)> - -Return a string representing the object. The returned string should have no -leading zeros, i.e., it should match C<^(0|[1-9]\d*)$>. - -=item I<_as_bin(OBJ)> - -Return the binary string representation of the number. The string must have a -'0b' prefix. - -=item I<_as_oct(OBJ)> - -Return the octal string representation of the number. The string must have -a '0x' prefix. - -Note: This method was required from Math::BigInt version 1.78, but the required -API version number was not incremented, so there are older libraries that -support API version 1, but do not support C<_as_oct()>. - -=item I<_as_hex(OBJ)> - -Return the hexadecimal string representation of the number. The string must -have a '0x' prefix. - -=back - -=head3 Numeric conversion - -=over 4 - -=item I<_num(OBJ)> - -Given an object, return a Perl scalar number (int/float) representing this -number. - -=back - -=head3 Miscellaneous - -=over 4 - -=item I<_copy(OBJ)> - -Return a true copy of the object. - -=item I<_len(OBJ)> - -Returns the number of the decimal digits in the number. The output is a -Perl scalar. - -=item I<_zeros(OBJ)> - -Return the number of trailing decimal zeros. The output is a Perl scalar. - -=item I<_digit(OBJ, N)> - -Return the Nth digit as a Perl scalar. N is a Perl scalar, where zero refers to -the rightmost (least significant) digit, and negative values count from the -left (most significant digit). If $obj represents the number 123, then -I<$obj->_digit(0)> is 3 and I<_digit(123, -1)> is 1. - -=item I<_check(OBJ)> - -Return a true value if the object is OK, and a false value otherwise. This is a -check routine to test the internal state of the object for corruption. - -=back - -=head2 API version 2 - -The following methods are required for an API version of 2 or greater. - -=head3 Constructors - -=over 4 - -=item I<_1ex(N)> - -Return an object representing the number 10**N where N E<gt>= 0 is a Perl -scalar. - -=back - -=head3 Mathematical functions - -=over 4 - -=item I<_nok(OBJ1, OBJ2)> - -Return the binomial coefficient OBJ1 over OBJ1. - -=back - -=head3 Miscellaneous - -=over 4 - -=item I<_alen(OBJ)> - -Return the approximate number of decimal digits of the object. The output is -one Perl scalar. - -=back - -=head2 API optional methods - -The following methods are optional, and can be defined if the underlying lib -has a fast way to do them. If undefined, Math::BigInt will use pure Perl (hence -slow) fallback routines to emulate these: - -=head3 Signed bitwise operators. - -Each of these methods may modify the first input argument. - -=over 4 - -=item I<_signed_or(OBJ1, OBJ2, SIGN1, SIGN2)> - -Return the signed bitwise or. - -=item I<_signed_and(OBJ1, OBJ2, SIGN1, SIGN2)> - -Return the signed bitwise and. - -=item I<_signed_xor(OBJ1, OBJ2, SIGN1, SIGN2)> - -Return the signed bitwise exclusive or. - -=back - -=head1 WRAP YOUR OWN - -If you want to port your own favourite c-lib for big numbers to the -Math::BigInt interface, you can take any of the already existing modules as a -rough guideline. You should really wrap up the latest Math::BigInt and -Math::BigFloat testsuites with your module, and replace in them any of the -following: - - use Math::BigInt; - -by this: - - use Math::BigInt lib => 'yourlib'; - -This way you ensure that your library really works 100% within Math::BigInt. - -=head1 BUGS - -Please report any bugs or feature requests to -C<bug-math-bigint at rt.cpan.org>, or through the web interface at -L<https://rt.cpan.org/Ticket/Create.html?Queue=Math-BigInt> -(requires login). -We will be notified, and then you'll automatically be notified of progress on -your bug as I make changes. - -=head1 SUPPORT - -You can find documentation for this module with the perldoc command. - - perldoc Math::BigInt::Calc - -You can also look for information at: - -=over 4 - -=item * RT: CPAN's request tracker - -L<https://rt.cpan.org/Public/Dist/Display.html?Name=Math-BigInt> - -=item * AnnoCPAN: Annotated CPAN documentation - -L<http://annocpan.org/dist/Math-BigInt> - -=item * CPAN Ratings - -L<http://cpanratings.perl.org/dist/Math-BigInt> - -=item * Search CPAN - -L<http://search.cpan.org/dist/Math-BigInt/> - -=item * CPAN Testers Matrix - -L<http://matrix.cpantesters.org/?dist=Math-BigInt> - -=item * The Bignum mailing list - -=over 4 - -=item * Post to mailing list - -C<bignum at lists.scsys.co.uk> - -=item * View mailing list - -L<http://lists.scsys.co.uk/pipermail/bignum/> - -=item * Subscribe/Unsubscribe - -L<http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/bignum> - -=back - -=back - -=head1 LICENSE - -This program is free software; you may redistribute it and/or modify it under -the same terms as Perl itself. - -=head1 AUTHORS - -=over 4 - -=item * - -Original math code by Mark Biggar, rewritten by Tels L<http://bloodgate.com/> -in late 2000. - -=item * - -Separated from BigInt and shaped API with the help of John Peacock. - -=item * - -Fixed, speed-up, streamlined and enhanced by Tels 2001 - 2007. - -=item * - -API documentation corrected and extended by Peter John Acklam, -E<lt>pjacklam@online.noE<gt> - -=back - -=head1 SEE ALSO - -L<Math::BigInt>, L<Math::BigFloat>, L<Math::BigInt::GMP>, -L<Math::BigInt::FastCalc> and L<Math::BigInt::Pari>. - -=cut diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/backermann-mbi.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/backermann-mbi.t new file mode 100644 index 00000000000..45fcac6dbd2 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/backermann-mbi.t @@ -0,0 +1,507 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 858; + +my $class; + +BEGIN { + $class = 'Math::BigInt'; + use_ok($class); +} + +can_ok($class, 'backermann', 'ackermann'); + +while (<DATA>) { + s/#.*$//; # remove comments + s/\s+$//; # remove trailing whitespace + next unless length; # skip empty lines + + my ($m, $n, $expected) = split /:/; + + # backermann() modifies the invocand. + + { + my ($x, $y); + my $test = qq|\$x = $class->new("$m"); \$y = \$x->backermann("$n");|; + + subtest $test, + sub { + plan tests => 4; + + eval $test; + is($@, "", "'$test' gives emtpy \$\@"); + + is(ref($y), $class, + "'$test' output arg is a $class"); + + is($y -> bstr(), $expected, + "'$test' output arg has the right value"); + + is($x -> bstr(), $expected, + "'$test' invocand has the right value"); + }; + } + + # ackermann() does not modify the invocand. + + { + my ($x, $y); + my $test = qq|\$x = $class->new("$m"); \$y = \$x->ackermann("$n");|; + + subtest $test, + sub { + plan tests => 4; + + eval $test; + is($@, "", "'$test' gives emtpy \$\@"); + + is(ref($y), $class, + "'$test' output arg is a $class"); + + is($y -> bstr(), $expected, + "'$test' output arg has the right value"); + + is($x -> bstr(), $m, + "'$test' invocand has the right value"); + }; + } +} + +__DATA__ + +0:0:1 +0:1:2 +0:2:3 +0:3:4 +0:4:5 +0:5:6 +0:6:7 +0:7:8 +0:8:9 +0:9:10 +0:10:11 +0:11:12 +0:12:13 +0:13:14 +0:14:15 +0:15:16 +0:16:17 +0:17:18 +0:18:19 +0:19:20 +0:20:21 +0:21:22 +0:22:23 +0:23:24 +0:24:25 +0:25:26 +0:26:27 +0:27:28 +0:28:29 +0:29:30 +0:30:31 +0:31:32 +0:32:33 +0:33:34 +0:34:35 +0:35:36 +0:36:37 +0:37:38 +0:38:39 +0:39:40 +0:40:41 +0:41:42 +0:42:43 +0:43:44 +0:44:45 +0:45:46 +0:46:47 +0:47:48 +0:48:49 +0:49:50 +0:50:51 +0:51:52 +0:52:53 +0:53:54 +0:54:55 +0:55:56 +0:56:57 +0:57:58 +0:58:59 +0:59:60 +0:60:61 +0:61:62 +0:62:63 +0:63:64 +0:64:65 +0:65:66 +0:66:67 +0:67:68 +0:68:69 +0:69:70 +0:70:71 +0:71:72 +0:72:73 +0:73:74 +0:74:75 +0:75:76 +0:76:77 +0:77:78 +0:78:79 +0:79:80 +0:80:81 +0:81:82 +0:82:83 +0:83:84 +0:84:85 +0:85:86 +0:86:87 +0:87:88 +0:88:89 +0:89:90 +0:90:91 +0:91:92 +0:92:93 +0:93:94 +0:94:95 +0:95:96 +0:96:97 +0:97:98 +0:98:99 +0:99:100 +0:100:101 +0:1000:1001 +0:100000:100001 +0:10000000:10000001 +0:10000000000:10000000001 +0:10000000000000:10000000000001 +0:10000000000000000000000000000000000:10000000000000000000000000000000001 +0:12345678987654321012345678987654321:12345678987654321012345678987654322 + +1:0:2 +1:1:3 +1:2:4 +1:3:5 +1:4:6 +1:5:7 +1:6:8 +1:7:9 +1:8:10 +1:9:11 +1:10:12 +1:11:13 +1:12:14 +1:13:15 +1:14:16 +1:15:17 +1:16:18 +1:17:19 +1:18:20 +1:19:21 +1:20:22 +1:21:23 +1:22:24 +1:23:25 +1:24:26 +1:25:27 +1:26:28 +1:27:29 +1:28:30 +1:29:31 +1:30:32 +1:31:33 +1:32:34 +1:33:35 +1:34:36 +1:35:37 +1:36:38 +1:37:39 +1:38:40 +1:39:41 +1:40:42 +1:41:43 +1:42:44 +1:43:45 +1:44:46 +1:45:47 +1:46:48 +1:47:49 +1:48:50 +1:49:51 +1:50:52 +1:51:53 +1:52:54 +1:53:55 +1:54:56 +1:55:57 +1:56:58 +1:57:59 +1:58:60 +1:59:61 +1:60:62 +1:61:63 +1:62:64 +1:63:65 +1:64:66 +1:65:67 +1:66:68 +1:67:69 +1:68:70 +1:69:71 +1:70:72 +1:71:73 +1:72:74 +1:73:75 +1:74:76 +1:75:77 +1:76:78 +1:77:79 +1:78:80 +1:79:81 +1:80:82 +1:81:83 +1:82:84 +1:83:85 +1:84:86 +1:85:87 +1:86:88 +1:87:89 +1:88:90 +1:89:91 +1:90:92 +1:91:93 +1:92:94 +1:93:95 +1:94:96 +1:95:97 +1:96:98 +1:97:99 +1:98:100 +1:99:101 +1:100:102 +1:1000:1002 +1:100000:100002 +1:10000000:10000002 +1:10000000000:10000000002 +1:10000000000000:10000000000002 +1:10000000000000000000000000000000000:10000000000000000000000000000000002 +1:12345678987654321012345678987654321:12345678987654321012345678987654323 + +2:0:3 +2:1:5 +2:2:7 +2:3:9 +2:4:11 +2:5:13 +2:6:15 +2:7:17 +2:8:19 +2:9:21 +2:10:23 +2:11:25 +2:12:27 +2:13:29 +2:14:31 +2:15:33 +2:16:35 +2:17:37 +2:18:39 +2:19:41 +2:20:43 +2:21:45 +2:22:47 +2:23:49 +2:24:51 +2:25:53 +2:26:55 +2:27:57 +2:28:59 +2:29:61 +2:30:63 +2:31:65 +2:32:67 +2:33:69 +2:34:71 +2:35:73 +2:36:75 +2:37:77 +2:38:79 +2:39:81 +2:40:83 +2:41:85 +2:42:87 +2:43:89 +2:44:91 +2:45:93 +2:46:95 +2:47:97 +2:48:99 +2:49:101 +2:50:103 +2:51:105 +2:52:107 +2:53:109 +2:54:111 +2:55:113 +2:56:115 +2:57:117 +2:58:119 +2:59:121 +2:60:123 +2:61:125 +2:62:127 +2:63:129 +2:64:131 +2:65:133 +2:66:135 +2:67:137 +2:68:139 +2:69:141 +2:70:143 +2:71:145 +2:72:147 +2:73:149 +2:74:151 +2:75:153 +2:76:155 +2:77:157 +2:78:159 +2:79:161 +2:80:163 +2:81:165 +2:82:167 +2:83:169 +2:84:171 +2:85:173 +2:86:175 +2:87:177 +2:88:179 +2:89:181 +2:90:183 +2:91:185 +2:92:187 +2:93:189 +2:94:191 +2:95:193 +2:96:195 +2:97:197 +2:98:199 +2:99:201 +2:100:203 +2:1000:2003 +2:100000:200003 +2:10000000:20000003 +2:10000000000:20000000003 +2:10000000000000:20000000000003 +2:10000000000000000000000000000000000:20000000000000000000000000000000003 +2:12345678987654321012345678987654321:24691357975308642024691357975308645 + +3:0:5 +3:1:13 +3:2:29 +3:3:61 +3:4:125 +3:5:253 +3:6:509 +3:7:1021 +3:8:2045 +3:9:4093 +3:10:8189 +3:11:16381 +3:12:32765 +3:13:65533 +3:14:131069 +3:15:262141 +3:16:524285 +3:17:1048573 +3:18:2097149 +3:19:4194301 +3:20:8388605 +3:21:16777213 +3:22:33554429 +3:23:67108861 +3:24:134217725 +3:25:268435453 +3:26:536870909 +3:27:1073741821 +3:28:2147483645 +3:29:4294967293 +3:30:8589934589 +3:31:17179869181 +3:32:34359738365 +3:33:68719476733 +3:34:137438953469 +3:35:274877906941 +3:36:549755813885 +3:37:1099511627773 +3:38:2199023255549 +3:39:4398046511101 +3:40:8796093022205 +3:41:17592186044413 +3:42:35184372088829 +3:43:70368744177661 +3:44:140737488355325 +3:45:281474976710653 +3:46:562949953421309 +3:47:1125899906842621 +3:48:2251799813685245 +3:49:4503599627370493 +3:50:9007199254740989 +3:51:18014398509481981 +3:52:36028797018963965 +3:53:72057594037927933 +3:54:144115188075855869 +3:55:288230376151711741 +3:56:576460752303423485 +3:57:1152921504606846973 +3:58:2305843009213693949 +3:59:4611686018427387901 +3:60:9223372036854775805 +3:61:18446744073709551613 +3:62:36893488147419103229 +3:63:73786976294838206461 +3:64:147573952589676412925 +3:65:295147905179352825853 +3:66:590295810358705651709 +3:67:1180591620717411303421 +3:68:2361183241434822606845 +3:69:4722366482869645213693 +3:70:9444732965739290427389 +3:71:18889465931478580854781 +3:72:37778931862957161709565 +3:73:75557863725914323419133 +3:74:151115727451828646838269 +3:75:302231454903657293676541 +3:76:604462909807314587353085 +3:77:1208925819614629174706173 +3:78:2417851639229258349412349 +3:79:4835703278458516698824701 +3:80:9671406556917033397649405 +3:81:19342813113834066795298813 +3:82:38685626227668133590597629 +3:83:77371252455336267181195261 +3:84:154742504910672534362390525 +3:85:309485009821345068724781053 +3:86:618970019642690137449562109 +3:87:1237940039285380274899124221 +3:88:2475880078570760549798248445 +3:89:4951760157141521099596496893 +3:90:9903520314283042199192993789 +3:91:19807040628566084398385987581 +3:92:39614081257132168796771975165 +3:93:79228162514264337593543950333 +3:94:158456325028528675187087900669 +3:95:316912650057057350374175801341 +3:96:633825300114114700748351602685 +3:97:1267650600228229401496703205373 +3:98:2535301200456458802993406410749 +3:99:5070602400912917605986812821501 +3:100:10141204801825835211973625643005 + +4:0:13 +4:1:65533 + +5:0:65533 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/bdigitsum-mbi.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bdigitsum-mbi.t new file mode 100644 index 00000000000..45c9bd72565 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/bdigitsum-mbi.t @@ -0,0 +1,113 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 48; + +use Math::BigInt; + +my $x; +my $y; + +############################################################################### +# bdigitsum() + +# Finite numbers. + +$x = Math::BigInt -> new("123"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> bdigitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "6"); +is($y, "6"); + +$x = Math::BigInt -> new("0"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> bdigitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "0"); +is($y, "0"); + +$x = Math::BigInt -> new("-123"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> bdigitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "6"); +is($y, "6"); + +# Infinity + +$x = Math::BigInt -> binf("+"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> bdigitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "NaN"); +is($y, "NaN"); + +$x = Math::BigInt -> binf("-"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> bdigitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "NaN"); +is($y, "NaN"); + +# NaN + +$x = Math::BigInt -> bnan(); +isa_ok($x, 'Math::BigInt'); +$y = $x -> bdigitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "NaN"); +is($y, "NaN"); + +############################################################################### +# digitsum() + +# Finite numbers. + +$x = Math::BigInt -> new("123"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> digitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "123"); +is($y, "6"); + +$x = Math::BigInt -> new("0"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> digitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "0"); +is($y, "0"); + +$x = Math::BigInt -> new("-123"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> digitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "-123"); +is($y, "6"); + +# Infinity + +$x = Math::BigInt -> binf("+"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> digitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "inf"); +is($y, "NaN"); + +$x = Math::BigInt -> binf("-"); +isa_ok($x, 'Math::BigInt'); +$y = $x -> digitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "-inf"); +is($y, "NaN"); + +# NaN + +$x = Math::BigInt -> bnan(); +isa_ok($x, 'Math::BigInt'); +$y = $x -> digitsum(); +isa_ok($y, 'Math::BigInt'); +is($x, "NaN"); +is($y, "NaN"); diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/buparrow-mbi.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/buparrow-mbi.t new file mode 100644 index 00000000000..c2eb2eec614 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/buparrow-mbi.t @@ -0,0 +1,581 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 1021; + +my $class; + +BEGIN { + $class = 'Math::BigInt'; + use_ok($class); +} + +while (<DATA>) { + s/#.*$//; # remove comments + s/\s+$//; # remove trailing whitespace + next unless length; # skip empty lines + + my ($a, $n, $b, $expected) = split /:/; + + # buparrow() modifies the invocand. + + { + my ($x, $y); + my $test = qq|\$x = $class->new("$a"); \$y = \$x->buparrow($n, $b);|; + + subtest $test, + sub { + plan tests => 4; + + eval $test; + is($@, "", "'$test' gives emtpy \$\@"); + + is(ref($y), $class, + "'$test' output arg is a $class"); + + is($y -> bstr(), $expected, + "'$test' output arg has the right value"); + + is($x -> bstr(), $expected, + "'$test' invocand has the right value"); + }; + } + + # uparrow() does not modify the invocand. + + { + my ($x, $y); + my $test = qq|\$x = $class->new("$a"); \$y = \$x->uparrow($n, $b);|; + + subtest $test, + sub { + plan tests => 4; + + eval $test; + is($@, "", "'$test' gives emtpy \$\@"); + + is(ref($y), $class, + "'$test' output arg is a $class"); + + is($y -> bstr(), $expected, + "'$test' output arg has the right value"); + + is($x -> bstr(), $a, + "'$test' invocand has the right value"); + }; + } +} + +__DATA__ +0:0:0:0 +0:0:1:0 +0:0:2:0 +0:0:3:0 +0:0:4:0 +0:0:5:0 +0:0:6:0 +0:0:7:0 +0:0:8:0 +0:0:9:0 +0:1:0:1 +0:1:1:0 +0:1:2:0 +0:1:3:0 +0:1:4:0 +0:1:5:0 +0:1:6:0 +0:1:7:0 +0:1:8:0 +0:1:9:0 +0:2:0:1 +0:2:1:0 +0:2:2:1 +0:2:3:0 +0:2:4:1 +0:2:5:0 +0:2:6:1 +0:2:7:0 +0:2:8:1 +0:2:9:0 +0:3:0:1 +0:3:1:0 +0:3:2:1 +0:3:3:0 +0:3:4:1 +0:3:5:0 +0:3:6:1 +0:3:7:0 +0:3:8:1 +0:3:9:0 +0:4:0:1 +0:4:1:0 +0:4:2:1 +0:4:3:0 +0:4:4:1 +0:4:5:0 +0:4:6:1 +0:4:7:0 +0:4:8:1 +0:4:9:0 +0:5:0:1 +0:5:1:0 +0:5:2:1 +0:5:3:0 +0:5:4:1 +0:5:5:0 +0:5:6:1 +0:5:7:0 +0:5:8:1 +0:5:9:0 +0:6:0:1 +0:6:1:0 +0:6:2:1 +0:6:3:0 +0:6:4:1 +0:6:5:0 +0:6:6:1 +0:6:7:0 +0:6:8:1 +0:6:9:0 +0:7:0:1 +0:7:1:0 +0:7:2:1 +0:7:3:0 +0:7:4:1 +0:7:5:0 +0:7:6:1 +0:7:7:0 +0:7:8:1 +0:7:9:0 +0:8:0:1 +0:8:1:0 +0:8:2:1 +0:8:3:0 +0:8:4:1 +0:8:5:0 +0:8:6:1 +0:8:7:0 +0:8:8:1 +0:8:9:0 +0:9:0:1 +0:9:1:0 +0:9:2:1 +0:9:3:0 +0:9:4:1 +0:9:5:0 +0:9:6:1 +0:9:7:0 +0:9:8:1 +0:9:9:0 +1:0:0:0 +1:0:1:1 +1:0:2:2 +1:0:3:3 +1:0:4:4 +1:0:5:5 +1:0:6:6 +1:0:7:7 +1:0:8:8 +1:0:9:9 +1:1:0:1 +1:1:1:1 +1:1:2:1 +1:1:3:1 +1:1:4:1 +1:1:5:1 +1:1:6:1 +1:1:7:1 +1:1:8:1 +1:1:9:1 +1:2:0:1 +1:2:1:1 +1:2:2:1 +1:2:3:1 +1:2:4:1 +1:2:5:1 +1:2:6:1 +1:2:7:1 +1:2:8:1 +1:2:9:1 +1:3:0:1 +1:3:1:1 +1:3:2:1 +1:3:3:1 +1:3:4:1 +1:3:5:1 +1:3:6:1 +1:3:7:1 +1:3:8:1 +1:3:9:1 +1:4:0:1 +1:4:1:1 +1:4:2:1 +1:4:3:1 +1:4:4:1 +1:4:5:1 +1:4:6:1 +1:4:7:1 +1:4:8:1 +1:4:9:1 +1:5:0:1 +1:5:1:1 +1:5:2:1 +1:5:3:1 +1:5:4:1 +1:5:5:1 +1:5:6:1 +1:5:7:1 +1:5:8:1 +1:5:9:1 +1:6:0:1 +1:6:1:1 +1:6:2:1 +1:6:3:1 +1:6:4:1 +1:6:5:1 +1:6:6:1 +1:6:7:1 +1:6:8:1 +1:6:9:1 +1:7:0:1 +1:7:1:1 +1:7:2:1 +1:7:3:1 +1:7:4:1 +1:7:5:1 +1:7:6:1 +1:7:7:1 +1:7:8:1 +1:7:9:1 +1:8:0:1 +1:8:1:1 +1:8:2:1 +1:8:3:1 +1:8:4:1 +1:8:5:1 +1:8:6:1 +1:8:7:1 +1:8:8:1 +1:8:9:1 +1:9:0:1 +1:9:1:1 +1:9:2:1 +1:9:3:1 +1:9:4:1 +1:9:5:1 +1:9:6:1 +1:9:7:1 +1:9:8:1 +1:9:9:1 +2:0:0:0 +2:0:1:2 +2:0:2:4 +2:0:3:6 +2:0:4:8 +2:0:5:10 +2:0:6:12 +2:0:7:14 +2:0:8:16 +2:0:9:18 +2:1:0:1 +2:1:1:2 +2:1:2:4 +2:1:3:8 +2:1:4:16 +2:1:5:32 +2:1:6:64 +2:1:7:128 +2:1:8:256 +2:1:9:512 +2:2:0:1 +2:2:1:2 +2:2:2:4 +2:2:3:16 +2:2:4:65536 +2:3:0:1 +2:3:1:2 +2:3:2:4 +2:3:3:65536 +2:4:0:1 +2:4:1:2 +2:4:2:4 +2:5:0:1 +2:5:1:2 +2:5:2:4 +2:6:0:1 +2:6:1:2 +2:6:2:4 +2:7:0:1 +2:7:1:2 +2:7:2:4 +2:8:0:1 +2:8:1:2 +2:8:2:4 +2:9:0:1 +2:9:1:2 +2:9:2:4 +3:0:0:0 +3:0:1:3 +3:0:2:6 +3:0:3:9 +3:0:4:12 +3:0:5:15 +3:0:6:18 +3:0:7:21 +3:0:8:24 +3:0:9:27 +3:1:0:1 +3:1:1:3 +3:1:2:9 +3:1:3:27 +3:1:4:81 +3:1:5:243 +3:1:6:729 +3:1:7:2187 +3:1:8:6561 +3:1:9:19683 +3:2:0:1 +3:2:1:3 +3:2:2:27 +3:2:3:7625597484987 +3:3:0:1 +3:3:1:3 +3:3:2:7625597484987 +3:4:0:1 +3:4:1:3 +3:5:0:1 +3:5:1:3 +3:6:0:1 +3:6:1:3 +3:7:0:1 +3:7:1:3 +3:8:0:1 +3:8:1:3 +3:9:0:1 +3:9:1:3 +4:0:0:0 +4:0:1:4 +4:0:2:8 +4:0:3:12 +4:0:4:16 +4:0:5:20 +4:0:6:24 +4:0:7:28 +4:0:8:32 +4:0:9:36 +4:1:0:1 +4:1:1:4 +4:1:2:16 +4:1:3:64 +4:1:4:256 +4:1:5:1024 +4:1:6:4096 +4:1:7:16384 +4:1:8:65536 +4:1:9:262144 +4:2:0:1 +4:2:1:4 +4:2:2:256 +4:2:3:13407807929942597099574024998205846127479365820592393377723561443721764030073546976801874298166903427690031858186486050853753882811946569946433649006084096 +4:3:0:1 +4:3:1:4 +4:4:0:1 +4:4:1:4 +4:5:0:1 +4:5:1:4 +4:6:0:1 +4:6:1:4 +4:7:0:1 +4:7:1:4 +4:8:0:1 +4:8:1:4 +4:9:0:1 +4:9:1:4 +5:0:0:0 +5:0:1:5 +5:0:2:10 +5:0:3:15 +5:0:4:20 +5:0:5:25 +5:0:6:30 +5:0:7:35 +5:0:8:40 +5:0:9:45 +5:1:0:1 +5:1:1:5 +5:1:2:25 +5:1:3:125 +5:1:4:625 +5:1:5:3125 +5:1:6:15625 +5:1:7:78125 +5:1:8:390625 +5:1:9:1953125 +5:2:0:1 +5:2:1:5 +5:2:2:3125 +5:2:3:1911012597945477520356404559703964599198081048990094337139512789246520530242615803012059386519739850265586440155794462235359212788673806972288410146915986602087961896757195701839281660338047611225975533626101001482651123413147768252411493094447176965282756285196737514395357542479093219206641883011787169122552421070050709064674382870851449950256586194461543183511379849133691779928127433840431549236855526783596374102105331546031353725325748636909159778690328266459182983815230286936572873691422648131291743762136325730321645282979486862576245362218017673224940567642819360078720713837072355305446356153946401185348493792719514594505508232749221605848912910945189959948686199543147666938013037176163592594479746164220050885079469804487133205133160739134230540198872570038329801246050197013467397175909027389493923817315786996845899794781068042822436093783946335265422815704302832442385515082316490967285712171708123232790481817268327510112746782317410985888683708522000711733492253913322300756147180429007527677793352306200618286012455254243061006894805446584704820650982664319360960388736258510747074340636286976576702699258649953557976318173902550891331223294743930343956161328334072831663498258145226862004307799084688103804187368324800903873596212919633602583120781673673742533322879296907205490595621406888825991244581842379597863476484315673760923625090371511798941424262270220066286486867868710182980872802560693101949280830825044198424796792058908817112327192301455582916746795197430548026404646854002733993860798594465961501752586965811447568510041568687730903712482535343839285397598749458497050038225012489284001826590056251286187629938044407340142347062055785305325034918189589707199305662188512963187501743535960282201038211616048545121039313312256332260766436236688296850208839496142830484739113991669622649948563685234712873294796680884509405893951104650944137909502276545653133018670633521323028460519434381399810561400652595300731790772711065783494174642684720956134647327748584238274899668755052504394218232191357223054066715373374248543645663782045701654593218154053548393614250664498585403307466468541890148134347714650315037954175778622811776585876941680908203125 +5:3:0:1 +5:3:1:5 +5:4:0:1 +5:4:1:5 +5:5:0:1 +5:5:1:5 +5:6:0:1 +5:6:1:5 +5:7:0:1 +5:7:1:5 +5:8:0:1 +5:8:1:5 +5:9:0:1 +5:9:1:5 +6:0:0:0 +6:0:1:6 +6:0:2:12 +6:0:3:18 +6:0:4:24 +6:0:5:30 +6:0:6:36 +6:0:7:42 +6:0:8:48 +6:0:9:54 +6:1:0:1 +6:1:1:6 +6:1:2:36 +6:1:3:216 +6:1:4:1296 +6:1:5:7776 +6:1:6:46656 +6:1:7:279936 +6:1:8:1679616 +6:1:9:10077696 +6:2:0:1 +6:2:1:6 +6:2:2:46656 +6:3:0:1 +6:3:1:6 +6:4:0:1 +6:4:1:6 +6:5:0:1 +6:5:1:6 +6:6:0:1 +6:6:1:6 +6:7:0:1 +6:7:1:6 +6:8:0:1 +6:8:1:6 +6:9:0:1 +6:9:1:6 +7:0:0:0 +7:0:1:7 +7:0:2:14 +7:0:3:21 +7:0:4:28 +7:0:5:35 +7:0:6:42 +7:0:7:49 +7:0:8:56 +7:0:9:63 +7:1:0:1 +7:1:1:7 +7:1:2:49 +7:1:3:343 +7:1:4:2401 +7:1:5:16807 +7:1:6:117649 +7:1:7:823543 +7:1:8:5764801 +7:1:9:40353607 +7:2:0:1 +7:2:1:7 +7:2:2:823543 +7:3:0:1 +7:3:1:7 +7:4:0:1 +7:4:1:7 +7:5:0:1 +7:5:1:7 +7:6:0:1 +7:6:1:7 +7:7:0:1 +7:7:1:7 +7:8:0:1 +7:8:1:7 +7:9:0:1 +7:9:1:7 +8:0:0:0 +8:0:1:8 +8:0:2:16 +8:0:3:24 +8:0:4:32 +8:0:5:40 +8:0:6:48 +8:0:7:56 +8:0:8:64 +8:0:9:72 +8:1:0:1 +8:1:1:8 +8:1:2:64 +8:1:3:512 +8:1:4:4096 +8:1:5:32768 +8:1:6:262144 +8:1:7:2097152 +8:1:8:16777216 +8:1:9:134217728 +8:2:0:1 +8:2:1:8 +8:2:2:16777216 +8:3:0:1 +8:3:1:8 +8:4:0:1 +8:4:1:8 +8:5:0:1 +8:5:1:8 +8:6:0:1 +8:6:1:8 +8:7:0:1 +8:7:1:8 +8:8:0:1 +8:8:1:8 +8:9:0:1 +8:9:1:8 +9:0:0:0 +9:0:1:9 +9:0:2:18 +9:0:3:27 +9:0:4:36 +9:0:5:45 +9:0:6:54 +9:0:7:63 +9:0:8:72 +9:0:9:81 +9:1:0:1 +9:1:1:9 +9:1:2:81 +9:1:3:729 +9:1:4:6561 +9:1:5:59049 +9:1:6:531441 +9:1:7:4782969 +9:1:8:43046721 +9:1:9:387420489 +9:2:0:1 +9:2:1:9 +9:2:2:387420489 +9:3:0:1 +9:3:1:9 +9:4:0:1 +9:4:1:9 +9:5:0:1 +9:5:1:9 +9:6:0:1 +9:6:1:9 +9:7:0:1 +9:7:1:9 +9:8:0:1 +9:8:1:9 +9:9:0:1 +9:9:1:9 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-class-methods.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-class-methods.t index 1bc0f6a2663..27ada2eb0c6 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-class-methods.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-class-methods.t @@ -5,7 +5,7 @@ use strict; use warnings; -use Test::More tests => 148; +use Test::More tests => 164; ############################################################################## @@ -76,6 +76,12 @@ __END__ &is_negative 1:0 -1:1 +&is_non_positive +1:0 +-1:1 +&is_non_negative +1:1 +-1:0 &is_nan abc:1 1:0 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-instance-methods.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-instance-methods.t index 8b0945e72af..30421da67b9 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-instance-methods.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/calling-instance-methods.t @@ -5,7 +5,7 @@ use strict; use warnings; -use Test::More tests => 140; +use Test::More tests => 156; ############################################################################## @@ -76,6 +76,12 @@ __END__ &is_negative 1:0 -1:1 +&is_non_positive +1:0 +-1:1 +&is_non_negative +1:1 +-1:0 &is_nan abc:1 1:0 diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/from_ieee754-mbf.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/from_ieee754-mbf.t new file mode 100644 index 00000000000..99dd6e1e071 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/from_ieee754-mbf.t @@ -0,0 +1,257 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 230; + +use Math::BigFloat; + +my @k = (16, 32, 64, 128); + +sub stringify { + my $x = shift; + return "$x" unless $x -> is_finite(); + my $nstr = $x -> bnstr(); + my $sstr = $x -> bsstr(); + return length($nstr) < length($sstr) ? $nstr : $sstr; +} + +for my $k (@k) { + + # Parameters specific to this format: + + my $b = 2; + my $p = $k == 16 ? 11 + : $k == 32 ? 24 + : $k == 64 ? 53 + : $k - sprintf("%.0f", 4 * log($k)/log(2)) + 13; + + $b = Math::BigFloat -> new($b); + $k = Math::BigFloat -> new($k); + $p = Math::BigFloat -> new($p); + my $w = $k - $p; + + my $emax = 2 ** ($w - 1) - 1; + my $emin = 1 - $emax; + + my $format = sprintf 'binary%u', $k; + + my $binv = Math::BigFloat -> new("0.5"); + + my $data = + [ + + { + dsc => "smallest positive subnormal number", + bin => "0" + . ("0" x $w) + . ("0" x ($p - 2)) . "1", + asc => "$b ** ($emin) * $b ** (" . (1 - $p) . ") " + . "= $b ** (" . ($emin + 1 - $p) . ")", + mbf => $binv ** ($p - 1 - $emin), + }, + + { + dsc => "largest subnormal number", + bin => "0" + . ("0" x $w) + . ("1" x ($p - 1)), + asc => "$b ** ($emin) * (1 - $b ** (" . (1 - $p) . "))", + mbf => $binv ** (-$emin) * (1 - $binv ** ($p - 1)), + }, + + { + dsc => "smallest positive normal number", + bin => "0" + . ("0" x ($w - 1)) . "1" + . ("0" x ($p - 1)), + asc => "$b ** ($emin)", + mbf => $binv ** (-$emin), + }, + + { + dsc => "largest normal number", + bin => "0" + . ("1" x ($w - 1)) . "0" + . "1" x ($p - 1), + asc => "$b ** $emax * ($b - $b ** (" . (1 - $p) . "))", + mbf => $b ** $emax * ($b - $binv ** ($p - 1)), + }, + + { + dsc => "largest number less than one", + bin => "0" + . "0" . ("1" x ($w - 2)) . "0" + . "1" x ($p - 1), + asc => "1 - $b ** (-$p)", + mbf => 1 - $binv ** $p, + }, + + { + dsc => "smallest number larger than one", + bin => "0" + . "0" . ("1" x ($w - 1)) + . ("0" x ($p - 2)) . "1", + asc => "1 + $b ** (" . (1 - $p) . ")", + mbf => 1 + $binv ** ($p - 1), + }, + + { + dsc => "second smallest number larger than one", + bin => "0" + . "0" . ("1" x ($w - 1)) + . ("0" x ($p - 3)) . "10", + asc => "1 + $b ** (" . (2 - $p) . ")", + mbf => 1 + $binv ** ($p - 2), + }, + + { + dsc => "one", + bin => "0" + . "0" . ("1" x ($w - 1)) + . "0" x ($p - 1), + asc => "1", + mbf => Math::BigFloat -> new("1"), + }, + + { + dsc => "minus one", + bin => "1" + . "0" . ("1" x ($w - 1)) + . "0" x ($p - 1), + asc => "-1", + mbf => Math::BigFloat -> new("-1"), + }, + + { + dsc => "two", + bin => "0" + . "1" . ("0" x ($w - 1)) + . ("0" x ($p - 1)), + asc => "2", + mbf => Math::BigFloat -> new("2"), + }, + + { + dsc => "minus two", + bin => "1" + . "1" . ("0" x ($w - 1)) + . ("0" x ($p - 1)), + asc => "-2", + mbf => Math::BigFloat -> new("-2"), + }, + + { + dsc => "positive zero", + bin => "0" + . ("0" x $w) + . ("0" x ($p - 1)), + asc => "+0", + mbf => Math::BigFloat -> new("0"), + }, + + { + dsc => "negative zero", + bin => "1" + . ("0" x $w) + . ("0" x ($p - 1)), + asc => "-0", + mbf => Math::BigFloat -> new("0"), + }, + + { + dsc => "positive infinity", + bin => "0" + . ("1" x $w) + . ("0" x ($p - 1)), + asc => "+inf", + mbf => Math::BigFloat -> new("inf"), + }, + + { + dsc => "negative infinity", + bin => "1" + . ("1" x $w) + . ("0" x ($p - 1)), + asc => "-inf", + mbf => Math::BigFloat -> new("-inf"), + }, + + { + dsc => "NaN (sNaN on most processors, such as x86 and ARM)", + bin => "0" + . ("1" x $w) + . ("0" x ($p - 2)) . "1", + asc => "sNaN", + mbf => Math::BigFloat -> new("NaN"), + }, + + { + dsc => "NaN (qNaN on most processors, such as x86 and ARM)", + bin => "0" + . ("1" x $w) + . "1" . ("0" x ($p - 3)) . "1", + asc => "qNaN", + mbf => Math::BigFloat -> new("NaN"), + }, + + { + dsc => "NaN (an alternative encoding)", + bin => "0" + . ("1" x $w) + . ("1" x ($p - 1)), + asc => "NaN", + mbf => Math::BigFloat -> new("NaN"), + }, + + { + dsc => "NaN (encoding used by Perl on Cygwin)", + bin => "1" + . ("1" x $w) + . ("1" . ("0" x ($p - 2))), + asc => "NaN", + mbf => Math::BigFloat -> new("NaN"), + }, + + ]; + + for my $entry (@$data) { + my $bin = $entry -> {bin}; + my $bytes = pack "B*", $bin; + my $hex = unpack "H*", $bytes; + + note("\n", $entry -> {dsc }, " (k = $k)\n\n"); + + my $expected = stringify($entry -> {mbf}); + my ($got, $test); + + $got = Math::BigFloat -> from_ieee754($bin, $format); + $got = stringify($got); + $test = qq|Math::BigFloat->from_ieee754("$bin")|; + is($got, $expected, $test); + + $got = Math::BigFloat -> from_ieee754($hex, $format); + $got = stringify($got); + $test = qq|Math::BigFloat->from_ieee754("$hex")|; + is($got, $expected, $test); + + $got = Math::BigFloat -> from_ieee754($bytes, $format); + $got = stringify($got); + (my $str = $hex) =~ s/(..)/\\x$1/g; + $test = qq|Math::BigFloat->from_ieee754("$str")|; + is($got, $expected, $test); + } +} + +note("\nTest as class method vs. instance method.\n\n"); + +# As class method. + +my $x = Math::BigFloat -> from_ieee754("4000000000000000", "binary64"); +is($x, 2, "class method"); + +# As instance method, the invocand should be modified. + +$x -> from_ieee754("4008000000000000", "binary64"); +is($x, 3, "instance method modifies invocand"); diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/new-mbf.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/new-mbf.t index d1edfd45ff6..547a69ca4b0 100644 --- a/gnu/usr.bin/perl/cpan/Math-BigInt/t/new-mbf.t +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/new-mbf.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 50; +use Test::More tests => 69; my $class; @@ -81,6 +81,43 @@ infinity:inf #-inf:NaN 0x.p+0:NaN +# This is more or less the same data as in from_oct-mbf.t, except that some of +# them are commented out, since new() only treats input as octal if it has a +# "0" prefix and a binary exponent, and possibly a leading "+" or "-" sign. +# Duplicates from above are also commented out. + +01p+0:1 +00.4p+1:1 +00.2p+2:1 +00.1p+3:1 +00.04p+4:1 +02p-1:1 +04p-2:1 +010p-3:1 + +-01p+0:-1 + +00p+0:0 +00p+7:0 +00p-7:0 +00.p+0:0 +00.0p+0:0 +#00.0p+0:0 + +#145376:51966 +#0145376:51966 +#00145376:51966 + +03.1p+2:12.5 +022.15p-1:9.1015625 +-00.361152746757p+32:-2023406814.9375 +044.3212636115p+30:39093746765 + +#NaN:NaN +#+inf:NaN +#-inf:NaN +0.p+0:NaN + # This is the same data as in from_bin-mbf.t, except that some of them are # commented out, since new() only treats input as binary if it has a "0b" or # "0B" prefix, possibly with a leading "+" or "-" sign. Duplicates from above diff --git a/gnu/usr.bin/perl/cpan/Math-BigInt/t/to_ieee754-mbf.t b/gnu/usr.bin/perl/cpan/Math-BigInt/t/to_ieee754-mbf.t new file mode 100644 index 00000000000..1f043f9ea6a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Math-BigInt/t/to_ieee754-mbf.t @@ -0,0 +1,206 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 60; + +use Math::BigFloat; + +my @k = (16, 32, 64, 128); + +sub stringify { + my $x = shift; + return "$x" unless $x -> is_finite(); + my $nstr = $x -> bnstr(); + my $sstr = $x -> bsstr(); + return length($nstr) < length($sstr) ? $nstr : $sstr; +} + +for my $k (@k) { + + # Parameters specific to this format: + + my $b = 2; + my $p = $k == 16 ? 11 + : $k == 32 ? 24 + : $k == 64 ? 53 + : $k - sprintf("%.0f", 4 * log($k)/log(2)) + 13; + + $b = Math::BigFloat -> new($b); + $k = Math::BigFloat -> new($k); + $p = Math::BigFloat -> new($p); + my $w = $k - $p; + + my $emax = 2 ** ($w - 1) - 1; + my $emin = 1 - $emax; + + my $format = 'binary' . $k; + + note("\nComputing test data for k = $k ...\n\n"); + + my $binv = Math::BigFloat -> new("0.5"); + + my $data = + [ + + { + dsc => "smallest positive subnormal number", + bin => "0" + . ("0" x $w) + . ("0" x ($p - 2)) . "1", + asc => "$b ** ($emin) * $b ** (" . (1 - $p) . ") " + . "= $b ** (" . ($emin + 1 - $p) . ")", + mbf => $binv ** ($p - 1 - $emin), + }, + + { + dsc => "largest subnormal number", + bin => "0" + . ("0" x $w) + . ("1" x ($p - 1)), + asc => "$b ** ($emin) * (1 - $b ** (" . (1 - $p) . "))", + mbf => $binv ** (-$emin) * (1 - $binv ** ($p - 1)), + }, + + { + dsc => "smallest positive normal number", + bin => "0" + . ("0" x ($w - 1)) . "1" + . ("0" x ($p - 1)), + asc => "$b ** ($emin)", + mbf => $binv ** (-$emin), + }, + + { + dsc => "largest normal number", + bin => "0" + . ("1" x ($w - 1)) . "0" + . "1" x ($p - 1), + asc => "$b ** $emax * ($b - $b ** (" . (1 - $p) . "))", + mbf => $b ** $emax * ($b - $binv ** ($p - 1)), + }, + + { + dsc => "largest number less than one", + bin => "0" + . "0" . ("1" x ($w - 2)) . "0" + . "1" x ($p - 1), + asc => "1 - $b ** (-$p)", + mbf => 1 - $binv ** $p, + }, + + { + dsc => "smallest number larger than one", + bin => "0" + . "0" . ("1" x ($w - 1)) + . ("0" x ($p - 2)) . "1", + asc => "1 + $b ** (" . (1 - $p) . ")", + mbf => 1 + $binv ** ($p - 1), + }, + + { + dsc => "second smallest number larger than one", + bin => "0" + . "0" . ("1" x ($w - 1)) + . ("0" x ($p - 3)) . "10", + asc => "1 + $b ** (" . (2 - $p) . ")", + mbf => 1 + $binv ** ($p - 2), + }, + + { + dsc => "one", + bin => "0" + . "0" . ("1" x ($w - 1)) + . "0" x ($p - 1), + asc => "1", + mbf => Math::BigFloat -> new("1"), + }, + + { + dsc => "minus one", + bin => "1" + . "0" . ("1" x ($w - 1)) + . "0" x ($p - 1), + asc => "-1", + mbf => Math::BigFloat -> new("-1"), + }, + + { + dsc => "two", + bin => "0" + . "1" . ("0" x ($w - 1)) + . ("0" x ($p - 1)), + asc => "2", + mbf => Math::BigFloat -> new("2"), + }, + + { + dsc => "minus two", + bin => "1" + . "1" . ("0" x ($w - 1)) + . ("0" x ($p - 1)), + asc => "-2", + mbf => Math::BigFloat -> new("-2"), + }, + + { + dsc => "positive zero", + bin => "0" + . ("0" x $w) + . ("0" x ($p - 1)), + asc => "+0", + mbf => Math::BigFloat -> new("0"), + }, + + { + dsc => "positive infinity", + bin => "0" + . ("1" x $w) + . ("0" x ($p - 1)), + asc => "+inf", + mbf => Math::BigFloat -> new("inf"), + }, + + { + dsc => "negative infinity", + bin => "1" + . ("1" x $w) + . ("0" x ($p - 1)), + asc => "-inf", + mbf => Math::BigFloat -> new("-inf"), + }, + + { + dsc => "NaN (encoding used by Perl on Cygwin)", + bin => "1" + . ("1" x $w) + . ("1" . ("0" x ($p - 2))), + asc => "NaN", + mbf => Math::BigFloat -> new("NaN"), + }, + + ]; + + for my $entry (@$data) { + my $bin = $entry -> {bin}; + my $bytes = pack "B*", $bin; + my $hex = unpack "H*", $bytes; + + note("\n", $entry -> {dsc}, " (k = $k): ", $entry -> {asc}, "\n\n"); + + my $x = Math::BigFloat -> new($entry -> {mbf}); + + my $test = qq|Math::BigFloat -> new("| . stringify($x) + . qq|") -> to_ieee754("$format")|; + + my $got_bytes = $x -> to_ieee754($format); + my $got_hex = unpack "H*", $got_bytes; + $got_hex =~ s/(..)/\\x$1/g; + + my $expected_hex = $hex; + $expected_hex =~ s/(..)/\\x$1/g; + + is($got_hex, $expected_hex); + } +} 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 a1ffa017bb9..3573c216854 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/expmod_t.t @@ -1,19 +1,14 @@ #!/usr/bin/perl +# test caching timeout + use lib '..'; use Memoize; -BEGIN { - eval {require Time::HiRes}; - if ($@ || $ENV{SLOW}) { -# $SLOW_TESTS = 1; - } else { - 'Time::HiRes'->import('time'); - } -} my $DEBUG = 0; +my $LIFETIME = 15; -my $n = 0; +my $test = 0; $| = 1; if (-e '.fast') { @@ -21,116 +16,93 @@ if (-e '.fast') { exit 0; } -# Perhaps nobody will notice if we don't say anything -# print "# Warning: I'm testing the timed expiration policy.\n# This will take about thirty seconds.\n"; - -print "1..15\n"; -$| = 1; +print "# Testing the timed expiration policy.\n"; +print "# This will take about thirty seconds.\n"; -# (1) -++$n; print "ok $n\n"; +print "1..26\n"; -# (2) require Memoize::Expire; -++$n; print "ok $n\n"; - -sub close_enough { -# print "Close enough? @_[0,1]\n"; - abs($_[0] - $_[1]) <= 2; -} - -sub very_close { -# print "Close enough? @_[0,1]\n"; - abs($_[0] - $_[1]) <= 0.01; -} - -my $t0; -sub start_timer { - $t0 = time; - $DEBUG and print "# $t0\n"; -} - -sub wait_until { - my $until = shift(); - my $diff = $until - (time() - $t0); - $DEBUG and print "# until $until; diff = $diff\n"; - return if $diff <= 0; - select undef, undef, undef, $diff; -} +++$test; print "ok $test - Expire loaded\n"; sub now { # print "NOW: @_ ", time(), "\n"; time; } -tie my %cache => 'Memoize::Expire', LIFETIME => 15; +tie my %cache => 'Memoize::Expire', LIFETIME => $LIFETIME; + memoize 'now', SCALAR_CACHE => [HASH => \%cache ], LIST_CACHE => 'FAULT' ; -# (3) -++$n; print "ok $n\n"; - - -# (4-6) -# T -start_timer(); -for (1,2,3) { - $when{$_} = now($_); - ++$n; - print "not " unless close_enough($when{$_}, time()); - print "ok $n\n"; - sleep 6 if $_ < 3; - $DEBUG and print "# ", time()-$t0, "\n"; -} -# values will now expire at T=15, 21, 27 -# it is now T=12 - -# T+12 -for (1,2,3) { - $again{$_} = now($_); # Should be the same as before, because of memoization -} - -# (7-9) -# T+12 -foreach (1,2,3) { - ++$n; - if (very_close($when{$_}, $again{$_})) { - print "ok $n\n"; - } else { - print "not ok $n # expected $when{$_}, got $again{$_}\n"; - } -} - -# (10) -wait_until(18); # now(1) expires -print "not " unless close_enough(time, $again{1} = now(1)); -++$n; print "ok $n\n"; - -# (11-12) -# T+18 -foreach (2,3) { # Should not have expired yet. - ++$n; - print "not " unless now($_) == $again{$_}; - print "ok $n\n"; +++$test; print "ok $test - function memoized\n"; + +my (@before, @after, @now); + +# Once a second call now(), with three varying indices. Record when +# (within a range) it was called last, and depending on the value returned +# on the next call with the same index, decide whether it correctly +# returned the old value or expired the cache entry. + +for my $iteration (0..($LIFETIME/2)) { + for my $i (0..2) { + my $before = time; + my $now = now($i); + my $after = time; + + # the time returned by now() should either straddle the + # current time range, or if it returns a cached value, the + # time range of the previous time it was called. + # $before..$after represents the time range within which now() must have + # been called. On very slow platforms, $after - $before may be > 1. + + my $in_range0 = !$iteration || ($before[$i] <= $now && $now <= $after[$i]); + my $in_range1 = ($before <= $now && $now <= $after); + + my $ok; + if ($iteration) { + if ($in_range0) { + if ($in_range1) { + $ok = 0; # this should never happen + } + else { + # cached value, so cache shouldn't have expired + $ok = $after[$i] + $LIFETIME >= $before && $now[$i] == $now; + } + } + else { + if ($in_range1) { + # not cached value, so any cache should have have expired + $ok = $before[$i] + $LIFETIME <= $after && $now[$i] != $now; + } + else { + # not in any range; caching broken + $ok = 0; + } + } + } + else { + $ok = $in_range1; + } + + $test++; + print "not " unless $ok; + print "ok $test - $iteration:$i\n"; + if (!$ok || $DEBUG) { + print STDERR sprintf + "expmod_t.t: %d:%d: r0=%d r1=%d prev=(%s..%s) cur=(%s..%s) now=(%s,%s)\n", + $iteration, $i, $in_range0, $in_range1, + $before[$i]||-1, $after[$i]||-1, $before, $after, $now[$i]||-1, $now; + } + + if (!defined($now[$i]) || $now[$i] != $now) { + # cache expired; record value of new cache + $before[$i] = $before; + $after[$i] = $after; + $now[$i] = $now; + } + + sleep 1; + } } - -wait_until(24); # now(2) expires - -# (13) -# T+24 -print "not " unless close_enough(time, $again{2} = now(2)); -++$n; print "ok $n\n"; - -# (14-15) -# T+24 -foreach (1,3) { # 1 is good again because it was recomputed after it expired - ++$n; - if (very_close(scalar(now($_)), $again{$_})) { - print "ok $n\n"; - } else { - print "not ok $n # expected $when{$_}, got $again{$_}\n"; - } -} - diff --git a/gnu/usr.bin/perl/cpan/Memoize/t/speed.t b/gnu/usr.bin/perl/cpan/Memoize/t/speed.t index 6d219065736..c4b838192d8 100755 --- a/gnu/usr.bin/perl/cpan/Memoize/t/speed.t +++ b/gnu/usr.bin/perl/cpan/Memoize/t/speed.t @@ -56,7 +56,7 @@ $N = 1; $ELAPSED = 0; -my $LONG_RUN = 10; +my $LONG_RUN = 11; while (1) { my $start = time; @@ -88,10 +88,11 @@ $COUNT=0; $start = time; $RESULT2 = fib($N); $ELAPSED2 = time - $start + .001; # prevent division by 0 errors - print (($RESULT == $RESULT2) ? "ok 1\n" : "not ok 1\n"); # If it's not ten times as fast, something is seriously wrong. +print "# ELAPSED2=$ELAPSED2 seconds.\n"; print (($ELAPSED/$ELAPSED2 > 10) ? "ok 2\n" : "not ok 2\n"); + # If it called the function more than $N times, it wasn't memoized properly print (($COUNT > $N) ? "ok 3\n" : "not ok 3\n"); @@ -100,8 +101,8 @@ $COUNT = 0; $start = time; $RESULT2 = fib($N); $ELAPSED2 = time - $start + .001; # prevent division by 0 errors - print (($RESULT == $RESULT2) ? "ok 4\n" : "not ok 4\n"); +print "# ELAPSED2=$ELAPSED2 seconds.\n"; print (($ELAPSED/$ELAPSED2 > 10) ? "ok 5\n" : "not ok 5\n"); # This time it shouldn't have called the function at all. print ($COUNT == 0 ? "ok 6\n" : "not ok 6\n"); diff --git a/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/01_Module_Load_Conditional.t b/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/01_Module_Load_Conditional.t index 1bfa1a10d8f..2f463d5571d 100755 --- a/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/01_Module_Load_Conditional.t +++ b/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/01_Module_Load_Conditional.t @@ -132,6 +132,13 @@ use_ok( 'Module::Load::Conditional' ); is( $rv->{version}, 2, " Version is correct" ); } +### test finding a version of a module that has a VERSION error in a HereDoc +{ my $rv = check_install( module => 'HereDoc' ); + ok( $rv, 'Testing $VERSION in HEREDOC' ); + ok( !$rv->{version}, " No Version found" ); + is( $rv->{version}, undef, " Version is correct" ); +} + ### test that no package statement means $VERSION is $main::VERSION { my $rv = check_install( module => 'NotMain' ); diff --git a/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/to_load/HereDoc.pm b/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/to_load/HereDoc.pm new file mode 100644 index 00000000000..06332ac5bcc --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Module-Load-Conditional/t/to_load/HereDoc.pm @@ -0,0 +1,14 @@ +package HereDoc; +$HereDoc::VERSION = 1; + +sub magic { + print <<'END'; +package Errno; +-use vars qw($VERSION); +- +-$VERSION = "1.111"; ++our $VERSION = "1.111"; +END +} + +1; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/JustPod.pm b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/JustPod.pm new file mode 100644 index 00000000000..c7ad3d69770 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/lib/Pod/Simple/JustPod.pm @@ -0,0 +1,362 @@ +use 5; +package Pod::Simple::JustPod; +# ABSTRACT: Pod::Simple formatter that extracts POD from a file containing +# other things as well +use strict; +use warnings; + +use Pod::Simple::Methody (); +our @ISA = ('Pod::Simple::Methody'); + +sub new { + my $self = shift; + my $new = $self->SUPER::new(@_); + + $new->accept_targets('*'); + $new->keep_encoding_directive(1); + $new->preserve_whitespace(1); + $new->complain_stderr(1); + $new->_output_is_for_JustPod(1); + + return $new; +} + +#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +sub check_that_all_is_closed { + + # Actually checks that the things we depend on being balanced in fact are, + # so that we can continue in spit of pod errors + + my $self = shift; + while ($self->{inL}) { + $self->end_L(@_); + } + while ($self->{fcode_end} && @{$self->{fcode_end}}) { + $self->_end_fcode(@_); + } +} + +sub handle_text { + + # Add text to the output buffer. This is skipped if within a L<>, as we use + # the 'raw' attribute of that tag instead. + + $_[0]{buffer} .= $_[1] unless $_[0]{inL} ; +} + +sub spacer { + + # Prints the white space following things like =head1. This is normally a + # blank, unless BlackBox has told us otherwise. + + my ($self, $arg) = @_; + return unless $arg; + + my $spacer = ($arg->{'~orig_spacer'}) + ? $arg->{'~orig_spacer'} + : " "; + $self->handle_text($spacer); +} + +sub _generic_start { + + # Called from tags like =head1, etc. + + my ($self, $text, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text($text); + $self->spacer($arg); +} + +sub start_Document { shift->_generic_start("=pod\n\n"); } +sub start_head1 { shift->_generic_start('=head1', @_); } +sub start_head2 { shift->_generic_start('=head2', @_); } +sub start_head3 { shift->_generic_start('=head3', @_); } +sub start_head4 { shift->_generic_start('=head4', @_); } +sub start_encoding { shift->_generic_start('=encoding', @_); } +# sub start_Para +# sub start_Verbatim + +sub start_item_bullet { # Handle =item * + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text('=item'); + + # It can be that they said simply '=item', and it is inferred that it is to + # be a bullet. + if (! $arg->{'~orig_content'}) { + $self->handle_text("\n\n"); + } + else { + $self->spacer($arg); + if ($arg->{'~_freaky_para_hack'}) { + + # See Message Id <87y3gtcwa2.fsf@hope.eyrie.org> + my $item_text = $arg->{'~orig_content'}; + my $trailing = quotemeta $arg->{'~_freaky_para_hack'}; + $item_text =~ s/$trailing$//; + $self->handle_text($item_text); + } + else { + $self->handle_text("*\n\n"); + } + } +} + +sub start_item_number { # Handle '=item 2' + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text("=item"); + $self->spacer($arg); + $self->handle_text("$arg->{'~orig_content'}\n\n"); +} + +sub start_item_text { # Handle '=item foo bar baz' + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text('=item'); + $self->spacer($arg); +} + +sub _end_item { + my $self = shift; + $self->check_that_all_is_closed(); + $self->emit; +} + +*end_item_bullet = *_end_item; +*end_item_number = *_end_item; +*end_item_text = *_end_item; + +sub _start_over { # Handle =over + my ($self, $arg) = @_; + $self->check_that_all_is_closed(); + $self->handle_text("=over"); + + # The =over amount is optional + if ($arg->{'~orig_content'}) { + $self->spacer($arg); + $self->handle_text("$arg->{'~orig_content'}"); + } + $self->handle_text("\n\n"); +} + +*start_over_bullet = *_start_over; +*start_over_number = *_start_over; +*start_over_text = *_start_over; +*start_over_block = *_start_over; + +sub _end_over { + my $self = shift; + $self->check_that_all_is_closed(); + $self->handle_text('=back'); + $self->emit; +} + +*end_over_bullet = *_end_over; +*end_over_number = *_end_over; +*end_over_text = *_end_over; +*end_over_block = *_end_over; + +sub end_Document { + my $self = shift; + $self->emit; # Make sure buffer gets flushed + print {$self->{'output_fh'} } "=cut\n" +} + +sub _end_generic { + my $self = shift; + $self->check_that_all_is_closed(); + $self->emit; +} + +*end_head1 = *_end_generic; +*end_head2 = *_end_generic; +*end_head3 = *_end_generic; +*end_head4 = *_end_generic; +*end_encoding = *_end_generic; +*end_Para = *_end_generic; +*end_Verbatim = *_end_generic; + +sub _start_fcode { + my ($type, $self, $flags) = @_; + + # How many brackets is set by BlackBox unless the count is 1 + my $bracket_count = (exists $flags->{'~bracket_count'}) + ? $flags->{'~bracket_count'} + : 1; + $self->handle_text($type . ( "<" x $bracket_count)); + + my $rspacer = ""; + if ($bracket_count > 1) { + my $lspacer = (exists $flags->{'~lspacer'}) + ? $flags->{'~lspacer'} + : " "; + $self->handle_text($lspacer); + + $rspacer = (exists $flags->{'~rspacer'}) + ? $flags->{'~rspacer'} + : " "; + } + + # BlackBox doesn't output things for for the ending code callbacks, so save + # what we need. + push @{$self->{'fcode_end'}}, [ $bracket_count, $rspacer ]; +} + +sub start_B { _start_fcode('B', @_); } +sub start_C { _start_fcode('C', @_); } +sub start_E { _start_fcode('E', @_); } +sub start_F { _start_fcode('F', @_); } +sub start_I { _start_fcode('I', @_); } +sub start_S { _start_fcode('S', @_); } +sub start_X { _start_fcode('X', @_); } +sub start_Z { _start_fcode('Z', @_); } + +sub _end_fcode { + my $self = shift; + my $fcode_end = pop @{$self->{'fcode_end'}}; + my $bracket_count = 1; + my $rspacer = ""; + + if (! defined $fcode_end) { # If BlackBox is working, this shouldn't + # happen, but verify + $self->whine($self->{line_count}, "Extra '>'"); + } + else { + $bracket_count = $fcode_end->[0]; + $rspacer = $fcode_end->[1]; + } + + $self->handle_text($rspacer) if $bracket_count > 1; + $self->handle_text(">" x $bracket_count); +} + +*end_B = *_end_fcode; +*end_C = *_end_fcode; +*end_E = *_end_fcode; +*end_F = *_end_fcode; +*end_I = *_end_fcode; +*end_S = *_end_fcode; +*end_X = *_end_fcode; +*end_Z = *_end_fcode; + +sub start_L { + _start_fcode('L', @_); + $_[0]->handle_text($_[1]->{raw}); + $_[0]->{inL}++ +} + +sub end_L { + my $self = shift; + $self->{inL}--; + if ($self->{inL} < 0) { # If BlackBox is working, this shouldn't + # happen, but verify + $self->whine($self->{line_count}, "Extra '>' ending L<>"); + $self->{inL} = 0; + } + + $self->_end_fcode(@_); +} + +sub emit { + my $self = shift; + + if ($self->{buffer} ne "") { + print { $self->{'output_fh'} } "",$self->{buffer} ,"\n\n"; + + $self->{buffer} = ""; + } + + return; +} + +1; + +__END__ + +=head1 NAME + +Pod::Simple::JustPod -- just the Pod, the whole Pod, and nothing but the Pod + +=head1 SYNOPSIS + + my $infile = "mixed_code_and_pod.pm"; + my $outfile = "just_the_pod.pod"; + open my $fh, ">$outfile" or die "Can't write to $outfile: $!"; + + my $parser = Pod::Simple::JustPod->new(); + $parser->output_fh($fh); + $parser->parse_file($infile); + close $fh or die "Can't close $outfile: $!"; + +=head1 DESCRIPTION + +This class returns a copy of its input, translated into Perl's internal +encoding (UTF-8), and with all the non-Pod lines removed. + +This is a subclass of L<Pod::Simple::Methody> and inherits all its methods. +And since, that in turn is a subclass of L<Pod::Simple>, you can use any of +its methods. This means you can output to a string instead of a file, or +you can parse from an array. + +This class strives to return the Pod lines of the input completely unchanged, +except for any necessary translation into Perl's internal encoding, and it makes +no effort to return trailing spaces on lines; these likely will be stripped. +If the input pod is well-formed with no warnings nor errors generated, the +extracted pod should generate the same documentation when formatted by a Pod +formatter as the original file does. + +By default, warnings are output to STDERR + +=head1 SEE ALSO + +L<Pod::Simple>, L<Pod::Simple::Methody> + +=head1 SUPPORT + +Questions or discussion about POD and Pod::Simple should be sent to the +L<mailto:pod-people@perl.org> mail list. Send an empty email to +L<mailto:pod-people-subscribe@perl.org> to subscribe. + +This module is managed in an open GitHub repository, +L<https://github.com/theory/pod-simple/>. Feel free to fork and contribute, or +to clone L<git://github.com/theory/pod-simple.git> and send patches! + +Patches against Pod::Simple are welcome. Please send bug reports to +L<mailto:<bug-pod-simple@rt.cpan.org>. + +=head1 COPYRIGHT AND DISCLAIMERS + +Copyright (c) 2002 Sean M. Burke. + +This library is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=head1 AUTHOR + +Pod::Simple was created by Sean M. Burke <sburke@cpan.org>. +But don't bother him, he's retired. + +Pod::Simple is maintained by: + +=over + +=item * Allison Randal C<allison@perl.org> + +=item * Hans Dieter Pearcey C<hdp@cpan.org> + +=item * David E. Wheeler C<dwheeler@cpan.org> + +=back + +Pod::Simple::JustPod was developed by John SJ Anderson +C<genehack@genehack.org>, with contributions from Karl Williamson +C<khw@cpan.org>. + +=cut diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/00about.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/00about.t index e5e7038e385..70fcffe12e8 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/00about.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/00about.t @@ -23,7 +23,7 @@ Pod::Simple Pod::Simple::BlackBox Pod::Simple::Checker Pod::Simple::DumpAsText Pod::Simple::DumpAsXML Pod::Simple::HTML Pod::Simple::HTMLBatch Pod::Simple::HTMLLegacy Pod::Simple::LinkSection Pod::Simple::Methody -Pod::Simple::Progress Pod::Simple::PullParser +Pod::Simple::JustPod Pod::Simple::Progress Pod::Simple::PullParser Pod::Simple::PullParserEndToken Pod::Simple::PullParserStartToken Pod::Simple::PullParserTextToken Pod::Simple::PullParserToken Pod::Simple::RTF Pod::Simple::Search Pod::Simple::SimpleTree diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod01.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod01.t new file mode 100644 index 00000000000..c74b3370cb3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod01.t @@ -0,0 +1,219 @@ +#! user/bin/perl -w + +# t/JustPod01.t - check basics of Pod::Simple::JustPod + +BEGIN { + chdir 't' if -d 't'; +} + +use strict; +use lib '../lib'; +use Test::More tests => 2; + +use warnings; +use utf8; + +use_ok('Pod::Simple::JustPod') or exit; + +my $parser = Pod::Simple::JustPod->new(); + +my $input; +while ( <DATA> ) { $input .= $_ } + +my $output; +$parser->output_string( \$output ); +$parser->parse_string_document( $input ); + +# Strip off text before =pod in the input +$input =~ s/^.*(=pod.*)$/$1/mgs; + +my $msg = "got expected output"; +if ($output eq $input) { + pass($msg); +} +elsif ($ENV{PERL_TEST_DIFF}) { + fail($msg); + require File::Temp; + my $orig_file = File::Temp->new(); + local $/ = "\n"; + chomp $input; + print $orig_file $input, "\n"; + close $orig_file || die "Can't close orig_file: $!"; + + chomp $output; + my $parsed_file = File::Temp->new(); + print $parsed_file $output, "\n"; + close $parsed_file || die "Can't close parsed_file"; + + my $diff = File::Temp->new(); + system("$ENV{PERL_TEST_DIFF} $orig_file $parsed_file > $diff"); + + open my $fh, "<", $diff || die "Can't open $diff"; + my @diffs = <$fh>; + diag(@diffs); +} +else { + eval { require Text::Diff; }; + if ($@) { + is($output, $input, $msg); + diag("Set environment variable PERL_TEST_DIFF=diff_tool or install" + . " Text::Diff to see just the differences."); + } + else { + fail($msg); + diag Text::Diff::diff(\$input, \$output, { STYLE => 'Unified' }); + } +} + + +__DATA__ +package utf8::all; +use strict; +use warnings; +use 5.010; # state +# ABSTRACT: turn on Unicode - all of it +our $VERSION = '0.010'; # VERSION + + +use Import::Into; +use parent qw(Encode charnames utf8 open warnings feature); + +sub import { + my $target = caller; + 'utf8'->import::into($target); + 'open'->import::into($target, qw{:encoding(UTF-8) :std}); + 'charnames'->import::into($target, qw{:full :short}); + 'warnings'->import::into($target, qw{FATAL utf8}); + 'feature'->import::into($target, qw{unicode_strings}) if $^V >= v5.11.0; + 'feature'->import::into($target, qw{unicode_eval fc}) if $^V >= v5.16.0; + + { + no strict qw(refs); ## no critic (TestingAndDebugging::ProhibitNoStrict) + *{$target . '::readdir'} = \&_utf8_readdir; + } + + # utf8 in @ARGV + state $have_encoded_argv = 0; + _encode_argv() unless $have_encoded_argv++; + + $^H{'utf8::all'} = 1; + + return; +} + +sub _encode_argv { + $_ = Encode::decode('UTF-8', $_) for @ARGV; + return; +} + +sub _utf8_readdir(*) { ## no critic (Subroutines::ProhibitSubroutinePrototypes) + my $handle = shift; + if (wantarray) { + my @all_files = CORE::readdir($handle); + $_ = Encode::decode('UTF-8', $_) for @all_files; + return @all_files; + } + else { + my $next_file = CORE::readdir($handle); + $next_file = Encode::decode('UTF-8', $next_file); + return $next_file; + } +} + + +1; + +__END__ + +=pod + +=encoding utf-8 + +=head1 NAME + +utf8::all - turn on Unicode - all of it + +=head1 VERSION + +version 0.010 + +=head1 SYNOPSIS + + use utf8::all; # Turn on UTF-8. All of it. + + open my $in, '<', 'contains-utf8'; # UTF-8 already turned on here + print length 'føø bÄr'; # 7 UTF-8 characters + my $utf8_arg = shift @ARGV; # @ARGV is UTF-8 too! + +=head1 DESCRIPTION + +L<utf8> allows you to write your Perl encoded in UTF-8. That means UTF-8 +strings, variable names, and regular expressions. C<utf8::all> goes further, and +makes C<@ARGV> encoded in UTF-8, and filehandles are opened with UTF-8 encoding +turned on by default (including STDIN, STDOUT, STDERR), and charnames are +imported so C<\N{...}> sequences can be used to compile Unicode characters based +on names. If you I<don't> want UTF-8 for a particular filehandle, you'll have to +set C<binmode $filehandle>. + +The pragma is lexically-scoped, so you can do the following if you had some +reason to: + + { + use utf8::all; + open my $out, '>', 'outfile'; + my $utf8_str = 'føø bÄr'; + print length $utf8_str, "\n"; # 7 + print $out $utf8_str; # out as utf8 + } + open my $in, '<', 'outfile'; # in as raw + my $text = do { local $/; <$in>}; + print length $text, "\n"; # 10, not 7! + +=head1 INTERACTION WITH AUTODIE + +If you use L<autodie>, which is a great idea, you need to use at least version +B<2.12>, released on L<June 26, 2012|https://metacpan.org/source/PJF/autodie-2.12/Changes#L3>. +Otherwise, autodie obliterates the IO layers set by the L<open> pragma. See +L<RT #54777|https://rt.cpan.org/Ticket/Display.html?id=54777> and +L<GH #7|https://github.com/doherty/utf8-all/issues/7>. + +=head1 AVAILABILITY + +The project homepage is L<http://metacpan.org/release/utf8-all/>. + +The latest version of this module is available from the Comprehensive Perl +Archive Network (CPAN). Visit L<http://www.perl.com/CPAN/> to find a CPAN +site near you, or see L<https://metacpan.org/module/utf8::all/>. + +=head1 SOURCE + +The development version is on github at L<http://github.com/doherty/utf8-all> +and may be cloned from L<git://github.com/doherty/utf8-all.git> + +=head1 BUGS AND LIMITATIONS + +You can make new bug reports, and view existing ones, through the +web interface at L<https://github.com/doherty/utf8-all/issues>. + +=head1 AUTHORS + +=over 4 + +=item * + +Michael Schwern <mschwern@cpan.org> + +=item * + +Mike Doherty <doherty@cpan.org> + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2009 by Michael Schwern <mschwern@cpan.org>. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +=cut diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod02.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod02.t new file mode 100644 index 00000000000..8205aecaa0a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod02.t @@ -0,0 +1,445 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { plan tests => 1 } + +use Pod::Simple::JustPod; + +my @orig = <DATA>; +my $parsed; + +my $parser = Pod::Simple::JustPod->new(); +$parser->output_string(\$parsed); +$parser->parse_lines(@orig, undef); + +my $orig = join "", @orig; + +my $msg = "Verify parsed pod sufficiently matches original"; +if ($parsed eq $orig) { + pass($msg); +} +elsif ($ENV{PERL_TEST_DIFF}) { + fail($msg); + require File::Temp; + my $orig_file = File::Temp->new(); + local $/ = "\n"; + chomp $orig; + print $orig_file $orig, "\n"; + close $orig_file || die "Can't close orig_file: $!"; + + chomp $parsed; + my $parsed_file = File::Temp->new(); + print $parsed_file $parsed, "\n"; + close $parsed_file || die "Can't close parsed_file"; + + my $diff = File::Temp->new(); + system("$ENV{PERL_TEST_DIFF} $orig_file $parsed_file > $diff"); + + open my $fh, "<", $diff || die "Can't open $diff"; + my @diffs = <$fh>; + diag(@diffs); +} +else { + eval { require Text::Diff; }; + if ($@) { + is($parsed, $orig, $msg); + diag("Set environment variable PERL_TEST_DIFF=diff_tool or install" + . " Text::Diff to see just the differences."); + } + else { + fail($msg); + diag Text::Diff::diff(\$orig, \$parsed, { STYLE => 'Unified' }); + } +} + +# The data is adapted from a test file from pod2lators. Extra spaces are +# added in places to make sure they get retained, and some extra tests +__DATA__ +=pod + +=encoding ASCII + +=head1 NAME + +basic.pod - Test of various basic POD features in translators. + +=head1 HEADINGS + +Try a few different levels of headings, with embedded formatting codes and +other interesting bits. + +=head1 This C<is> a "level 1" heading + +=head2 ``Level'' "2 I<heading> + +=head3 Level 3 B<heading I<with C<weird F<stuff "" (double quote)>>>> + +=head4 Level "4 C<heading> + +Now try again with B<intermixed> F<text>. + +=head1 This C<is> a "level 1" heading + +Text. + +=head2 ``Level'' 2 I<heading> + +Text. + +=head3 Level 3 B<heading I<with C<weird F<stuff>>>> + +Text. + +=head4 Level "4 C<heading> + +Text. + +=head1 LINKS + +These are all taken from the Pod::Parser tests. + +Try out I<LOTS> of different ways of specifying references: + +Reference the L<manpage/section> + +Reference the L<"manpage"/section> + +Reference the L<manpage/"section"> + +Now try it using the new "|" stuff ... + +Reference the L<thistext|manpage/section>| + +Reference the L<thistext | manpage / section>| + +Reference the L<thistext| manpage/ section>| + +Reference the L<thistext |manpage /section>| + +Reference the L<thistext|manpage/"section">| + +Reference the L<thistext| +manpage/ +section>| + +And then throw in a few new ones of my own. + +L<foo> + +L<foo|bar> + +L<foo/bar> + +L<foo/"baz boo"> + +L</bar> + +L</"baz boo"> + +L</baz boo> + +L<foo bar/baz boo> + +L<"boo var baz"> + +L<bar baz> + +L</boo>, L</bar>, and L</baz> + +L<fooZ<>bar> + +L<Testing I<italics>|foo/bar> + +L<foo/I<Italic> text> + +L<fooE<verbar>barZ<>/Section C<with> I<B<other> markup>> + +=head1 OVER AND ITEMS + +Taken from Pod::Parser tests, this is a test to ensure that multiline +=item paragraphs get indented appropriately. + +=over 4 + +=item This +is +a +test. + +=back + +There should be whitespace now before this line. + +Taken from Pod::Parser tests, this is a test to ensure the nested =item +paragraphs get indented appropriately. + +=over 2 + +=item 1 + +First section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=back + +=item 2 + +Second section. + +=over 2 + +=item a + +this is item a + +=item b + +this is item b + +=item c + +=item d + +This is item c & d. + +=back + +=back + +Now some additional weirdness of our own. Make sure that multiple tags +for one paragraph are properly compacted. + +=over 4 + +=item "foo" + +=item B<bar> + +=item C<baz> + +There shouldn't be any spaces between any of these item tags; this idiom +is used in perlfunc. + +=item Some longer item text + +Just to make sure that we test paragraphs where the item text doesn't fit +in the margin of the paragraph (and make sure that this paragraph fills a +few lines). + +Let's also make it multiple paragraphs to be sure that works. + +=back + +Test use of =over without =item as a block "quote" or block paragraph. + +=over 4 + +This should be indented four spaces but otherwise formatted the same as +any other regular text paragraph. Make sure it's long enough to see the +results of the formatting..... + +=back + +Now try the same thing nested, and make sure that the indentation is reset +back properly. + +=over 4 + +=over 4 + +This paragraph should be doubly indented. + +=back + +This paragraph should only be singly indented. + +=over 4 + +=item + +This is an item in the middle of a block-quote, which should be allowed. + +=item + +We're also testing tagless item commands. + +=back + +Should be back to the single level of indentation. + +=back + +Should be back to regular indentation. + +Now also check the transformation of * into real bullets for man pages. + +=over + +=item * + +An item. We're also testing using =over without a number, and making sure +that item text wraps properly. + +=item * + +Another item. + +=back + +and now test the numbering of item blocks. + +=over 4 + +=item 1. + +First item. + +=item 2. + +Second item. + +=back + +=head1 FORMATTING CODES + +Another test taken from Pod::Parser. + +This is a test to see if I can do not only C<$self> and C<method()>, but +also C<< $self->method() >> and C<< $self->{FIELDNAME} >> and +C<< $Foo <=> $Bar >> without resorting to escape sequences. If +I want to refer to the right-shift operator I can do something +like C<<< $x >> 3 >>> or even C<<<< $y >> 5 >>>>. + +Now for the grand finale of C<< $self->method()->{FIELDNAME} = {FOO=>BAR} >>. +And I also want to make sure that newlines work like this +C<<< +$self->{FOOBAR} >> 3 and [$b => $a]->[$a <=> $b] +>>> + +Of course I should still be able to do all this I<with> escape sequences +too: C<$self-E<gt>method()> and C<$self-E<gt>{FIELDNAME}> and +C<{FOO=E<gt>BAR}>. + +Dont forget C<$self-E<gt>method()-E<gt>{FIELDNAME} = {FOO=E<gt>BAR}>. + +And make sure that C<0> works too! + +Now, if I use << or >> as my delimiters, then I have to use whitespace. +So things like C<<$self->method()>> and C<<$self->{FIELDNAME}>> wont end +up doing what you might expect since the first > will still terminate +the first < seen. + +Lets make sure these work for empty ones too, like C<<< >>>, +C<<<< +>>>>, and C<< >> >> (just to be obnoxious) + +The statement: C<This is dog kind's I<finest> hour!> is a parody of a +quotation from Winston Churchill. + +The following tests are added to those: + +Make sure that a few othZ<>er odd I<Z<>things> still work. This should be +a vertical bar: E<verbar>. Here's a test of a few more special escapes +that have to be supported: + +=over 3 + +=item E<amp> + +An ampersand. + +=item E<apos> + +An apostrophe. + +=item E<lt> + +A less-than sign. + +=item E<gt> + +A greater-than sign. + +=item E<quot> + +A double quotation mark. + +=item E<sol> + +A forward slash. + +=back + +Try to get this bit of text over towards the edge so S<|that all of this +text inside SE<lt>E<gt> won't|> be wrapped. Also test the +|sameE<nbsp>thingE<nbsp>withE<nbsp>non-breakingS< spaces>.| + +There is a soft hyE<shy>phen in hyphen at hy-phen. + +This is a test of an X<index entry>index entry. + +=head1 VERBATIM + +Throw in a few verbatim paragraphs. + + use Term::ANSIColor; + print color 'bold blue'; + print "This text is bold blue.\n"; + print color 'reset'; + print "This text is normal.\n"; + print colored ("Yellow on magenta.\n", 'yellow on_magenta'); + print "This text is normal.\n"; + print colored ['yellow on_magenta'], "Yellow on magenta.\n"; + + use Term::ANSIColor qw(uncolor); + print uncolor '01;31', "\n"; + +But this isn't verbatim (make sure it wraps properly), and the next +paragraph is again: + + use Term::ANSIColor qw(:constants); + print BOLD, BLUE, "This text is in bold blue.\n", RESET; + + use Term::ANSIColor qw(:constants); $Term::ANSIColor::AUTORESET = 1; print BOLD BLUE "This text is in bold blue.\n"; print "This text is normal.\n"; + +(Ugh, that's obnoxiously long.) Try different spacing: + + Starting with a tab. +Not +starting +with +a +tab. But this should still be verbatim. + As should this. + +This isn't. + + This is. And this: is an internal tab. It should be: + |--| <= lined up with that. + +(Tricky, but tabs should be expanded before the translator starts in on +the text since otherwise text with mixed tabs and spaces will get messed +up.) + + And now we test verbatim paragraphs right before a heading. Older + versions of Pod::Man generated two spaces between paragraphs like this + and the heading. (In order to properly test this, one may have to + visually inspect the nroff output when run on the generated *roff + text, unfortunately.) + +=head1 CONCLUSION + +That's all, folks! + +=cut diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod_corpus.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod_corpus.t new file mode 100644 index 00000000000..e0bb8780f86 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/JustPod_corpus.t @@ -0,0 +1,156 @@ +# Testing Pod::Simple::JustPod against *.pod in /t +use strict; + +BEGIN { + if($ENV{PERL_CORE}) { + chdir 't'; + @INC = '../lib'; + } + + use Config; + if ($Config::Config{'extensions'} !~ /\bEncode\b/) { + print "1..0 # Skip: Encode was not built\n"; + exit 0; + } +} + +use File::Find; +use File::Spec; +use Test::More; + +use Pod::Simple::JustPod; + +my @test_files; + +BEGIN { + sub source_path { + my $file = shift; + if ($ENV{PERL_CORE}) { + require File::Spec; + my $updir = File::Spec->updir; + my $dir = File::Spec->catdir($updir, 'lib', 'Pod', 'Simple', 't'); + return File::Spec->catdir($dir, $file); + } + else { + return $file; + } + } + + my @test_dirs = ( + File::Spec->catdir( source_path('t') ) , + File::Spec->catdir( File::Spec->updir, 't') , + ); + + my $test_dir; + foreach( @test_dirs ) { + $test_dir = $_ and last if -e; + } + + die "Can't find the test dir" unless $test_dir; + print "# TESTDIR: $test_dir\n"; + + sub wanted { + push @test_files, $File::Find::name + if $File::Find::name =~ /\.pod$/; + } + find(\&wanted , $test_dir ); + + plan tests => scalar @test_files; +} + +foreach my $file (@test_files) { + my $parser = Pod::Simple::JustPod->new(); + $parser->complain_stderr(0); + + my $input; + open( IN , '<:raw' , $file ) or die "$file: $!"; + $input .= $_ while (<IN>); + close( IN ); + + my $output; + $parser->output_string( \$output ); + $parser->parse_string_document( $input ); + + if ($parser->any_errata_seen()) { + pass("Skip '$file' because of pod errors"); + next if "$]" lt '5.010.001'; # note() not found in earlier versions + my $errata = $parser->errata_seen(); + foreach my $line_number (sort { $a <=> $b } keys %$errata) { + foreach my $err_msg (sort @{$errata->{$line_number}}) { + note("$file: $line_number: $err_msg"); + } + } + next; + } + + my $encoding = $parser->encoding(); + if (defined $encoding) { + eval { require Encode; }; + $input = Encode::decode($parser->encoding(), $input); + } + + my @input = split "\n", $input; + my $stripped_input = ""; + while (defined ($_ = shift @input)) { + if (/ ^ = [a-z]+ /x) { + my $line = "$_\n"; + + if ($stripped_input eq "" || $_ !~ /^=pod/) { + $stripped_input .= $line; + } + while (defined ($_ = shift @input)) { + $stripped_input .= "$_\n"; + last if / ^ =cut /x; + } + } + } + $stripped_input =~ s/ ^ =cut \n (.) /$1/mgx; + + $input = $stripped_input if $stripped_input ne ""; + if ($input !~ / ^ =pod /x) { + $input =~ s/ ^ \s+ //x; + $input = "=pod\n\n$input"; + } + if ($input !~ / =cut $ /x) { + $input =~ s/ \s+ $ //x; + $input .= "\n\n=cut\n"; + } + + my $msg = "got expected output for $file"; + if ($output eq $input) { + pass($msg); + } + elsif ($ENV{PERL_TEST_DIFF}) { + fail($msg); + require File::Temp; + my $orig_file = File::Temp->new(); + local $/ = "\n"; + chomp $input; + print $orig_file $input, "\n"; + close $orig_file || die "Can't close orig_file: $!"; + + chomp $output; + my $parsed_file = File::Temp->new(); + print $parsed_file $output, "\n"; + close $parsed_file || die "Can't close parsed_file"; + + my $diff = File::Temp->new(); + system("$ENV{PERL_TEST_DIFF} $orig_file $parsed_file > $diff"); + + open my $fh, "<", $diff || die "Can't open $diff"; + my @diffs = <$fh>; + diag(@diffs); + } + else { + eval { require Text::Diff; }; + if ($@) { + is($output, $input, $msg); + diag("Set environment variable PERL_TEST_DIFF=diff_tool or install" + . " Text::Diff to see just the differences."); + } + else { + fail($msg); + diag Text::Diff::diff(\$input, \$output, { STYLE => 'Unified' }); + } + } +} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/content_seen.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/content_seen.t new file mode 100644 index 00000000000..82095bafb2a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/content_seen.t @@ -0,0 +1,34 @@ +BEGIN { + if($ENV{PERL_CORE}) { + chdir 't'; + @INC = '../lib'; + } +} + +use strict; +use Test; +BEGIN { plan tests => 2 }; + +use Pod::Simple::Text; + +my $p = Pod::Simple::Text->new(); +$p->parse_string_document('dm+aSxLl7V3VUJFIe6CFDU13zhZ3yvjIuVkp6l//ZHcDcX014vnnh3FoElI92kFB +JGFU23Vga5Tfz0Epybwio9dq1gzrZ/PIcil2MnEcUWSrIStriv4hAbf0MXcNRHOM +oOV7xKU= +=y6KV +-----END PGP PUBLIC KEY BLOCK-----}; + +print $key; +exit; +'); + +# The =y6KV should not make this appear to be pod +ok ! $p->content_seen; + +my $q = Pod::Simple::Text->new(); +$q->parse_string_document('=head1 yes this is pod + +And this fills it in +'); + +ok $q->content_seen; diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.txt b/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.txt index 32c763ee7ac..95b1224842f 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.txt +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.txt @@ -8,7 +8,16 @@ WÅšRÓD NOCNEJ CISZY -- explicitly utf8 test document in Polish =head1 DESCRIPTION This is a test Pod document in UTF8. Its content is the lyrics to -the Polish Christmas carol "WÅ›ród nocnej ciszy". +the Polish Christmas carol "WÅ›ród nocnej ciszy", except it includes +a few lines to test RTF specially. + +ff is a character in the upper half of Plane 0, so should be negative in RTF +𔸠is a character in Plane 1, so should be expressed as a surrogate pair in RTF + +All the ASCII printables + !"#$%&\'()*+,-./0123456789:;<=>?@ +ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_` +abcdefghijklmnopqrstuvwxyz{|}~ WÅ›ród nocnej ciszy gÅ‚os siÄ™ rozchodzi: / WstaÅ„cie, pasterze, Bóg siÄ™ nam rodzi! / @@ -38,6 +47,14 @@ Chleba i wina. And now as verbatim text: + ff upper half, Plane 0 + 𔸠Plane 1 + + All the ASCII printables + !"#$%&\'()*+,-./0123456789:;<=>?@ + ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_` + abcdefghijklmnopqrstuvwxyz{|}~ + WÅ›ród nocnej ciszy gÅ‚os siÄ™ rozchodzi: WstaÅ„cie, pasterze, Bóg siÄ™ nam rodzi! Czym prÄ™dzej siÄ™ wybierajcie, diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.xml b/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.xml index 2778571c956..2eccfe76d4a 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.xml +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/corpus/polish_utf8.xml @@ -13,35 +13,54 @@ </head1> <Para start_line="10"> This is a test Pod document in UTF8. Its content is the lyrics to the - Polish Christmas carol "Wśród nocnej ciszy". + Polish Christmas carol "Wśród nocnej ciszy", except + it includes a few lines to test RTF specially. </Para> - <Para start_line="13"> + <Para start_line="14"> + ff is a character in the upper half of Plane 0, so should be negative + in RTF 𝔸 is a character in Plane 1, so should be expressed as a + surrogate pair in RTF + </Para> + <Para start_line="17"> + All the ASCII printables + !"#$%&\'()*+,-./0123456789:;<=>?@ + ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_` abcdefghijklmnopqrstuvwxyz{|}~ + </Para> + <Para start_line="22"> Wśród nocnej ciszy głos się rozchodzi: / Wstańcie, pasterze, Bóg się nam rodzi! / Czym prędzej się wybierajcie, / Do Betlejem pospieszajcie / Przywitać Pana. </Para> - <Para start_line="19"> + <Para start_line="28"> Poszli, znaleźli Dzieciątko w żłobie / Z wszystkimi znaki danymi sobie. / Jako Bogu cześć Mu dali, / A witając zawołali / Z wielkiej radości: </Para> - <Para start_line="25"> + <Para start_line="34"> Ach, witaj Zbawco z dawno żądany, / Wiele tysięcy lat wyglądany / Na Ciebie króle, prorocy / Czekali, a Tyś tej nocy / Nam się objawił. </Para> - <Para start_line="31"> + <Para start_line="40"> I my czekamy na Ciebie, Pana, / A skoro przyjdziesz na głos kapłana, / Padniemy na twarz przed Tobą, / Wierząc, żeś jest pod osłoną / Chleba i wina. </Para> - <head2 start_line="37"> + <head2 start_line="46"> As Verbatim </head2> - <Para start_line="39"> + <Para start_line="48"> And now as verbatim text: </Para> - <VerbatimFormatted start_line="41" xml:space="preserve"> + <VerbatimFormatted start_line="50" xml:space="preserve"> + ff upper half, Plane 0 + 𝔸 Plane 1 + + All the ASCII printables + !"#$%&\'()*+,-./0123456789:;<=>?@ + ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_` + abcdefghijklmnopqrstuvwxyz{|}~ + Wśród nocnej ciszy głos się rozchodzi: Wstańcie, pasterze, Bóg się nam rodzi! Czym prędzej się wybierajcie, @@ -66,7 +85,7 @@ Wierząc, żeś jest pod osłoną Chleba i wina. </VerbatimFormatted> - <Para start_line="65"> + <Para start_line="82"> [end] </Para> </Document> diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/fcodes_s.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/fcodes_s.t index 977756593de..fd48ec07bf7 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/fcodes_s.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/fcodes_s.t @@ -43,17 +43,17 @@ skip( $unless_ascii, skip( $unless_ascii, $x->_out( sub { $_[0]->nbsp_for_S(1) }, qq{=pod\n\nI like S<L</"bric-a-brac a gogo">>.\n}), -'<Document><Para>I like <L content-implicit="yes" section="bric-a-brac a gogo" type="pod">"bric-a-brac a gogo"</L>.</Para></Document>' +'<Document><Para>I like <L content-implicit="yes" raw="/"bric-a-brac a gogo"" section="bric-a-brac a gogo" type="pod">"bric-a-brac a gogo"</L>.</Para></Document>' ); skip( $unless_ascii, $x->_out( sub { $_[0]->nbsp_for_S(1) }, qq{=pod\n\nI like S<L<Stuff like that|/"bric-a-brac a gogo">>.\n}), -'<Document><Para>I like <L section="bric-a-brac a gogo" type="pod">Stuff like that</L>.</Para></Document>' +'<Document><Para>I like <L raw="Stuff like that|/"bric-a-brac a gogo"" section="bric-a-brac a gogo" type="pod">Stuff like that</L>.</Para></Document>' ); skip( $unless_ascii, $x->_out( sub { $_[0]->nbsp_for_S(1) }, qq{=pod\n\nI like S<L<Stuff I<like that>|/"bric-a-brac a gogo">>.\n}), -'<Document><Para>I like <L section="bric-a-brac a gogo" type="pod">Stuff <I>like that</I></L>.</Para></Document>' +'<Document><Para>I like <L raw="Stuff I<like that>|/"bric-a-brac a gogo"" section="bric-a-brac a gogo" type="pod">Stuff <I>like that</I></L>.</Para></Document>' ); &ok( $x->_duo( sub { $_[0]->nbsp_for_S(1) }, @@ -219,7 +219,7 @@ ok( # Test HTML output of links. use Pod::Simple::HTML; -my $PERLDOC = "http://search.cpan.org/perldoc"; +my $PERLDOC = "https://metacpan.org/pod"; my $MANURL = "http://man.he.net/man"; sub x ($) { Pod::Simple::HTML->_out( @@ -230,12 +230,12 @@ sub x ($) { ok( x(qq{L<Net::Ping>\n}), - qq{\n<p><a href="$PERLDOC?Net%3A%3APing" class="podlinkpod"\n>Net::Ping</a></p>\n} + qq{\n<p><a href="$PERLDOC/Net%3A%3APing" class="podlinkpod"\n>Net::Ping</a></p>\n} ); ok( x(qq{Be sure to read the L<Net::Ping> docs\n}), - qq{\n<p>Be sure to read the <a href="$PERLDOC?Net%3A%3APing" class="podlinkpod"\n>Net::Ping</a> docs</p>\n} + qq{\n<p>Be sure to read the <a href="$PERLDOC/Net%3A%3APing" class="podlinkpod"\n>Net::Ping</a> docs</p>\n} ); ok( @@ -250,7 +250,7 @@ ok( ok( x(qq{L<Net::Ping/Ping-pong>\n}), - qq{\n<p><a href="$PERLDOC?Net%3A%3APing#Ping-pong" class="podlinkpod"\n>"Ping-pong" in Net::Ping</a></p>\n} + qq{\n<p><a href="$PERLDOC/Net%3A%3APing#Ping-pong" class="podlinkpod"\n>"Ping-pong" in Net::Ping</a></p>\n} ); ok( @@ -270,7 +270,7 @@ ok( ok( x(qq{L<Net::Ping/Ping-E<112>ong>\n}), - qq{\n<p><a href="$PERLDOC?Net%3A%3APing#Ping-pong" class="podlinkpod"\n>"Ping-pong" in Net::Ping</a></p>\n} + qq{\n<p><a href="$PERLDOC/Net%3A%3APing#Ping-pong" class="podlinkpod"\n>"Ping-pong" in Net::Ping</a></p>\n} ); ok( @@ -315,17 +315,17 @@ ok( ok( x(qq{L<Perl Error Messages|perldiag>\n}), - qq{\n<p><a href="$PERLDOC?perldiag" class="podlinkpod"\n>Perl Error Messages</a></p>\n} + qq{\n<p><a href="$PERLDOC/perldiag" class="podlinkpod"\n>Perl Error Messages</a></p>\n} ); ok( x(qq{L<Perl\nError\nMessages|perldiag>\n}), - qq{\n<p><a href="$PERLDOC?perldiag" class="podlinkpod"\n>Perl Error Messages</a></p>\n} + qq{\n<p><a href="$PERLDOC/perldiag" class="podlinkpod"\n>Perl Error Messages</a></p>\n} ); ok( x(qq{L<Perl\nError\t Messages|perldiag>\n}), - qq{\n<p><a href="$PERLDOC?perldiag" class="podlinkpod"\n>Perl Error Messages</a></p>\n} + qq{\n<p><a href="$PERLDOC/perldiag" class="podlinkpod"\n>Perl Error Messages</a></p>\n} ); ok( @@ -352,12 +352,12 @@ sub o ($) { ok( o(qq{L<Net::Ping>}), - qq{<p><a href="$PERLDOC?Net::Ping">Net::Ping</a></p>\n\n} + qq{<p><a href="$PERLDOC/Net::Ping">Net::Ping</a></p>\n\n} ); ok( o(qq{Be sure to read the L<Net::Ping> docs}), - qq{<p>Be sure to read the <a href="$PERLDOC?Net::Ping">Net::Ping</a> docs</p>\n\n} + qq{<p>Be sure to read the <a href="$PERLDOC/Net::Ping">Net::Ping</a> docs</p>\n\n} ); ok( @@ -372,7 +372,7 @@ ok( ok( o(qq{L<Net::Ping/Ping-pong>}), - qq{<p><a href="$PERLDOC?Net::Ping#Ping-pong">"Ping-pong" in Net::Ping</a></p>\n\n} + qq{<p><a href="$PERLDOC/Net::Ping#Ping-pong">"Ping-pong" in Net::Ping</a></p>\n\n} ); ok( @@ -392,7 +392,7 @@ ok( ok( o(qq{L<Net::Ping/Ping-E<112>ong>}), - qq{<p><a href="$PERLDOC?Net::Ping#Ping-pong">"Ping-pong" in Net::Ping</a></p>\n\n} + qq{<p><a href="$PERLDOC/Net::Ping#Ping-pong">"Ping-pong" in Net::Ping</a></p>\n\n} ); ok( @@ -437,17 +437,17 @@ ok( ok( o(qq{L<Perl Error Messages|perldiag>}), - qq{<p><a href="$PERLDOC?perldiag">Perl Error Messages</a></p>\n\n} + qq{<p><a href="$PERLDOC/perldiag">Perl Error Messages</a></p>\n\n} ); ok( o(qq{L<Perl\nError\nMessages|perldiag>}), - qq{<p><a href="$PERLDOC?perldiag">Perl Error Messages</a></p>\n\n} + qq{<p><a href="$PERLDOC/perldiag">Perl Error Messages</a></p>\n\n} ); ok( o(qq{L<Perl\nError\t Messages|perldiag>}), - qq{<p><a href="$PERLDOC?perldiag">Perl Error Messages</a></p>\n\n} + qq{<p><a href="$PERLDOC/perldiag">Perl Error Messages</a></p>\n\n} ); ok( diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/github_issue_79.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/github_issue_79.t new file mode 100644 index 00000000000..a56b428c2aa --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/github_issue_79.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval { require Test::Deep; }; + plan skip_all => 'Fails with Can\'t locate object method "print" via package "IO::File" at t/github_issue_79.t line 33' if $] le 5.012005; + plan skip_all => 'Need Test::Deep to test' if $@; + Test::Deep->import('cmp_deeply'); +} + +{ +package DumpAsXML::Enh; + +use parent 'Pod::Simple::DumpAsXML'; + +sub new { + my ( $class ) = @_; + my $self = $class->SUPER::new(); + $self->code_handler( sub { pop( @_ )->_handle_line( 'code', @_ ); } ); + $self->cut_handler( sub { pop( @_ )->_handle_line( 'cut', @_ ); } ); + $self->pod_handler( sub { pop( @_ )->_handle_line( 'pod', @_ ); } ); + $self->whiteline_handler( sub { pop( @_ )->_handle_line( 'white', @_ ); } ); + return $self; +}; + +sub _handle_line { + my ( $self, $elem, $text, $line ) = @_; + my $fh = $self->{ output_fh }; + $fh->print( ' ' x $self->{ indent }, "<$elem start_line=\"$line\"/>\n" ); +}; + +} + +my $output = ''; +my $parser = DumpAsXML::Enh->new(); +$parser->output_string( \$output ); + +my $input = [ + '=head1 DESCRIPTION', + '', + ' Verbatim paragraph.', + '', + '=cut', +]; +my $expected_output = [ + '<Document start_line="1">', + ' <head1 start_line="1">', + ' DESCRIPTION', + ' </head1>', + ' <VerbatimFormatted start_line="3" xml:space="preserve">', + ' Verbatim paragraph.', + ' </VerbatimFormatted>', + ' <cut start_line="5"/>', + '</Document>', +]; + +$parser->parse_lines( @$input, undef ); + +my $actual_output = [ split( "\n", $output ) ]; +cmp_deeply( $actual_output, $expected_output ) or do { + diag( 'actual output:' ); + diag( "|$_" ) for @$actual_output; + diag( 'expected output:' ); + diag( "|$_" ) for @$expected_output; +}; + +done_testing; +exit( 0 ); + diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/perlcyg.pod b/gnu/usr.bin/perl/cpan/Pod-Simple/t/perlcyg.pod index 6264a15788b..2da4b28aa65 100644 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/perlcyg.pod +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/perlcyg.pod @@ -56,7 +56,7 @@ runtime behavior (see L</"TEST">). =over 4 -=item * C<PATH> +=item * C<PATH> Set the C<PATH> environment variable so that Configure finds the Cygwin versions of programs. Any Windows directories should be removed or diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/rtf_utf8.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/rtf_utf8.t new file mode 100644 index 00000000000..0d2d8ecf731 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/rtf_utf8.t @@ -0,0 +1,220 @@ +#!/usr/bin/perl -w + +# t/rtf_utf8.t - Check that RTF works with UTF-8 input + +BEGIN { + chdir 't' if -d 't'; +} + +my $expected = join "", <DATA>; + +use strict; +use lib '../lib'; +use Test::More; +use File::Spec; + +if ($] < 5.008) { + plan skip_all => "Doesn't work before 5.8"; +} +else { + plan tests => 5; +} + +for my $format (qw(RTF)) { + my $class = "Pod::Simple::RTF"; + use_ok $class or next; + ok my $parser = $class->new, "Construct RTF parser"; + + my $output = ''; + ok $parser->output_string(\$output), "Set RTF output string"; + ok $parser->parse_file(File::Spec->catfile(qw(corpus polish_utf8.txt))), + "Parse to RTF via parse_file()"; + $output =~ s/\\info.*?author \[see doc\]\}/VARIANT TEXT DELETED/s; + $output =~ s/$/\n/; + + my $msg = "got expected output"; + if ($output eq $expected) { + pass($msg); + } + elsif ($ENV{PERL_TEST_DIFF}) { + fail($msg); + require File::Temp; + my $orig_file = File::Temp->new(); + local $/ = "\n"; + chomp $expected; + print $orig_file $expected, "\n"; + close $orig_file || die "Can't close orig_file: $!"; + + chomp $output; + my $parsed_file = File::Temp->new(); + print $parsed_file $output, "\n"; + close $parsed_file || die "Can't close parsed_file"; + + my $diff = File::Temp->new(); + system("$ENV{PERL_TEST_DIFF} $orig_file $parsed_file > $diff"); + + open my $fh, "<", $diff || die "Can't open $diff"; + my @diffs = <$fh>; + diag(@diffs); + } + else { + eval { require Text::Diff; }; + if ($@) { + is($output, $expected, $msg); + diag("Set environment variable PERL_TEST_DIFF=diff_tool or install" + . " Text::Diff to see just the differences."); + } + else { + fail($msg); + diag Text::Diff::diff(\$expected, \$output, { STYLE => 'Unified' }); + } + } +} + +__DATA__ +{\rtf1\ansi\deff0 + +{\fonttbl +{\f0\froman Times New Roman;} +{\f1\fmodern Courier New;} +{\f2\fswiss Arial;} +} + +{\stylesheet +{\snext0 Normal;} +{\*\cs10 \additive Default Paragraph Font;} +{\*\cs16 \additive \i \sbasedon10 pod-I;} +{\*\cs17 \additive \i\lang1024\noproof \sbasedon10 pod-F;} +{\*\cs18 \additive \b \sbasedon10 pod-B;} +{\*\cs19 \additive \f1\lang1024\noproof\sbasedon10 pod-C;} +{\s20\ql \li0\ri0\sa180\widctlpar\f1\fs18\lang1024\noproof\sbasedon0 \snext0 pod-codeblock;} +{\*\cs21 \additive \lang1024\noproof \sbasedon10 pod-computerese;} +{\*\cs22 \additive \i\lang1024\noproof\sbasedon10 pod-L-pod;} +{\*\cs23 \additive \i\lang1024\noproof\sbasedon10 pod-L-url;} +{\*\cs24 \additive \i\lang1024\noproof\sbasedon10 pod-L-man;} + +{\*\cs25 \additive \f1\lang1024\noproof\sbasedon0 pod-codelbock-plain;} +{\*\cs26 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-ital;} +{\*\cs27 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold;} +{\*\cs28 \additive \f1\lang1024\noproof\sbasedon25 pod-codelbock-bold-ital;} + +{\s31\ql \keepn\sb90\sa180\f2\fs32\ul\sbasedon0 \snext0 pod-head1;} +{\s32\ql \keepn\sb90\sa180\f2\fs28\ul\sbasedon0 \snext0 pod-head2;} +{\s33\ql \keepn\sb90\sa180\f2\fs25\ul\sbasedon0 \snext0 pod-head3;} +{\s34\ql \keepn\sb90\sa180\f2\fs22\ul\sbasedon0 \snext0 pod-head4;} +} + +{\colortbl;\red255\green0\blue0;\red0\green0\blue255;} +{VARIANT TEXT DELETED{\company [see doc]}{\operator [see doc]} +} + +\deflang1033\plain\lang1033\widowctrl +{\header\pard\qr\plain\f2\fs17 +W\uc1\u346?R\'d3D NOCNEJ CISZY \_\_ explicitly utf8 test document in Polish, +p.\chpgn\par} +\fs25 + + + +{\pard\li0\s31\keepn\sb90\sa180\f2\fs32\ul{ +NAME +}\par} + +{\pard\li0\sa180 +W\uc1\u346?R\'d3D NOCNEJ CISZY \_\_ explicitly utf8 test document +in Polish +\par} + +{\pard\li0\s31\keepn\sb90\sa180\f2\fs32\ul{ +DESCRIPTION +}\par} + +{\pard\li0\sa180 +This is a test Pod document in UT\'468. Its content is the lyrics +to the Polish Christmas carol "W\uc1\u347?r\'f3d nocnej ciszy", except +it includes a few lines to test RT\'46 specially. +\par} + +{\pard\li0\sa180 +\uc1\u-1280? is a character in the upper half of Plane 0, so should +be negative in RT\'46 \uc1\u-10187\u-8904? is a character in Plane +1, so should be expressed as a surrogate pair in RT\'46 +\par} + +{\pard\li0\sa180 +All the ASCII printables !"#$%&\'5c'()*+,\_./0123456789:;<=>?@ ABCDE\'46GHIJKLMNOPQRSTUVWXYZ[{ +\cs21\lang1024\noproof \'5c]^\'5f`} abcdefghijklmnopqrstuvwxyz\'7b|\'7d~ +\par} + +{\pard\li0\sa180 +W\uc1\u347?r\'f3d nocnej ciszy g\uc1\u322?os si\uc1\u281? rozchodzi: +/ Wsta\uc1\u324?cie, pasterze, B\'f3g si\uc1\u281? nam rodzi! / Czym +pr\uc1\u281?dzej si\uc1\u281? wybierajcie, / Do Betlejem pospieszajcie +/ Przywita\uc1\u263? Pana. +\par} + +{\pard\li0\sa180 +Poszli, znale\uc1\u378?li Dzieci\uc1\u261?tko w \uc1\u380?\uc1\u322?obie +/ Z wszystkimi znaki danymi sobie. / Jako Bogu cze\uc1\u347?\uc1\u263? +Mu dali, / A witaj\uc1\u261?c zawo\uc1\u322?ali / Z wielkiej rado\uc1\u347?ci: +\par} + +{\pard\li0\sa180 +Ach, witaj Zbawco z dawno \uc1\u380?\uc1\u261?dany, / Wiele tysi\uc1\u281?cy +lat wygl\uc1\u261?dany / Na Ciebie kr\'f3le, prorocy / Czekali, a +Ty\uc1\u347? tej nocy / Nam si\uc1\u281? objawi\uc1\u322?. +\par} + +{\pard\li0\sa180 +I my czekamy na Ciebie, Pana, / A skoro przyjdziesz na g\uc1\u322?os +kap\uc1\u322?ana, / Padniemy na twarz przed Tob\uc1\u261?, / Wierz\uc1\u261?c, +\uc1\u380?e\uc1\u347? jest pod os\uc1\u322?on\uc1\u261? / Chleba i +wina. +\par} + +{\pard\li0\s32\keepn\sb90\sa180\f2\fs28\ul{ +As Verbatim +}\par} + +{\pard\li0\sa180 +And now as verbatim text: +\par} + +{\pard\li0\plain\s20\sa180\f1\fs18\lang1024\noproof + \uc1\u-1280? upper half, Plane 0\line + \uc1\u-10187\u-8904? Plane 1\line +\line + All the ASCII printables\line + !"#$%&\'5c'()*+,-./0123456789:;<=>?@\line + ABCDE\'46GHIJKLMNOPQRSTUVWXYZ[\'5c]^\'5f`\line + abcdefghijklmnopqrstuvwxyz\'7b|\'7d~\line +\line + W\uc1\u347?r\'f3d nocnej ciszy g\uc1\u322?os si\uc1\u281? rozchodzi:\line + Wsta\uc1\u324?cie, pasterze, B\'f3g si\uc1\u281? nam rodzi!\line + Czym pr\uc1\u281?dzej si\uc1\u281? wybierajcie,\line + Do Betlejem pospieszajcie\line + Przywita\uc1\u263? Pana.\line +\line + Poszli, znale\uc1\u378?li Dzieci\uc1\u261?tko w \uc1\u380?\uc1\u322?obie\line + Z wszystkimi znaki danymi sobie.\line + Jako Bogu cze\uc1\u347?\uc1\u263? Mu dali,\line + A witaj\uc1\u261?c zawo\uc1\u322?ali\line + Z wielkiej rado\uc1\u347?ci:\line +\line + Ach, witaj Zbawco z dawno \uc1\u380?\uc1\u261?dany,\line + Wiele tysi\uc1\u281?cy lat wygl\uc1\u261?dany\line + Na Ciebie kr\'f3le, prorocy\line + Czekali, a Ty\uc1\u347? tej nocy\line + Nam si\uc1\u281? objawi\uc1\u322?.\line +\line + I my czekamy na Ciebie, Pana,\line + A skoro przyjdziesz na g\uc1\u322?os kap\uc1\u322?ana,\line + Padniemy na twarz przed Tob\uc1\u261?,\line + Wierz\uc1\u261?c, \uc1\u380?e\uc1\u347? jest pod os\uc1\u322?on\uc1\u261?\line + Chleba i wina. +\par} + +{\pard\li0\sa180 +[end] +\par} +} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60.t new file mode 100644 index 00000000000..4ffbbb173a1 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60.t @@ -0,0 +1,56 @@ +BEGIN {
+ if($ENV{PERL_CORE}) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+use Pod::Simple::Search;
+use Test;
+BEGIN { plan tests => 4 }
+
+print "# ", __FILE__,
+ ": Testing forced case sensitivity ...\n";
+
+my $x = Pod::Simple::Search->new;
+die "Couldn't make an object!?" unless ok defined $x;
+
+$x->inc(0);
+$x->is_case_insensitive(0);
+
+use File::Spec;
+use Cwd;
+my $cwd = cwd();
+print "# CWD: $cwd\n";
+
+sub source_path {
+ my $file = shift;
+ if ($ENV{PERL_CORE}) {
+ my $updir = File::Spec->updir;
+ my $dir = File::Spec->catdir($updir, 'lib', 'Pod', 'Simple', 't');
+ return File::Spec->catdir ($dir, $file);
+ } else {
+ return $file;
+ }
+}
+
+my($A, $B);
+
+if( -e ($A = source_path( 'search60/A' ))) {
+ die "But where's $B?"
+ unless -e ($B = source_path( 'search60/B'));
+} elsif( -e ($A = File::Spec->catdir($cwd, 't', 'search60', 'A' ))) {
+ die "But where's $B?"
+ unless -e ($B = File::Spec->catdir($cwd, 't', 'search60', 'B'));
+} else {
+ die "Can't find the test corpora";
+}
+print "# OK, found the test corpora\n# as $A\n# and $B\n#\n";
+ok 1;
+
+my($name2where, $where2name) = $x->survey($A, $B);
+
+ok ($name2where->{x} =~ m{^\Q$A\E[\\/]x\.pod$});
+
+ok ($name2where->{X} =~ m{^\Q$B\E[\\/]X\.pod$});
diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60/A/x.pod b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60/A/x.pod new file mode 100644 index 00000000000..393200433bb --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60/A/x.pod @@ -0,0 +1 @@ +=head1 x
diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60/B/X.pod b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60/B/X.pod new file mode 100644 index 00000000000..654c580f8a9 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/search60/B/X.pod @@ -0,0 +1 @@ +=head1 X
diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/strpvbtm.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/strpvbtm.t index 8650fb8131b..25c41cc55bd 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/strpvbtm.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/strpvbtm.t @@ -8,7 +8,7 @@ BEGIN { use strict; use lib '../lib'; -use Test::More tests => 87; +use Test::More tests => 103; #use Test::More 'no_plan'; use_ok('Pod::Simple::XHTML') or exit; @@ -116,3 +116,42 @@ for my $spec ( ok $p->parse_string_document( $pod ), "Parse POD to XHTML for $desc"; is $output, $xhtml, "Should have expected XHTML output for $desc"; } + +for my $spec ( + [ + "\n=pod\n\n\t\tfoo bar baz\n", + 0, + "<pre><code>\t\tfoo bar baz</code></pre>\n\n", + 'preserve tabs' + ], + [ + "\n=pod\n\n\t\tfoo bar baz\n", + undef, + "<pre><code> foo bar baz</code></pre>\n\n", + 'preserve tabs' + ], + [ + "\n=pod\n\n\t\tfoo bar baz\n", + -1, + "<pre><code> foo bar baz</code></pre>\n\n", + 'preserve tabs' + ], + [ + "\n=pod\n\n\t\tfoo bar baz\n", + 1, + "<pre><code> foo bar baz</code></pre>\n\n", + 'tabs are xlate to one space each' + ], +) { + my ($pod, $tabs, $xhtml, $desc) = @$spec; + # Test XHTML output. + ok my $p = Pod::Simple::XHTML->new, "Construct XHMTL parser to test $desc"; + $p->html_header(''); + $p->html_footer(''); + my $output = ''; + $p->output_string( \$output ); + is $tabs, $p->expand_verbatim_tabs($tabs), + 'Set tab for XHTML to ' . (defined $tabs ? qq{"$tabs"} : 'undef'); + ok $p->parse_string_document( $pod ), "Parse POD to XHTML for $desc"; + is $output, $xhtml, "Should have expected XHTML output for $desc"; +} diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/testlib2/pods/perlzoned.pod b/gnu/usr.bin/perl/cpan/Pod-Simple/t/testlib2/pods/perlzoned.pod new file mode 100644 index 00000000000..66dcbf4172f --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/testlib2/pods/perlzoned.pod @@ -0,0 +1,5 @@ +=head1 NAME + +perlzoned - This is just some test file + +=cut diff --git a/gnu/usr.bin/perl/cpan/Pod-Simple/t/x_nixer.t b/gnu/usr.bin/perl/cpan/Pod-Simple/t/x_nixer.t index 34018109c57..3787006266c 100755 --- a/gnu/usr.bin/perl/cpan/Pod-Simple/t/x_nixer.t +++ b/gnu/usr.bin/perl/cpan/Pod-Simple/t/x_nixer.t @@ -184,7 +184,7 @@ ok( Pod::Simple::DumpAsXML->_out( \&nixy_mergy, "=pod\n\nZ<>F<C<Z<>fE<111>L<E<78 ' <F>', ' <C>', ' fo', - ' <L content-implicit="yes" section="Ping-pong" to="Net::Ping" type="pod">', + ' <L content-implicit="yes" raw="E<78>et::Ping/Ping-E<112>ong" section="Ping-pong" to="Net::Ping" type="pod">', ' "Ping-pong" in Net::Ping', ' </L>', ' o', diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/Makefile.PL b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/Makefile.PL index 37bd104b409..3dc13d769fd 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/Makefile.PL +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/Makefile.PL @@ -6,12 +6,13 @@ use Config; use File::Spec; use ExtUtils::MakeMaker; my $PERL_CORE = grep { $_ eq 'PERL_CORE=1' } @ARGV; +my $defines = $ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H]; -WriteMakefile( +my %params = ( NAME => q[List::Util], ABSTRACT => q[Common Scalar and List utility subroutines], AUTHOR => q[Graham Barr <gbarr@cpan.org>], - DEFINE => ($ENV{PERL_CORE} ? q[-DPERL_EXT] : q[-DPERL_EXT -DUSE_PPPORT_H]), + DEFINE => $defines, DISTNAME => q[Scalar-List-Utils], VERSION_FROM => 'lib/List/Util.pm', @@ -29,7 +30,9 @@ WriteMakefile( ? () : ( INSTALLDIRS => ($] < 5.011 ? q[perl] : q[site]), - PREREQ_PM => {'Test::More' => 0,}, + TEST_REQUIRES => { + 'Test::More' => 0, + }, (eval { ExtUtils::MakeMaker->VERSION(6.31) } ? (LICENSE => 'perl') : ()), (eval { ExtUtils::MakeMaker->VERSION(6.48) } ? (MIN_PERL_VERSION => '5.006') : ()), ( eval { ExtUtils::MakeMaker->VERSION(6.46) } ? ( @@ -54,3 +57,18 @@ WriteMakefile( ) ), ); + +if ($params{TEST_REQUIRES} and !eval { ExtUtils::MakeMaker->VERSION(6.64) }) { + $params{BUILD_REQUIRES} = { + %{$params{BUILD_REQUIRES} || {}}, + %{delete $params{TEST_REQUIRES}}, + }; +} +if ($params{BUILD_REQUIRES} and !eval { ExtUtils::MakeMaker->VERSION(6.5503) }) { + $params{PREREQ_PM} = { + %{$params{PREREQ_PM} || {}}, + %{delete $params{BUILD_REQUIRES}}, + }; +} + +WriteMakefile(%params); 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 cb5d2cc9f2d..3c5f212325d 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 @@ -13,10 +13,10 @@ BEGIN { $^P |= 0x210 } use if $] >= 5.016, feature => 'unicode_eval'; if ($] >= 5.008) { - my $builder = Test::More->builder; - binmode $builder->output, ":encoding(utf8)"; - binmode $builder->failure_output, ":encoding(utf8)"; - binmode $builder->todo_output, ":encoding(utf8)"; + my $builder = Test::More->builder; + binmode $builder->output, ":encoding(utf8)"; + binmode $builder->failure_output, ":encoding(utf8)"; + binmode $builder->todo_output, ":encoding(utf8)"; } sub compile_named_sub { diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reductions.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reductions.t new file mode 100644 index 00000000000..fd669f14c75 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/reductions.t @@ -0,0 +1,51 @@ +#!./perl + +use strict; +use warnings; + +use Test::More tests => 7; + +use List::Util qw( reductions ); + +is_deeply( [ reductions { } ], [], + 'emmpty list' +); + +is_deeply( + [ reductions { $a + $b } 1 .. 5 ], + [ 1, 3, 6, 10, 15 ], + 'sum 1..5' +); + +# We don't guarantee what this will return but it definitely shouldn't crash +{ + my $ret = reductions { $a + $b } 1 .. 3; + pass( 'reductions in scalar context does not crash' ); +} + +my $destroyed_count; +sub Guardian::DESTROY { $destroyed_count++ } + +{ + undef $destroyed_count; + + my @ret = reductions { $b } map { bless [], "Guardian" } 1 .. 5; + + ok( !$destroyed_count, 'nothing destroyed yet' ); + + @ret = (); + + is( $destroyed_count, 5, 'all the items were destroyed' ); +} + +{ + undef $destroyed_count; + + ok( !defined eval { + reductions { die "stop" if $b == 4; bless [], "Guardian" } 1 .. 4; + 1 + }, 'die in BLOCK is propagated' + ); + + is( $destroyed_count, 2, 'intermediate temporaries are destroyed after exception' ); +} diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sample.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sample.t new file mode 100644 index 00000000000..09275719488 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/sample.t @@ -0,0 +1,73 @@ +#!./perl + +use strict; +use warnings; + +use Test::More tests => 9; + +use List::Util qw(sample); + +{ + my @items = sample 3, 1 .. 10; + is( scalar @items, 3, 'returns correct count when plentiful' ); + + @items = sample 10, 1 .. 10; + is( scalar @items, 10, 'returns correct count when exact' ); + + @items = sample 20, 1 .. 10; + is( scalar @items, 10, 'returns correct count when short' ); +} + +{ + my @items = sample 5, 1 .. 5; + is_deeply( [ sort { $a <=> $b } @items ], [ 1 .. 5 ], + 'returns a permutation of the input list when exact' ); +} + +{ + # These two seeds happen to give different results for me, but there is the + # smallest 1-in-2**48 chance that they happen to agree on some platform. If + # so then pick a different seed value. + + srand 1234; + my $x = join "", sample 3, 'a'..'z'; + + srand 5678; + my $y = join "", sample 3, 'a'..'z'; + + isnt( $x, $y, 'returns different result on different random seed' ); + + srand; +} + +{ + my @nums = ( 1..5 ); + sample 5, @nums; + + is_deeply( \@nums, [ 1..5 ], + 'sample does not mutate passed array' + ); +} + +{ + my $destroyed_count; + sub Guardian::DESTROY { $destroyed_count++ } + + my @ret = sample 3, map { bless [], "Guardian" } 1 .. 10; + + is( $destroyed_count, 7, 'the 7 unselected items were destroyed' ); + + @ret = (); + + is( $destroyed_count, 10, 'all the items were destroyed' ); +} + +{ + local $List::Util::RAND = sub { 4/10 }; + + is( + join( "", sample 5, 'A'..'Z' ), + join( "", sample 5, 'A'..'Z' ), + 'rigged rand() yields predictable output' + ); +} diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t index e9b653a6667..8d70a77cfd7 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/scalarutil-proto.t @@ -5,48 +5,48 @@ use warnings; use Scalar::Util (); use Test::More (grep { /set_prototype/ } @Scalar::Util::EXPORT_FAIL) - ? (skip_all => 'set_prototype requires XS version') - : (tests => 14); + ? (skip_all => 'set_prototype requires XS version') + : (tests => 14); Scalar::Util->import('set_prototype'); sub f { } -is( prototype('f'), undef, 'no prototype'); +is( prototype('f'), undef, 'no prototype'); my $r = set_prototype(\&f,'$'); -is( prototype('f'), '$', 'set prototype'); -is( $r, \&f, 'return value'); +is( prototype('f'), '$', 'set prototype'); +is( $r, \&f, 'return value'); set_prototype(\&f,undef); -is( prototype('f'), undef, 'remove prototype'); +is( prototype('f'), undef, 'remove prototype'); set_prototype(\&f,''); -is( prototype('f'), '', 'empty prototype'); +is( prototype('f'), '', 'empty prototype'); sub g (@) { } -is( prototype('g'), '@', '@ prototype'); +is( prototype('g'), '@', '@ prototype'); set_prototype(\&g,undef); -is( prototype('g'), undef, 'remove prototype'); +is( prototype('g'), undef, 'remove prototype'); sub stub; -is( prototype('stub'), undef, 'non existing sub'); +is( prototype('stub'), undef, 'non existing sub'); set_prototype(\&stub,'$$$'); -is( prototype('stub'), '$$$', 'change non existing sub'); +is( prototype('stub'), '$$$', 'change non existing sub'); sub f_decl ($$$$); -is( prototype('f_decl'), '$$$$', 'forward declaration'); +is( prototype('f_decl'), '$$$$', 'forward declaration'); set_prototype(\&f_decl,'\%'); -is( prototype('f_decl'), '\%', 'change forward declaration'); +is( prototype('f_decl'), '\%', 'change forward declaration'); eval { &set_prototype( 'f', '' ); }; print "not " unless -ok($@ =~ /^set_prototype: not a reference/, 'not a reference'); +ok($@ =~ /^set_prototype: not a reference/, 'not a reference'); eval { &set_prototype( \'f', '' ); }; -ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference'); +ok($@ =~ /^set_prototype: not a subroutine reference/, 'not a sub reference'); # RT 72080 diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t index 1bf8a9f698e..c78a70043f6 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/subname.t @@ -3,10 +3,11 @@ use warnings; BEGIN { $^P |= 0x210 } -use Test::More tests => 18; +use Test::More tests => 21; use B::Deparse; use Sub::Util qw( subname set_subname ); +use Symbol qw( delete_package ) ; { sub localfunc {} @@ -78,4 +79,18 @@ is($x->(), "main::foo"); 'subname of set_subname'); } +# this used to segfault + +{ + sub ToDelete::foo {} + + my $foo = \&ToDelete::foo; + + delete_package 'ToDelete'; + + is( subname($foo), "$]" >= 5.010 ? '__ANON__::foo' : 'ToDelete::foo', 'subname in deleted package' ); + ok( set_subname('NewPackage::foo', $foo), 'rename from deleted package' ); + is( subname($foo), 'NewPackage::foo', 'subname after rename' ); +} + # vim: ft=perl diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniq.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniq.t index 8806b8e7d7d..c55f03a6382 100644 --- a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniq.t +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniq.t @@ -2,9 +2,9 @@ use strict; use warnings; - -use Test::More tests => 30; -use List::Util qw( uniqnum uniqstr uniq ); +use Config; # to determine ivsize +use Test::More tests => 31; +use List::Util qw( uniqstr uniqint uniq ); use Tie::Array; @@ -67,48 +67,52 @@ SKIP: { is( $warnings, "", 'No warnings are printed when handling Unicode strings' ); } -is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ], - [ 1, 2, 3 ], - 'uniqnum compares numbers' ); - -is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ], - [ 1, 1.1, 1.2, 1.3 ], - 'uniqnum distinguishes floats' ); - -# Hard to know for sure what an Inf is going to be. Lets make one -my $Inf = 0 + 1E1000; -my $NaN; -$Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN; - -is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ], - [ 0, 1, 12345, $Inf, -$Inf, $NaN ], - 'uniqnum preserves the special values of +-Inf and Nan' ); +is_deeply( [ uniqint ], + [], + 'uniqint of empty list' ); -{ - my $maxuint = ~0; - my $maxint = ~0 >> 1; - my $minint = -(~0 >> 1) - 1; +is_deeply( [ uniqint 5, 5 ], + [ 5 ], + 'uniqint of repeated-element list' ); - my @nums = ($maxuint, $maxuint-1, -1, $Inf, $NaN, $maxint, $minint, 1 ); +is_deeply( [ uniqint 1, 2, 1, 3 ], + [ 1, 2, 3 ], + 'uniqint removes subsequent duplicates' ); - is_deeply( [ uniqnum @nums, 1.0 ], - [ @nums ], - 'uniqnum preserves uniqness of full integer range' ); -} +is_deeply( [ uniqint 6.1, 6.2, 6.3 ], + [ 6 ], + 'uniqint compares as and returns integers' ); { my $warnings = ""; local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; - is_deeply( [ uniqnum 0, undef ], + is_deeply( [ uniqint 0, undef ], [ 0 ], - 'uniqnum considers undef and zero equivalent' ); + 'uniqint considers undef and zero equivalent' ); - ok( length $warnings, 'uniqnum on undef yields a warning' ); + ok( length $warnings, 'uniqint on undef yields a warning' ); - is_deeply( [ uniqnum undef ], + is_deeply( [ uniqint undef ], [ 0 ], - 'uniqnum on undef coerces to zero' ); + 'uniqint on undef coerces to zero' ); +} + +SKIP: { + skip('UVs are not reliable on this perl version', 2) unless $] ge "5.008000"; + + my $maxbits = $Config{ivsize} * 8 - 1; + + # An integer guaranteed to be a UV + my $uv = 1 << $maxbits; + is_deeply( [ uniqint $uv, $uv + 1 ], + [ $uv, $uv + 1 ], + 'uniqint copes with UVs' ); + + my $nvuv = 2 ** $maxbits; + is_deeply( [ uniqint $nvuv, 0 ], + [ int($nvuv), 0 ], + 'uniqint copes with NVUV dualvars' ); } is_deeply( [ uniq () ], @@ -148,24 +152,21 @@ is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' ); 'uniqstr respects stringify overload' ); } -{ - package Numify; +SKIP: { + skip('int overload requires perl version 5.8.0', 1) unless $] ge "5.008000"; - use overload '0+' => sub { return $_[0]->{num} }; + package Googol; - sub new { bless { num => $_[1] }, $_[0] } + use overload '""' => sub { "1" . ( "0"x100 ) }, + 'int' => sub { $_[0] }; - package main; - use Scalar::Util qw( refaddr ); + sub new { bless {}, $_[0] } - my @nums = map { Numify->new( $_ ) } qw( 2 2 5 ); + package main; - # is_deeply wants to use eq overloading - my @ret = uniqnum @nums; - ok( scalar @ret == 2 && - refaddr $ret[0] == refaddr $nums[0] && - refaddr $ret[1] == refaddr $nums[2], - 'uniqnum respects numify overload' ); + is_deeply( [ uniqint( Googol->new, Googol->new ) ], + [ "1" . ( "0"x100 ) ], + 'uniqint respects int overload' ); } { @@ -198,11 +199,6 @@ is( scalar( uniqstr qw( a b c d a b e ) ), 5, 'uniqstr() in scalar context' ); is_deeply( [ uniqstr $1, $2, $3 ], [qw( a b )], 'uniqstr handles magic' ); - - "1 1 2" =~ m/(.) (.) (.)/; - is_deeply( [ uniqnum $1, $2, $3 ], - [ 1, 2 ], - 'uniqnum handles magic' ); } { diff --git a/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniqnum.t b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniqnum.t new file mode 100644 index 00000000000..d34d2c7747f --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Scalar-List-Utils/t/uniqnum.t @@ -0,0 +1,329 @@ +#!./perl + +use strict; +use warnings; +use Config; # to determine nvsize +use Test::More tests => 23; +use List::Util qw( uniqnum ); + +is_deeply( [ uniqnum qw( 1 1.0 1E0 2 3 ) ], + [ 1, 2, 3 ], + 'uniqnum compares numbers' ); + +is_deeply( [ uniqnum qw( 1 1.1 1.2 1.3 ) ], + [ 1, 1.1, 1.2, 1.3 ], + 'uniqnum distinguishes floats' ); + +{ + my @nums = map $_+0.1, 1e7..1e7+5; + is_deeply( [ uniqnum @nums ], + [ @nums ], + 'uniqnum distinguishes large floats' ); + + my @strings = map "$_", @nums; + is_deeply( [ uniqnum @strings ], + [ @strings ], + 'uniqnum distinguishes large floats (stringified)' ); +} + +my ($uniq_count1, $uniq_count2, $equiv); + +if($Config{nvsize} == 8) { + # NV is either 'double' or 8-byte 'long double' + + # The 2 values should be unequal - but just in case perl is buggy: + $equiv = 1 if 1.4142135623730951 == 1.4142135623730954; + + $uniq_count1 = uniqnum (1.4142135623730951, + 1.4142135623730954 ); + + $uniq_count2 = uniqnum('1.4142135623730951', + '1.4142135623730954' ); +} + +elsif(length(sqrt(2)) > 25) { + # NV is either IEEE 'long double' or '__float128' or doubledouble + + if(1 + (2 ** -1074) != 1) { + # NV is doubledouble + + # The 2 values should be unequal - but just in case perl is buggy: + $equiv = 1 if 1 + (2 ** -1074) == 1 + (2 ** - 1073); + + $uniq_count1 = uniqnum (1 + (2 ** -1074), + 1 + (2 ** -1073) ); + # The 2 values should be unequal - but just in case perl is buggy: + $equiv = 1 if 4.0564819207303340847894502572035e31 == 4.0564819207303340847894502572034e31; + + $uniq_count2 = uniqnum('4.0564819207303340847894502572035e31', + '4.0564819207303340847894502572034e31' ); + } + + else { + # NV is either IEEE 'long double' or '__float128' + + # The 2 values should be unequal - but just in case perl is buggy: + $equiv = 1 if 1005.10228292019306452029161597769015 == 1005.1022829201930645202916159776901; + + $uniq_count1 = uniqnum (1005.10228292019306452029161597769015, + 1005.1022829201930645202916159776901 ); + + $uniq_count2 = uniqnum('1005.10228292019306452029161597769015', + '1005.1022829201930645202916159776901' ); + } +} + +else { + # NV is extended precision 'long double' + + # The 2 values should be unequal - but just in case perl is buggy: + $equiv = 1 if 10.770329614269008063 == 10.7703296142690080625; + + $uniq_count1 = uniqnum (10.770329614269008063, + 10.7703296142690080625 ); + + $uniq_count2 = uniqnum('10.770329614269008063', + '10.7703296142690080625' ); +} + +if($equiv) { + is($uniq_count1, 1, 'uniqnum preserves uniqueness of high precision floats'); + is($uniq_count2, 1, 'uniqnum preserves uniqueness of high precision floats (stringified)'); +} + +else { + is($uniq_count1, 2, 'uniqnum preserves uniqueness of high precision floats'); + is($uniq_count2, 2, 'uniqnum preserves uniqueness of high precision floats (stringified)'); +} + +SKIP: { + skip ('test not relevant for this perl configuration', 1) unless $Config{nvsize} == 8 + && $Config{ivsize} == 8; + + my @in = (~0, ~0 - 1, 18446744073709551614.0, 18014398509481985, 1.8014398509481985e16); + my(@correct); + + # On perl-5.6.2 (and perhaps other old versions), ~0 - 1 is assigned to an NV. + # This affects the outcome of the following test, so we need to first determine + # whether ~0 - 1 is an NV or a UV: + + if("$in[1]" eq "1.84467440737096e+19") { + + # It's an NV and $in[2] is a duplicate of $in[1] + @correct = (~0, ~0 - 1, 18014398509481985, 1.8014398509481985e16); + } + else { + + # No duplicates in @in + @correct = @in; + } + + is_deeply( [ uniqnum @in ], + [ @correct ], + 'uniqnum correctly compares UV/IVs that overflow NVs' ); +} + +my $ls = 31; # maximum left shift for 32-bit unity + +if( $Config{ivsize} == 8 ) { + $ls = 63; # maximum left shift for 64-bit unity +} + +# Populate @in with UV-NV pairs of equivalent values. +# Each of these values is exactly representable as +# either a UV or an NV. + +my @in = (1 << $ls, 2 ** $ls, + 1 << ($ls - 3), 2 ** ($ls - 3), + 5 << ($ls - 3), 5 * (2 ** ($ls - 3))); + +my @correct = (1 << $ls, 1 << ($ls - 3), 5 << ($ls -3)); + +if( $Config{ivsize} == 8 && $Config{nvsize} == 8 ) { + + # Add some more UV-NV pairs of equivalent values. + # Each of these values is exactly representable + # as either a UV or an NV. + + push @in, ( 9007199254740991, 9.007199254740991e+15, + 9007199254740992, 9.007199254740992e+15, + 9223372036854774784, 9.223372036854774784e+18, + 18446744073709549568, 1.8446744073709549568e+19, + 18446744073709139968, 1.8446744073709139968e+19, + 100000000000262144, 1.00000000000262144e+17, + 100000000001310720, 1.0000000000131072e+17, + 144115188075593728, 1.44115188075593728e+17, + -9007199254740991, -9.007199254740991e+15, + -9007199254740992, -9.007199254740992e+15, + -9223372036854774784, -9.223372036854774784e+18, + -18446744073709549568, -1.8446744073709549568e+19, + -18446744073709139968, -1.8446744073709139968e+19, + -100000000000262144, -1.00000000000262144e+17, + -100000000001310720, -1.0000000000131072e+17, + -144115188075593728, -1.44115188075593728e+17 ); + + push @correct, ( 9007199254740991, + 9007199254740992, + 9223372036854774784, + 18446744073709549568, + 18446744073709139968, + 100000000000262144, + 100000000001310720, + 144115188075593728, + -9007199254740991, + -9007199254740992, + -9223372036854774784, + -18446744073709549568, + -18446744073709139968, + -100000000000262144, + -100000000001310720, + -144115188075593728 ); +} + +# uniqnum should discard each of the NVs as being a +# duplicate of the preceding UV. + +is_deeply( [ uniqnum @in], + [ @correct], + 'uniqnum correctly compares UV/IVs that don\'t overflow NVs' ); + +# Hard to know for sure what an Inf is going to be. Lets make one +my $Inf = 0 + 1E1000; +my $NaN; +$Inf **= 1000 while ( $NaN = $Inf - $Inf ) == $NaN; + +is_deeply( [ uniqnum 0, 1, 12345, $Inf, -$Inf, $NaN, 0, $Inf, $NaN ], + [ 0, 1, 12345, $Inf, -$Inf, $NaN ], + 'uniqnum preserves the special values of +-Inf and Nan' ); + +SKIP: { + my $maxuint = ~0; + my $maxint = ~0 >> 1; + my $minint = -(~0 >> 1) - 1; + + my @nums = ($maxuint, $maxuint-1, -1, $maxint, $minint, 1 ); + + { + use warnings FATAL => 'numeric'; + if (eval { + "$Inf" + 0 == $Inf + }) { + push @nums, $Inf; + } + if (eval { + my $nanish = "$NaN" + 0; + $nanish != 0 && !$nanish != $NaN; + }) { + push @nums, $NaN; + } + } + + is_deeply( [ uniqnum @nums, 1.0 ], + [ @nums ], + 'uniqnum preserves uniqueness of full integer range' ); + + my @strs = map "$_", @nums; + + if($maxuint !~ /\A[0-9]+\z/) { + skip( "Perl $] doesn't stringify UV_MAX right ($maxuint)", 1 ); + } + + is_deeply( [ uniqnum @strs, "1.0" ], + [ @strs ], + 'uniqnum preserves uniqueness of full integer range (stringified)' ); +} + +{ + my @nums = (6.82132005170133e-38, 62345678); + is_deeply( [ uniqnum @nums ], [ @nums ], + 'uniqnum keeps uniqueness of numbers that stringify to the same byte pattern as a float' + ); +} + +{ + my $warnings = ""; + local $SIG{__WARN__} = sub { $warnings .= join "", @_ }; + + is_deeply( [ uniqnum 0, undef ], + [ 0 ], + 'uniqnum considers undef and zero equivalent' ); + + ok( length $warnings, 'uniqnum on undef yields a warning' ); + + is_deeply( [ uniqnum undef ], + [ 0 ], + 'uniqnum on undef coerces to zero' ); +} + +is_deeply( [uniqnum 0, -0.0 ], + [0], + 'uniqnum handles negative zero'); + +SKIP: { + skip ('test not relevant for this perl configuration', 4) unless $Config{ivsize} == 8; + + # 1e17 is the number beyond which "%.20g" formatting fails on some + # 64-bit int perls. + # The following 2 tests check that the nearest values (both above + # and below that tipping point) are being handled correctly. + + # 99999999999999984 is the largest 64-bit integer less than 1e17 + # that can be expressed exactly as a double + + is_deeply( [ uniqnum (99999999999999984, 99999999999999984.0) ], + [ (99999999999999984) ], + 'uniqnum recognizes 99999999999999984 and 99999999999999984.0 as the same' ); + + is_deeply( [ uniqnum (-99999999999999984, -99999999999999984.0) ], + [ (-99999999999999984) ], + 'uniqnum recognizes -99999999999999984 and -99999999999999984.0 as the same' ); + + # 100000000000000016 is the smallest positive 64-bit integer greater than 1e17 + # that can be expressed exactly as a double + + is_deeply( [ uniqnum (100000000000000016, 100000000000000016.0) ], + [ (100000000000000016) ], + 'uniqnum recognizes 100000000000000016 and 100000000000000016.0 as the same' ); + + is_deeply( [ uniqnum (-100000000000000016, -100000000000000016.0) ], + [ (-100000000000000016) ], + 'uniqnum recognizes -100000000000000016 and -100000000000000016.0 as the same' ); +} + +# uniqnum not confused by IV'ified floats +SKIP: { + # This fails on 5.6 and isn't fixable without breaking a lot of other tests + skip 'This perl version gets confused by IVNV dualvars', 1 if $] lt '5.008000'; + my @nums = ( 2.1, 2.2, 2.3 ); + my $dummy = sprintf "%d", $_ for @nums; + + # All @nums now have both NOK and IOK but IV=2 in each case + is( scalar( uniqnum @nums ), 3, 'uniqnum not confused by dual IV+NV' ); +} + +{ + package Numify; + + use overload '0+' => sub { return $_[0]->{num} }; + + sub new { bless { num => $_[1] }, $_[0] } + + package main; + use Scalar::Util qw( refaddr ); + + my @nums = map { Numify->new( $_ ) } qw( 2 2 5 ); + + # is_deeply wants to use eq overloading + my @ret = uniqnum @nums; + ok( scalar @ret == 2 && + refaddr $ret[0] == refaddr $nums[0] && + refaddr $ret[1] == refaddr $nums[2], + 'uniqnum respects numify overload' ); +} + +{ + "1 1 2" =~ m/(.) (.) (.)/; + is_deeply( [ uniqnum $1, $2, $3 ], + [ 1, 2 ], + 'uniqnum handles magic' ); +} diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-21516.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-21516.t new file mode 100644 index 00000000000..f895eda22fa --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-21516.t @@ -0,0 +1,14 @@ +#!perl -wT +use strict; +use Test::More; + +plan tests => 1; + +# ---------- +# CPAN-RT#21516: closelog() wasn't correctly calling closelog_xs() when +# using the native mechanism. +# +use Sys::Syslog; +openlog("sys-syslog-test", 'pid,ndelay', 'user'); +closelog(); +is( $@, '', "was closelog_xs() correctly called?" ); diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-21866.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-21866.t new file mode 100644 index 00000000000..12cc34a9e8d --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-21866.t @@ -0,0 +1,16 @@ +#!perl -wT +use strict; +use Test::More; + +# any remaining warning should be severly punished +eval "use Test::NoWarnings"; +my $tests = $@ ? 0 : 1; +plan skip_all => "Test::NoWarnings not available" if !$tests; +plan tests => $tests; + +# ---------- +# CPAN-RT#21866: openlog() produced a "use of uninitialized value in split" +# warning when given undefined arguments. +# +use Sys::Syslog; +openlog(); diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-25488.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-25488.t new file mode 100644 index 00000000000..a8a8ed4d8b3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-25488.t @@ -0,0 +1,17 @@ +#!perl -wT +use strict; +use Test::More; + +# any remaining warning should be severly punished +eval "use Test::NoWarnings"; +my $tests = $@ ? 0 : 1; +plan skip_all => "Test::NoWarnings not available" if !$tests; +plan tests => $tests; + +# ---------- +# CPAN-RT#25488: disconnect_log() produced a "uninitialized" warning +# because $current_proto was used without being checked. +# +use Sys::Syslog qw(:standard :macros); +openlog("sys-syslog-test", "", LOG_USER); +closelog(); diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-49877.pl b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-49877.pl new file mode 100644 index 00000000000..0ec26608e68 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-49877.pl @@ -0,0 +1,19 @@ +#!perl +use strict; +#use Test::More; + +#plan tests => 2; + +# -------------------- +# CPAN-RT #49877: Options not reset after closelog() +# +use Sys::Syslog qw< :standard :macros >; + +openlog("Sys::Syslog", "pid,ndelay,perror", "user"); +syslog(info => "Lorem ipsum dolor sit amet"); +closelog(); + +openlog("Sys::Syslog", "ndelay,perror", "user"); +syslog(info => "Lorem ipsum dolor sit amet"); +closelog(); + diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-55151.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-55151.t new file mode 100644 index 00000000000..bf6c792fe12 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-55151.t @@ -0,0 +1,19 @@ +#!perl +use strict; +use Test::More; + +plan tests => 2; + +# -------------------- +# CPAN-RT #55151: Allow temporary facility in syslog() for native mechanism +# +use Sys::Syslog qw< :standard :macros >; + +openlog("Sys::Syslog", "pid,ndelay", "user"); + +eval { syslog("local0|info", "Lorem ipsum dolor sit amet") }; +is($@, "", "syslog('local0|info', ...)"); + +eval { syslog(LOG_LOCAL0|LOG_INFO, "Lorem ipsum dolor sit amet") }; +is($@, "", "syslog(LOG_LOCAL0|LOG_INFO, ...)"); + diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-64287.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-64287.t new file mode 100644 index 00000000000..bacb021d95b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/cpan-rt-64287.t @@ -0,0 +1,29 @@ +#!perl +use strict; +use Test::More; + +plan tests => 4; + +# -------------------- +# CPAN-RT #64287: Avoid memory corruption when closelog() is called twice. +# +use Sys::Syslog; + +openlog("Sys::Syslog", "pid", "user"); +syslog(debug => "Lorem ipsum dolor sit amet"); + +# first call to closelog() +eval { closelog() }; +is($@, "", "closelog()"); + +# create a variable with a reference to something +$a = {}; +isa_ok($a, "HASH"); + +# second call to closelog() +eval { closelog() }; +is($@, "", "closelog()"); + +# check that the variable still is what it's supposed to be +isa_ok($a, "HASH"); + diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog-inet-udp.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog-inet-udp.t new file mode 100644 index 00000000000..707e3ce9cec --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog-inet-udp.t @@ -0,0 +1,205 @@ +#!perl -T + +use strict; +use Config; +use FileHandle; +use File::Spec; +use Test::More; + +# we enable all Perl warnings, but we don't "use warnings 'all'" because +# we want to disable the warnings generated by Sys::Syslog +no warnings; +use warnings qw(closure deprecated exiting glob io misc numeric once overflow + pack portable recursion redefine regexp severe signal substr + syntax taint uninitialized unpack untie utf8 void); + +# if someone is using warnings::compat, the previous trick won't work, so we +# must manually disable warnings +$^W = 0 if $] < 5.006; + +my $is_Win32 = $^O =~ /win32/i; +my $is_Cygwin = $^O =~ /cygwin/i; + +# if testing in core, check that the module is at least available +if ($ENV{PERL_CORE}) { + plan skip_all => "Sys::Syslog was not build" + unless $Config{'extensions'} =~ /\bSyslog\b/; +} + +# we also need Socket +plan skip_all => "Socket was not build" + unless $Config{'extensions'} =~ /\bSocket\b/; + +my $tests; +plan tests => $tests; + +# any remaining warning should be severly punished +BEGIN { eval "use Test::NoWarnings"; $tests = $@ ? 0 : 1; } + +BEGIN { $tests += 1 } +# ok, now loads them +eval 'use Socket'; +use_ok('Sys::Syslog', ':standard', ':extended', ':macros'); + +BEGIN { $tests += 1 } +# check that the documented functions are correctly provided +can_ok( 'Sys::Syslog' => qw(openlog syslog syslog setlogmask setlogsock closelog) ); + + +BEGIN { $tests += 4 } +# check the diagnostics +# setlogsock() +eval { setlogsock() }; +like( $@, qr/^setlogsock\(\): Invalid number of arguments/, + "calling setlogsock() with no argument" ); + +eval { setlogsock(undef) }; +like( $@, qr/^setlogsock\(\): Invalid type; must be one of /, + "calling setlogsock() with undef" ); + +eval { setlogsock(\"") }; +like( $@, qr/^setlogsock\(\): Unexpected scalar reference/, + "calling setlogsock() with a scalar reference" ); + +eval { setlogsock({}) }; +like( $@, qr/^setlogsock\(\): No argument given/, + "calling setlogsock() with an empty hash reference" ); + +BEGIN { $tests += 3 } +# syslog() +eval { syslog() }; +like( $@, qr/^syslog: expecting argument \$priority/, + "calling syslog() with no argument" ); + +eval { syslog(undef) }; +like( $@, qr/^syslog: expecting argument \$priority/, + "calling syslog() with one undef argument" ); + +eval { syslog('') }; +like( $@, qr/^syslog: expecting argument \$format/, + "calling syslog() with one empty argument" ); + + +my $test_string = "uid $< is testing Perl $] syslog(3) capabilities"; +my $r = 0; + +BEGIN { $tests += 8 } +# try to open a syslog using a Unix or stream socket +SKIP: { + skip "can't connect to Unix socket: _PATH_LOG unavailable", 8 + unless -e Sys::Syslog::_PATH_LOG(); + + # The only known $^O eq 'svr4' that needs this is NCR MP-RAS, + # but assuming 'stream' in SVR4 is probably not that bad. + my $sock_type = $^O =~ /^(solaris|irix|svr4|powerux)$/ ? 'stream' : 'unix'; + + eval { setlogsock($sock_type) }; + is( $@, '', "setlogsock() called with '$sock_type'" ); + TODO: { + local $TODO = "minor bug"; + SKIP: { skip "TODO $TODO", 1 if $] < 5.006002; + ok( $r, "setlogsock() should return true: '$r'" ); + } + } + + + # open syslog with a "local0" facility + SKIP: { + # openlog() + $r = eval { openlog('perl', 'ndelay', 'local0') } || 0; + skip "can't connect to syslog", 6 if $@ =~ /^no connection to syslog available/; + is( $@, '', "openlog() called with facility 'local0'" ); + ok( $r, "openlog() should return true: '$r'" ); + + # syslog() + $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0; + is( $@, '', "syslog() called with level 'info'" ); + ok( $r, "syslog() should return true: '$r'" ); + + # closelog() + $r = eval { closelog() } || 0; + is( $@, '', "closelog()" ); + ok( $r, "closelog() should return true: '$r'" ); + } +} + +# try to open a syslog using all the available connection methods +# handle other connections in t/syslog.t + +my @passed = (); + +BEGIN { $tests += 22 * 2 } +for my $sock_type (qw(inet udp)) { + SKIP: { + skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 22 + if $sock_type eq 'stream' and grep {/pipe|unix/} @passed; + # setlogsock() called with an arrayref + $r = eval { setlogsock([$sock_type]) } || 0; + skip "can't use '$sock_type' socket", 22 unless $r; + is( $@, '', "[$sock_type] setlogsock() called with ['$sock_type']" ); + ok( $r, "[$sock_type] setlogsock() should return true: '$r'" ); + + # setlogsock() called with a single argument + $r = eval { setlogsock($sock_type) } || 0; + skip "can't use '$sock_type' socket", 20 unless $r; + is( $@, '', "[$sock_type] setlogsock() called with '$sock_type'" ); + ok( $r, "[$sock_type] setlogsock() should return true: '$r'" ); + + # openlog() without option NDELAY + $r = eval { openlog('perl', '', 'local0') } || 0; + skip "can't connect to syslog", 18 if $@ =~ /^no connection to syslog available/; + is( $@, '', "[$sock_type] openlog() called with facility 'local0' and without option 'ndelay'" ); + ok( $r, "[$sock_type] openlog() should return true: '$r'" ); + + # openlog() with the option NDELAY + $r = eval { openlog('perl', 'ndelay', 'local0') } || 0; + skip "can't connect to syslog", 16 if $@ =~ /^no connection to syslog available/; + is( $@, '', "[$sock_type] openlog() called with facility 'local0' with option 'ndelay'" ); + ok( $r, "[$sock_type] openlog() should return true: '$r'" ); + + # syslog() with negative level, should fail + $r = eval { syslog(-1, "$test_string by connecting to a $sock_type socket") } || 0; + like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level -1" ); + ok( !$r, "[$sock_type] syslog() should return false: '$r'" ); + + # syslog() with invalid level, should fail + $r = eval { syslog("plonk", "$test_string by connecting to a $sock_type socket") } || 0; + like( $@, '/^syslog: invalid level\/facility: /', "[$sock_type] syslog() called with level plonk" ); + ok( !$r, "[$sock_type] syslog() should return false: '$r'" ); + + # syslog() with levels "info" and "notice" (as a strings), should fail + $r = eval { syslog('info,notice', "$test_string by connecting to a $sock_type socket") } || 0; + like( $@, '/^syslog: too many levels given: notice/', "[$sock_type] syslog() called with level 'info,notice'" ); + ok( !$r, "[$sock_type] syslog() should return false: '$r'" ); + + # syslog() with facilities "local0" and "local1" (as a strings), should fail + $r = eval { syslog('local0,local1', "$test_string by connecting to a $sock_type socket") } || 0; + like( $@, '/^syslog: too many facilities given: local1/', "[$sock_type] syslog() called with level 'local0,local1'" ); + ok( !$r, "[$sock_type] syslog() should return false: '$r'" ); + + # syslog() with level "info" (as a string), should pass + $r = eval { syslog('info', "$test_string by connecting to a $sock_type socket") } || 0; + is( $@, '', "[$sock_type] syslog() called with level 'info' (string)" ); + ok( $r, "[$sock_type] syslog() should return true: '$r'" ); + + # syslog() with level "info" (as a macro), should pass + { local $! = 1; + $r = eval { syslog(LOG_INFO(), "$test_string by connecting to a $sock_type socket, setting a fake errno: %m") } || 0; + } + is( $@, '', "[$sock_type] syslog() called with level 'info' (macro)" ); + ok( $r, "[$sock_type] syslog() should return true: '$r'" ); + + push @passed, $sock_type; + + SKIP: { + skip "skipping closelog() tests for 'console'", 2 if $sock_type eq 'console'; + # closelog() + $r = eval { closelog() } || 0; + is( $@, '', "[$sock_type] closelog()" ); + ok( $r, "[$sock_type] closelog() should return true: '$r'" ); + } + } +} + + + diff --git a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog.t b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog.t index 92af0c7f1cc..6802ace6651 100755 --- a/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog.t +++ b/gnu/usr.bin/perl/cpan/Sys-Syslog/t/syslog.t @@ -102,6 +102,7 @@ SKIP: { } } + # open syslog with a "local0" facility SKIP: { # openlog() @@ -122,15 +123,16 @@ SKIP: { } } - -BEGIN { $tests += 22 * 8 } # try to open a syslog using all the available connection methods +# handle inet and udp in a separate test file + my @passed = (); -for my $sock_type (qw(native eventlog unix pipe stream inet tcp udp)) { + +BEGIN { $tests += 22 * 6 } +for my $sock_type (qw(native eventlog unix pipe stream tcp )) { SKIP: { skip "the 'stream' mechanism because a previous mechanism with similar interface succeeded", 22 if $sock_type eq 'stream' and grep {/pipe|unix/} @passed; - # setlogsock() called with an arrayref $r = eval { setlogsock([$sock_type]) } || 0; skip "can't use '$sock_type' socket", 22 unless $r; @@ -199,7 +201,6 @@ for my $sock_type (qw(native eventlog unix pipe stream inet tcp udp)) { } } - BEGIN { $tests += 10 } SKIP: { skip "not testing setlogsock('stream') on Win32", 10 if $is_Win32; diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/aliases-func.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/aliases-func.t index 7ba1c3ef9db..890c7140b91 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/aliases-func.t +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/aliases-func.t @@ -2,20 +2,21 @@ # # Test setting color aliases via the function interface. # -# Copyright 2012 Russ Allbery <rra@cpan.org> +# Copyright 2012, 2020 Russ Allbery <rra@cpan.org> # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl +use 5.008; use strict; use warnings; -use Test::More tests => 23; +use Test::More tests => 30; # Load the module. BEGIN { delete $ENV{ANSI_COLORS_ALIASES}; delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; use_ok('Term::ANSIColor', qw(color colored colorvalid uncolor coloralias)); } @@ -30,21 +31,50 @@ like( # Basic alias functionality. is(coloralias('alert', 'red'), 'red', 'coloralias works and returns color'); -is(color('alert'), color('red'), 'alert now works as a color'); +is(color('alert'), color('red'), 'alert now works as a color'); is(colored('test', 'alert'), "\e[31mtest\e[0m", '..and colored works'); ok(colorvalid('alert'), '...and alert is now a valid color'); is(coloralias('alert'), 'red', 'coloralias with one arg returns value'); # The alias can be changed. is(coloralias('alert', 'green'), 'green', 'changing the alias works'); -is(coloralias('alert'), 'green', '...and changed the mapping'); -is(color('alert'), color('green'), '...and now returns its new value'); +is(coloralias('alert'), 'green', '...and changed the mapping'); +is(color('alert'), color('green'), '...and now returns its new value'); + +# Aliasing to an alias expands the underlying alias. +is(coloralias('warning', 'alert'), 'green', 'aliasing to an alias works'); +is(color('warning'), color('green'), '...and returns the right value'); + +# An alias can map to multiple attributes. +is( + coloralias('multiple', 'blue on_green', 'bold'), + 'blue on_green bold', + 'aliasing to multiple attributes works' +); +is(color('multiple'), color('blue on_green bold'), '...and works with color'); +is(colored('foo', 'multiple'), "\e[34;42;1mfoo\e[0m", '...and colored works'); +ok(colorvalid('multiple'), '...and colorvalid works'); + +# Those can include other aliases. +is( + coloralias('multiple', 'on_blue alert blink'), + 'on_blue green blink', + 'aliasing to multiple attributes including aliases' +); +is(color('multiple'), color('on_blue green blink'), '...and works with color'); + +# color supports aliases among multiple attributes. +is( + color('bold warning'), + color('bold', 'green'), + 'color supports aliases with multiple attributes' +); # uncolor ignores aliases. is_deeply([uncolor("\e[32m")], ['green'], 'uncolor ignores aliases'); # Asking for the value of an unknown alias returns undef. -is(coloralias('warning'), undef, 'coloralias on unknown alias returns undef'); +is(coloralias('foo'), undef, 'coloralias on unknown alias returns undef'); # Invalid alias names. $output = eval { coloralias('foo;bar', 'green') }; @@ -71,7 +101,7 @@ like( '...with the right error' ); -# Aliasing to a color that doesn't exist, or to another alias. +# Aliasing to a color that doesn't exist. $output = eval { coloralias('warning', 'chartreuse') }; ok(!$output, 'aliasing to an unknown color rejected'); like( @@ -79,10 +109,3 @@ like( qr{ \A Invalid [ ] attribute [ ] name [ ] "chartreuse" [ ] at [ ] }xms, '...with the right error' ); -$output = eval { coloralias('warning', 'alert') }; -ok(!$output, 'aliasing to an alias rejected'); -like( - $@, - qr{ \A Invalid [ ] attribute [ ] name [ ] "alert" [ ] at [ ] }xms, - '...with the right error' -); diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic.t index 735ce529ffa..ae2b8437000 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic.t +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/basic.t @@ -2,21 +2,22 @@ # # Basic test suite for the Term::ANSIColor Perl module. # -# Copyright 1997, 1998, 2000, 2001, 2002, 2005, 2006, 2009, 2010, 2012, 2014 +# Copyright 1997-1998, 2000-2002, 2005-2006, 2009-2010, 2012, 2014, 2020 # Russ Allbery <rra@cpan.org> # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl +use 5.008; use strict; use warnings; -use Test::More tests => 152; +use Test::More tests => 169; # Load the module. BEGIN { delete $ENV{ANSI_COLORS_ALIASES}; delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; use_ok('Term::ANSIColor', qw(:pushpop color colored uncolor colorstrip colorvalid)); } @@ -24,7 +25,7 @@ BEGIN { # Various basic tests. is(color('blue on_green', 'bold'), "\e[34;42;1m", 'Simple attributes'); is(colored('testing', 'blue', 'bold'), "\e[34;1mtesting\e[0m", 'colored'); -is((BLUE BOLD 'testing'), "\e[34m\e[1mtesting", 'Constants'); +is((BLUE BOLD 'testing'), "\e[34m\e[1mtesting", 'Constants'); is(join(q{}, BLUE, BOLD, 'testing'), "\e[34m\e[1mtesting", 'Constants with commas'); is((BLUE 'test', 'ing'), "\e[34mtesting", 'Constants with multiple strings'); @@ -90,6 +91,18 @@ is(color('bold'), "\e[1m", '...likewise when set to an empty string'); is((BOLD), "\e[1m", '...likewise for constants'); delete $ENV{ANSI_COLORS_DISABLED}; +# Similar tests for NO_COLOR, although NO_COLOR may be set to any value. +local $ENV{NO_COLOR} = 1; +is(color('blue'), q{}, 'color support for NO_COLOR'); +is(colored('testing', 'blue', 'on_red'), + 'testing', 'colored support for NO_COLOR'); +is((BLUE 'testing'), 'testing', 'Constant support for NO_COLOR'); +local $ENV{NO_COLOR} = q{}; +is(color('blue'), q{}, 'color support for NO_COLOR with empty string'); +is((RED 'testing'), + 'testing', 'Constant support for NO_COLOR with empty string'); +delete $ENV{NO_COLOR}; + # Make sure DARK is exported. This was omitted in versions prior to 1.07. is((DARK 'testing'), "\e[2mtesting", 'DARK'); @@ -130,7 +143,7 @@ is((POPCOLOR 'text'), "\e[31m\e[42mtext", '...and POPCOLOR works'); is((LOCALCOLOR GREEN ON_BLUE 'text'), "\e[32m\e[44mtext\e[31m\e[42m", 'LOCALCOLOR'); $Term::ANSIColor::AUTOLOCAL = 1; -is((BLUE 'text'), "\e[34mtext\e[31m\e[42m", 'AUTOLOCAL'); +is((BLUE 'text'), "\e[34mtext\e[31m\e[42m", 'AUTOLOCAL'); is((BLUE 'te', 'xt'), "\e[34mtext\e[31m\e[42m", 'AUTOLOCAL with commas'); $Term::ANSIColor::AUTOLOCAL = 0; is((POPCOLOR 'text'), "\e[0mtext", 'POPCOLOR with empty stack'); @@ -300,6 +313,22 @@ is(ON_BLUE, q{}, '...and for ON_BLUE'); is(RESET, q{}, '...and for RESET'); delete $ENV{ANSI_COLORS_DISABLED}; +# Do the same for disabled colors with NO_COLOR. +local $ENV{NO_COLOR} = 1; +is(BOLD, q{}, 'NO_COLOR works for BOLD'); +is(BLUE, q{}, '...and for BLUE'); +is(GREEN, q{}, '...and for GREEN'); +is(DARK, q{}, '...and for DARK'); +is(FAINT, q{}, '...and for FAINT'); +is(BRIGHT_RED, q{}, '...and for BRIGHT_RED'); +is(ON_BRIGHT_RED, q{}, '...and for ON_BRIGHT_RED'); +is(ITALIC, q{}, '...and for ITALIC'); +is(RED, q{}, '...and for RED'); +is(ON_GREEN, q{}, '...and for ON_GREEN'); +is(ON_BLUE, q{}, '...and for ON_BLUE'); +is(RESET, q{}, '...and for RESET'); +delete $ENV{NO_COLOR}; + # Do the same for AUTORESET. $Term::ANSIColor::AUTORESET = 1; is((BOLD 't'), "\e[1mt\e[0m", 'AUTORESET works for BOLD'); diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/eval.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/eval.t index b5332ee5045..677aae0377a 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/eval.t +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/eval.t @@ -6,15 +6,15 @@ # processing and lose its value or leak $@ values to the calling program. # This is a regression test to ensure that this problem doesn't return. # -# Copyright 2012, 2013, 2014 Russ Allbery <rra@cpan.org> +# Copyright 2012-2014, 2020 Russ Allbery <rra@cpan.org> # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl +use 5.008; use strict; use warnings; -use Test::More tests => 15; +use Test::More tests => 17; # We refer to $@ in the test descriptions. ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) @@ -23,6 +23,7 @@ use Test::More tests => 15; BEGIN { delete $ENV{ANSI_COLORS_ALIASES}; delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; use_ok('Term::ANSIColor', qw(:constants)); } @@ -43,6 +44,12 @@ is(BOLD, q{}, 'ANSI_COLORS_DISABLED works for BOLD'); is(BLINK, q{}, '...and for BLINK'); delete $ENV{ANSI_COLORS_DISABLED}; +# Now, NO_COLOR. +local $ENV{NO_COLOR} = 'foo'; +is(BOLD, q{}, 'NO_COLOR works for BOLD'); +is(BLINK, q{}, '...and for BLINK'); +delete $ENV{NO_COLOR}; + # Now, AUTORESET. $Term::ANSIColor::AUTORESET = 1; is((BOLD 't'), "\e[1mt\e[0m", 'AUTORESET works for BOLD'); diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/stringify.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/stringify.t index acb558dbdf3..ead86d4a862 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/stringify.t +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/stringify.t @@ -3,11 +3,11 @@ # Test suite for stringify interaction. # # Copyright 2011 Revilo Reegiles -# Copyright 2011, 2014 Russ Allbery <rra@cpan.org> +# Copyright 2011, 2014, 2020 Russ Allbery <rra@cpan.org> # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl +use 5.008; use strict; use warnings; @@ -17,7 +17,7 @@ use Test::More tests => 6; ## no critic (Modules::ProhibitMultiplePackages) package Test::Stringify; use overload '""' => 'stringify'; -sub new { return bless({}, 'Test::Stringify') } +sub new { return bless({}, 'Test::Stringify') } sub stringify { return "Foo Bar\n" } # Back to the main package. @@ -27,6 +27,7 @@ package main; BEGIN { delete $ENV{ANSI_COLORS_ALIASES}; delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; use_ok('Term::ANSIColor', qw(colored)); } diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/true-color.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/true-color.t new file mode 100644 index 00000000000..a5fe55ab9d1 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/module/true-color.t @@ -0,0 +1,112 @@ +#!/usr/bin/perl +# +# Tests for true color support (24-bit color). +# +# Copyright 2020 Russ Allbery <rra@cpan.org> +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl + +use 5.008; +use strict; +use warnings; + +use Test::More tests => 82; + +# Load the module. +BEGIN { + delete $ENV{ANSI_COLORS_ALIASES}; + delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; + use_ok('Term::ANSIColor', qw(color uncolor colorvalid)); +} + +# Test basic true color codes. +is(color('r0g0b0'), "\e[38;2;0;0;0m", 'foreground 0 0 0'); +is(color('r000g000b000'), "\e[38;2;0;0;0m", 'foreground 000 000 000'); +is(color('r255g0b0'), "\e[38;2;255;0;0m", 'foreground 255 0 0'); +is(color('r0g255b0'), "\e[38;2;0;255;0m", 'foreground 255 0 0'); +is(color('r0g0b255'), "\e[38;2;0;0;255m", 'foreground 255 0 0'); +is(color('r255g255b255'), "\e[38;2;255;255;255m", 'foreground 255 255 255'); +is(color('r1g02b003'), "\e[38;2;1;2;3m", 'foreground 1 02 003'); +is(color('on_r0g0b0'), "\e[48;2;0;0;0m", 'background 0 0 0'); +is(color('on_r000g000b000'), "\e[48;2;0;0;0m", 'background 000 000 000'); +is(color('on_r255g0b0'), "\e[48;2;255;0;0m", 'background 255 0 0'); +is(color('on_r0g255b0'), "\e[48;2;0;255;0m", 'background 255 0 0'); +is(color('on_r0g0b255'), "\e[48;2;0;0;255m", 'background 255 0 0'); +is(color('on_r255g255b255'), "\e[48;2;255;255;255m", 'background 255 255 255'); +is(color('on_r1g02b003'), "\e[48;2;1;2;3m", 'background 1 02 003'); + +# Check that various true color codes are valid. +my @valid = qw( + r0g0b0 r255g255b255 r1g02b003 on_r0g0b0 on_r255g255b255 on_r1g02b003 +); +for my $color (@valid) { + ok(colorvalid($color), "Color $color is valid"); +} + +# Errors at boundary cases. +my @invalid = qw( + r0g0 r256g0b0 r0g256b0 r0g0b256 r1000g2b3 rgb r1g2b r1gb2 r1b2g3 +); +for my $color (@invalid) { + my $output = eval { color($color) }; + is($output, undef, 'color on an invalid attribute fails'); + like( + $@, + qr{ \A Invalid [ ] attribute [ ] name [ ] \Q$color\E [ ] at [ ] }xms, + '...with the right error' + ); + ok(!colorvalid($color), '...and colorvalid says it is invalid'); +} + +# Check uncolor with true color codes. +is_deeply([uncolor('38;2;0;0;0')], ['r0g0b0'], 'uncolor of r0g0b0'); +is_deeply([uncolor('48;02;0;0;0')], ['on_r0g0b0'], 'uncolor of on_r0g0b0'); +is_deeply([uncolor("\e[038;2;255;255;255")], + ['r255g255b255'], 'uncolor of r255g255b255'); +is_deeply([uncolor("\e[48;002;255;255;255")], + ['on_r255g255b255'], 'uncolor of on_r255g255b255'); +is_deeply( + [uncolor("\e[1;38;2;1;02;003;5;48;2;4;5;6m")], + [qw(bold r1g2b3 blink on_r4g5b6)], + 'uncolor of a complex escape', +); +is_deeply( + [uncolor("\e[1;38;2;1;02;003;5;48;5;230m")], + [qw(bold r1g2b3 blink on_rgb554)], + 'uncolor mixing true-color and 256-color', +); + +# An invalid true-color code should report an error on the part that makes it +# invalid. Check truncated codes (should report on the 38 or 48), codes with +# an invalid second part (likewise), and codes with an invalid third part +# (should report the complete code). +# +# This is a hash of test escape sequences to the invalid sequence that should +# be reported. +my %uncolor_tests = ( + "\e[38;1m" => 38, + "\e[38;2m" => 38, + "\e[38;2;255;0m" => 38, + "\e[38;2;256;0;0m" => '38;2;256;0;0', + "\e[38;2;0;256;0m" => '38;2;0;256;0', + "\e[38;2;0;0;256m" => '38;2;0;0;256', + "\e[38;2;777;777;777m" => '38;2;777;777;777', + "\e[48;1m" => 48, + "\e[48;2m" => 48, + "\e[48;2;255;0m" => 48, + "\e[48;2;256;0;0m" => '48;2;256;0;0', + "\e[48;2;0;256;0m" => '48;2;0;256;0', + "\e[48;2;0;0;256m" => '48;2;0;0;256', + "\e[48;2;777;777;777m" => '48;2;777;777;777', +); +while (my ($escape, $invalid) = each(%uncolor_tests)) { + my $output = eval { uncolor($escape) }; + is($output, undef, "uncolor on unknown color code \Q$escape\E fails"); + like( + $@, + qr{ \A No [ ] name [ ] for [ ] escape [ ] sequence [ ] \Q$invalid\E + [ ] at [ ] }xms, + '...with the right error' + ); +} diff --git a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/taint/basic.t b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/taint/basic.t index 53a6bb667cf..54611c82e02 100644 --- a/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/taint/basic.t +++ b/gnu/usr.bin/perl/cpan/Term-ANSIColor/t/taint/basic.t @@ -7,11 +7,11 @@ # an environment variable). Term::ANSIColor does the work to untaint it; be # sure that the taint flag is properly cleared. # -# Copyright 2012 Russ Allbery <rra@cpan.org> +# Copyright 2012, 2020 Russ Allbery <rra@cpan.org> # -# This program is free software; you may redistribute it and/or modify it -# under the same terms as Perl itself. +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl +use 5.008; use strict; use warnings; @@ -21,13 +21,14 @@ use Test::More tests => 4; BEGIN { delete $ENV{ANSI_COLORS_ALIASES}; delete $ENV{ANSI_COLORS_DISABLED}; + delete $ENV{NO_COLOR}; use_ok('Term::ANSIColor', qw(:pushpop)); } # Generate a tainted constant name. PATH is always tainted, and tainting is # sticky, so we can prepend the name to whatever PATH holds and then chop it # off again. -my $constant = substr 'BOLD' . $ENV{PATH}, 0, length 'BOLD'; +my $constant = substr('BOLD' . $ENV{PATH}, 0, length('BOLD')); # Using that as a constant should now work without any tainting problems. ## no critic (TestingAndDebugging::ProhibitNoStrict) 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 3c29ffdaf21..ab405cab98a 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.302162'; +our $VERSION = '1.302175'; BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } @@ -33,7 +33,8 @@ sub debug_tap { my ($self, $f, $num) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::debug_tap($f, $num); - $self->redirect(\@out) if @out && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; + $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} + && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } @@ -41,7 +42,8 @@ sub info_tap { my ($self, $f) = @_; return if $self->{+NO_DIAG}; my @out = $self->SUPER::info_tap($f); - $self->redirect(\@out) if @out && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; + $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} + && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; return @out; } 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 8ac230f71c9..b69ca25266e 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.302162'; +our $VERSION = '1.302175'; 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 98c5391da9d..d9156310707 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.302162'; +our $VERSION = '1.302175'; 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 8193b073661..6c517415bd9 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 @@ -9,14 +9,44 @@ BEGIN { $ENV{TEST2_ACTIVE} = 1; } -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; my $INST; my $ENDING = 0; -sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) } +sub test2_unset_is_end { $ENDING = 0 } sub test2_get_is_end { $ENDING } +sub test2_set_is_end { + my $before = $ENDING; + ($ENDING) = @_ ? @_ : (1); + + # Only send the event in a transition from false to true + return if $before; + return unless $ENDING; + + return unless $INST; + my $stack = $INST->stack or return; + my $root = $stack->root or return; + + return unless $root->count; + + return unless $$ == $INST->pid; + return unless get_tid() == $INST->tid; + + my $trace = Test2::EventFacet::Trace->new( + frame => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'], + ); + my $ctx = Test2::API::Context->new( + trace => $trace, + hub => $root, + ); + + $ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' }); + + 1; +} + use Test2::API::Instance(\$INST); # Set the exit status @@ -85,8 +115,10 @@ our @EXPORT_OK = qw{ test2_start_preload test2_stop_preload test2_in_preload + test2_is_testing_done test2_set_is_end + test2_unset_is_end test2_get_is_end test2_pid @@ -176,6 +208,27 @@ sub test2_ipc_wait_enable { $INST->set_no_wait(0) } sub test2_ipc_wait_disable { $INST->set_no_wait(1) } sub test2_ipc_wait_enabled { !$INST->no_wait } +sub test2_is_testing_done { + # No instance? VERY DONE! + return 1 unless $INST; + + # No stack? tests must be done, it is created pretty early + my $stack = $INST->stack or return 1; + + # Nothing on the stack, no root hub yet, likely have not started testing + return 0 unless @$stack; + + # Stack has a slot for the root hub (see above) but it is undefined, likely + # garbage collected, test is done + my $root_hub = $stack->[0] or return 1; + + # If the root hub is ended than testing is done. + return 1 if $root_hub->ended; + + # Looks like we are still testing! + return 0; +} + sub test2_no_wait { $INST->set_no_wait(@_) if @_; $INST->no_wait; @@ -322,6 +375,23 @@ sub context { my $stack = $params{stack} || $STACK; my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top); + + # Catch an edge case where we try to get context after the root hub has + # been garbage collected resulting in a stack that has a single undef + # hub + if (!$hub && !exists($params{hub}) && @$stack) { + my $msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)"); + + # The error message is usually masked by the global destruction, so we have to print to STDER + print STDERR $msg; + + # Make sure this is a failure, we are probably already in END, so set $? to change the exit code + $? = 1; + + # Now we actually die to interrupt the program flow and avoid undefined his warnings + die $msg; + } + my $hid = $hub->{hid}; my $current = $CONTEXTS->{$hid}; @@ -814,6 +884,7 @@ C<intercept { ... }> which only lets you see events as the main hub sees them. test2_ipc test2_formatter_set test2_formatter + test2_is_testing_done }; my $init = test2_init_done(); @@ -1257,6 +1328,26 @@ Check if Test2 believes it is the END phase. This will return the global L<Test2::API::Stack> instance. If this has not yet been initialized it will be initialized now. +=item $bool = test2_is_testing_done() + +This will return true if testing is complete and no other events should be +sent. This is useful in things like warning handlers where you might want to +turn warnings into events, but need them to start acting like normal warnings +when testing is done. + + $SIG{__WARN__} = sub { + my ($warning) = @_; + + if (test2_is_testing_done()) { + warn @_; + } + else { + my $ctx = context(); + ... + $ctx->release + } + } + =item test2_ipc_disable Disable IPC. 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 ffcf1be582f..2dd2852d0e0 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.302162'; +our $VERSION = '1.302175'; use Test2::Util qw/pkg_to_file/; @@ -73,7 +73,9 @@ sub report { next unless $INC{$file} || ($require && eval { require $file; 1 }); my $want = $suggest{$mod}; next if eval { $mod->VERSION($want); 1 }; - push @warn => " * Module '$mod' is outdated, we recommed updating above $want."; + my $error = $@; + chomp $error; + push @warn => " * Module '$mod' is outdated, we recommed updating above $want. error was: '$error'; INC is $INC{$file}"; } for my $mod (keys %required) { 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 9cb1cfca723..177d9c40724 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.302162'; +our $VERSION = '1.302175'; use Carp qw/confess croak/; @@ -71,6 +71,8 @@ sub DESTROY { # show the warning about using eq. no warnings 'uninitialized'; if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { + require Carp; + my $mess = Carp::longmess("Context destroyed"); my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; warn <<" EOT"; A context appears to have been destroyed without first calling release(). @@ -87,6 +89,10 @@ release(): Line: $frame->[2] Tool: $frame->[3] +Here is a trace to the code that caused the context to be destroyed, this could +be an exit(), a goto, or simply the end of a scope: +$mess + Cleaning up the CONTEXT stack... EOT } 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 1cf224cf063..fbbb675cc42 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.302162'; +our $VERSION = '1.302175'; 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/Stack.pm b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/API/Stack.pm index ffa4ed57f01..d6b6e85c86b 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.302162'; +our $VERSION = '1.302175'; use Test2::Hub(); @@ -63,6 +63,12 @@ sub all { return @$self; } +sub root { + my $self = shift; + return unless @$self; + return $self->[0]; +} + sub clear { my $self = shift; @$self = (); 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 598456c1dc3..e1c567a7396 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.302162'; +our $VERSION = '1.302175'; use Scalar::Util qw/blessed reftype/; use Carp qw/croak/; @@ -526,11 +526,11 @@ perhaps to say that an event of an unknown type was seen. Facets are produced by the C<facet_data()> subroutine, which you should nearly-always override. C<facet_data()> is expected to return a hashref where each key is the facet type, and the value is either a hashref with the data for -that facet, or an array of hashref's. Some facets must be defined as single +that facet, or an array of hashrefs. Some facets must be defined as single hashrefs, some must be defined as an array of hashrefs, No facets allow both. C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and -nested facet hashref's B<MUST> be bare, though items contained within each +nested facet hashrefs B<MUST> be bare, though items contained within each facet may be blessed. The data returned by this method B<should> also be copies of the internal data in order to prevent accidental state modification. 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 4fa83c4899b..076ac9761dd 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.302162'; +our $VERSION = '1.302175'; 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 86617f8afc7..9fa732ff4ff 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.302162'; +our $VERSION = '1.302175'; 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 12071637af5..3fb7364394a 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.302162'; +our $VERSION = '1.302175'; 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 66bbdb4fb40..df83ac8714b 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.302162'; +our $VERSION = '1.302175'; 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 2577cd93381..f09a035ede9 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.302162'; +our $VERSION = '1.302175'; 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 02619d9a171..ef08124a166 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.302162'; +our $VERSION = '1.302175'; 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 3dd09998445..4a310f3cd13 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.302162'; +our $VERSION = '1.302175'; 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 7a603b40ca5..088c8b6d4dd 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.302162'; +our $VERSION = '1.302175'; 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 46726234304..bfc3a73b48b 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.302162'; +our $VERSION = '1.302175'; 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 00b63970f7a..ad8f927552b 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.302162'; +our $VERSION = '1.302175'; 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 07db32932aa..a9923243551 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.302162'; +our $VERSION = '1.302175'; 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 92e3f6dfa14..aed0c0061f4 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.302162'; +our $VERSION = '1.302175'; BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid}; 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 cf7d773e1f4..b3cb1d8558e 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.302162'; +our $VERSION = '1.302175'; 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 020cf2348e6..326a818f1d8 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.302162'; +our $VERSION = '1.302175'; use Scalar::Util qw/reftype/; use Carp qw/croak/; @@ -60,8 +60,8 @@ sub facet_data { for my $k (keys %$f) { next if substr($k, 0, 1) eq '_'; - my $data = $f->{$k}; - my $is_list = reftype($data) eq 'ARRAY'; + my $data = $f->{$k} or next; # Key is there, but no facet + my $is_list = 'ARRAY' eq (reftype($data) || ''); $out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data}; } 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 4b790a6ff92..dbd1448584f 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.302162'; +our $VERSION = '1.302175'; 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 d9fb03f4518..13c217f33fd 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.302162'; +our $VERSION = '1.302175'; 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 fc36d2766a8..f12ebf835a4 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.302162'; +our $VERSION = '1.302175'; 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 ac72cf3890c..45ed92703cd 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.302162'; +our $VERSION = '1.302175'; 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 a11aef15691..02f89aff729 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.302162'; +our $VERSION = '1.302175'; 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 6ea0eaef404..8a04a4a3a55 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,10 +2,10 @@ package Test2::EventFacet::Control; use strict; use warnings; -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } -use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding }; +use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; 1; @@ -65,6 +65,13 @@ True if the C<callback($hub)> method on the event should be called. This can be used to change the encoding from this event onward. +=item $phase = $control->{phase} + +=item $phase = $control->phase() + +Used to signal that a phase change has occurred. Currently only the perl END +phase is signaled. + =back =head1 SOURCE 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 4a21ef7e286..87baf113fbd 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.302162'; +our $VERSION = '1.302175'; 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 40b9d658026..370142577c3 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.302162'; +our $VERSION = '1.302175'; 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 c382049480d..badd2d04573 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.302162'; +our $VERSION = '1.302175'; 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 64bd95539a5..0c127b5a242 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,6 +2,8 @@ package Test2::EventFacet::Info::Table; use strict; use warnings; +our $VERSION = '1.302175'; + use Carp qw/confess/; use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string}; 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 dc369ff2b1c..2b75764eb15 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.302162'; +our $VERSION = '1.302175'; 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 d36fd92b27c..ac267379cf1 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.302162'; +our $VERSION = '1.302175'; 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 2f14f7d69e0..355588b5bc1 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.302162'; +our $VERSION = '1.302175'; 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 07c454365a2..13fe4cbc91f 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.302162'; +our $VERSION = '1.302175'; 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 34a3fce7ad0..455b0ee1166 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.302162'; +our $VERSION = '1.302175'; 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 c4515d8c41c..17c28bf2769 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.302162'; +our $VERSION = '1.302175'; 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 25961bf7370..120c82d77b9 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.302162'; +our $VERSION = '1.302175'; use Test2::Util qw/clone_io/; @@ -16,16 +16,17 @@ sub OUT_ERR() { 1 } BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) } -# Not constants because this is a method, and can be overriden -BEGIN { - local $SIG{__DIE__} = 'DEFAULT'; - local $@; - if (($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'}) || eval { require Term::Table; require Term::Table::Util; 1 }) { - *supports_tables = sub { 1 }; - } - else { - *supports_tables = sub { 0 }; +my $supports_tables; +sub supports_tables { + if (!defined $supports_tables) { + local $SIG{__DIE__} = 'DEFAULT'; + local $@; + $supports_tables + = ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'}) + || eval { require Term::Table; require Term::Table::Util; 1 } + || 0; } + return $supports_tables; } sub _autoflush { @@ -270,7 +271,10 @@ sub assert_tap { } my %seen; - my @order = grep { !$seen{$_}++ } sort keys %directives; + + # Sort so that TODO comes before skip even on systems where lc sorts + # before uc, as other code depends on that ordering. + my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives; $directives = ' # ' . join ' & ' => @order; 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 a5706e56771..e041f6db73a 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.302162'; +our $VERSION = '1.302175'; use Carp qw/carp croak confess/; @@ -813,7 +813,7 @@ Get the IPC object used by the hub. This can be used to disable auto-ending behavior for a hub. The auto-ending behavior is triggered by an end block and is used to cull IPC events, and -output the final plan if the plan was 'no_plan'. +output the final plan if the plan was 'NO PLAN'. =item $bool = $hub->active @@ -861,7 +861,7 @@ pass/fail status. =item $plan = $hub->plan Get or set the plan. The plan must be an integer larger than 0, the string -'no_plan', or the string 'skip_all'. +'NO PLAN', or the string 'SKIP'. =item $bool = $hub->check_plan 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 cd459ada066..317dfa8c2ee 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.302162'; +our $VERSION = '1.302175'; 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 6f44b08bcdd..906e7b0a037 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.302162'; +our $VERSION = '1.302175'; 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 52d5b4e0fa4..acc63696461 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.302162'; +our $VERSION = '1.302175'; 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 b2a503bfa74..e9d29cca25f 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.302162'; +our $VERSION = '1.302175'; 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 dbcb7004b3f..db6642a564a 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.302162'; +our $VERSION = '1.302175'; 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 f6d7ff1b2c0..09fdd5c0cf6 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.302162'; +our $VERSION = '1.302175'; BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) } @@ -117,12 +117,36 @@ sub drop_hub { } opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!"); + + my %bad; for my $file (readdir($dh)) { next if $file =~ m{\.complete$}; next unless $file =~ m{^$hid}; - $self->abort_trace("Not all files from hub '$hid' have been collected!"); + + eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file"; } closedir($dh); + + return unless keys %bad; + + my $data; + my $ok = eval { + require JSON::PP; + local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } }; + my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed; + $data = $json->encode(\%bad); + 1; + }; + $ok ||= eval { + require Data::Dumper; + local $Data::Dumper::Sortkeys = 1; + $data = Data::Dumper::Dumper(\%bad); + 1; + }; + + $data = "Could not dump data... sorry." unless defined $data; + + $self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n"); } sub send { 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 4da76a79ba4..5139e4607c7 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.302162'; +our $VERSION = '1.302175'; BEGIN { require Exporter; our @ISA = qw(Exporter) } our @EXPORT = qw{ diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Transition.pod b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Transition.pod index de6442ce610..07811f0d629 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Transition.pod +++ b/gnu/usr.bin/perl/cpan/Test-Simple/lib/Test2/Transition.pod @@ -76,7 +76,7 @@ as needed. =head3 The Problem An early change, in fact the change that made Test2 an idea, was a change to -the indentation of the subtest note. IT was decided it would be more readable +the indentation of the subtest note. It was decided it would be more readable to outdent the subtest note instead of having it inline with the subtest: # subtest foo @@ -104,7 +104,7 @@ This breaks tests that do string comparison of TAP output. ); Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be -expected. If it is not set than the old Test::Builder is in use, indentation +expected. If it is not set, then the old Test::Builder is in use, indentation should be expected. =head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED @@ -129,13 +129,6 @@ failure. This can be easily updated, but nobody has done so yet. Known broken in versions: 1.0.9 and older -=item Test::Kit - -This actually works fine, but will not install because L<Test::Aggregate> is in -the dependency chain. - -See the L<Test::Aggregate> info below for additional information. - =item Device::Chip Tests break due to subtest indentation. @@ -201,6 +194,13 @@ the bugfix. Fixed in version: 0.04 +=item Test::Kit + +Old versions work fine, but would not install because L<Test::Aggregate> was in +the dependency chain. An upgrade should not be needed. + +Fixed in version: 2.15 + =item autouse A test broke because it depended on Scalar::Util not being loaded. Test2 loads @@ -274,8 +274,8 @@ Fixed in version: 0.007 This distribution directly accesses the hash keys in the L<Test::Builder> singleton. It also approaches the problem from the wrong angle, please consider -using L<Test2::Harness> or L<App::ForkProve> which both solve the same problem -at the harness level. +using L<Test2::Aggregate> for similar functionality and L<Test2::Harness> +which allows module preloading at the harness level. Still broken as of version: 0.373 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 c4a865e9b15..0ba499557a0 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.302162'; +our $VERSION = '1.302175'; 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 dbd819feeaf..90345d0ecd4 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.302162'; +our $VERSION = '1.302175'; 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 812282d157a..4bcee18112e 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.302162'; +our $VERSION = '1.302175'; 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 c34db5fc565..a6a04f9bee1 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.302162'; +our $VERSION = '1.302175'; ################################################################# # # @@ -16,7 +16,7 @@ our $VERSION = '1.302162'; { no warnings 'once'; - $Test2::Util::HashBase::HB_VERSION = '0.006'; + $Test2::Util::HashBase::HB_VERSION = '0.009'; *Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS; *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST; *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION; @@ -44,9 +44,12 @@ BEGIN { } } -my %STRIP = ( - '^' => 1, - '-' => 1, +my %SPEC = ( + '^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1}, + '-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1}, + '>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1}, + '<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, + '+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1}, ); sub import { @@ -68,14 +71,22 @@ sub import { map { my $p = substr($_, 0, 1); my $x = $_; - substr($x, 0, 1) = '' if $STRIP{$p}; + + my $spec = $SPEC{$p} || {reader => 1, writer => 1}; + + substr($x, 0, 1) = '' if $spec->{strip}; push @$attr_list => $x; my ($sub, $attr) = (uc $x, $x); - $sub => ($attr_subs->{$sub} = sub() { $attr }), - $attr => sub { $_[0]->{$attr} }, - $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") }) - : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] }) - : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }), + + $attr_subs->{$sub} = sub() { $attr }; + my %out = ($sub => $attr_subs->{$sub}); + + $out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader}; + $out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer}; + $out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only}; + $out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer}; + + %out; } @_ ), ); @@ -167,7 +178,7 @@ A class: use warnings; # Generate 3 accessors - use Test2::Util::HashBase qw/foo -bar ^baz/; + use Test2::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; # Chance to initialize defaults sub init { @@ -175,10 +186,13 @@ A class: $self->{+FOO} ||= "foo"; $self->{+BAR} ||= "bar"; $self->{+BAZ} ||= "baz"; + $self->{+BAT} ||= "bat"; + $self->{+BAN} ||= "ban"; + $self->{+BOO} ||= "boo"; } sub print { - print join ", " => map { $self->{$_} } FOO, BAR, BAZ; + print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO; } Subclass it @@ -189,14 +203,14 @@ Subclass it # Note, you should subclass before loading HashBase. use base 'My::Class'; - use Test2::Util::HashBase qw/bat/; + use Test2::Util::HashBase qw/bub/; sub init { my $self = shift; # We get the constants from the base class for free. $self->{+FOO} ||= 'SubFoo'; - $self->{+BAT} ||= 'bat'; + $self->{+BUB} ||= 'bub'; $self->SUPER::init(); } @@ -213,10 +227,13 @@ use it: my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'}); my $three = My::Class->new(['MyFoo', 'MyBar']); - # Accessors! + # Readers! my $foo = $one->foo; # 'MyFoo' my $bar = $one->bar; # 'MyBar' my $baz = $one->baz; # Defaulted to: 'baz' + my $bat = $one->bat; # Defaulted to: 'bat' + # '>ban' means setter only, no reader + # '+boo' means no setter or reader, just the BOO constant # Setters! $one->set_foo('A Foo'); @@ -228,6 +245,9 @@ use it: # deprecated. $one->set_baz('A Baz'); + # '<bat' means no setter defined at all + # '+boo' means no setter or reader, just the BOO constant + $one->{+FOO} = 'xxx'; =head1 DESCRIPTION @@ -371,6 +391,24 @@ deprecated. =back +=head2 NO SETTER + + use Test2::Util::HashBase qw/<foo/; + +Only gives you a reader, no C<set_foo> method is defined at all. + +=head2 NO READER + + use Test2::Util::HashBase qw/>foo/; + +Only gives you a write (C<set_foo>), no C<foo> method is defined at all. + +=head2 CONSTANT ONLY + + use Test2::Util::HashBase qw/+foo/; + +This does not create any methods for you, it just adds the C<FOO> constant. + =head1 SUBCLASSING You can subclass an existing HashBase class. @@ -425,7 +463,7 @@ F<http://github.com/Test-More/HashBase/>. =head1 COPYRIGHT -Copyright 2019 Chad Granum E<lt>exodist@cpan.orgE<gt>. +Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 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 28124f3406c..33b3648789b 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 @@ -2,7 +2,7 @@ package Test2::Util::Trace; require Test2::EventFacet::Trace; @ISA = ('Test2::EventFacet::Trace'); -our $VERSION = '1.302162'; +our $VERSION = '1.302175'; 1; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/HashBase.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/HashBase.t index 397c69759ff..e040de6e365 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/HashBase.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/HashBase.t @@ -135,17 +135,28 @@ BEGIN { package main::HBase2; - use Test2::Util::HashBase qw/foo -bar ^baz/; + use Test2::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/; main::is(FOO, 'foo', "FOO CONSTANT"); main::is(BAR, 'bar', "BAR CONSTANT"); main::is(BAZ, 'baz', "BAZ CONSTANT"); + main::is(BAT, 'bat', "BAT CONSTANT"); + main::is(BAN, 'ban', "BAN CONSTANT"); + main::is(BOO, 'boo', "BOO CONSTANT"); } -my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz'); +my $ro = main::HBase2->new(foo => 'foo', bar => 'bar', baz => 'baz', bat => 'bat', ban => 'ban'); is($ro->foo, 'foo', "got foo"); is($ro->bar, 'bar', "got bar"); is($ro->baz, 'baz', "got baz"); +is($ro->bat, 'bat', "got bat"); +ok(!$ro->can('set_bat'), "No setter for bat"); +ok(!$ro->can('ban'), "No reader for ban"); +ok(!$ro->can('boo'), "No reader for boo"); +ok(!$ro->can('set_boo'), "No setter for boo"); +is($ro->{ban}, 'ban', "ban attribute is set"); +$ro->set_ban('xxx'); +is($ro->{ban}, 'xxx', "ban attribute can be set"); is($ro->set_foo('xxx'), 'xxx', "Can set foo"); is($ro->foo, 'xxx', "got foo"); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t index 87e1a541408..6b255254b32 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Legacy/Tester/tbt_09do.t @@ -9,7 +9,7 @@ use File::Basename qw(dirname); use File::Spec qw(); my $file = File::Spec->join(dirname(__FILE__), 'tbt_09do_script.pl'); -$file = File::Spec->catfile(File::Spec->curdir(), $file) +$file = File::Spec->rel2abs(File::Spec->catfile(File::Spec->curdir(), $file)) unless File::Spec->file_name_is_absolute($file); my $done = do $file; ok(defined($done), 'do succeeded') or do { diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API.t index a804cac4753..c96c423a435 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API.t @@ -1,6 +1,8 @@ use strict; use warnings; +BEGIN { no warnings 'once'; $main::cleanup1 = bless {}, 'My::Cleanup' } + use Test2::API qw/context/; my ($LOADED, $INIT); @@ -26,6 +28,7 @@ ok(Test2::API->can($_), "$_ method is present") for qw{ test2_tid test2_stack test2_no_wait + test2_is_testing_done test2_add_callback_context_init test2_add_callback_context_release @@ -285,5 +288,23 @@ is((grep { $_ == $sub } Test2::API::test2_list_context_release_callbacks()), 2, is((grep { $_ == $sub } Test2::API::test2_list_exit_callbacks()), 2, "got the two instances of the hook"); is((grep { $_ == $sub } Test2::API::test2_list_post_load_callbacks()), 2, "got the two instances of the hook"); +ok(!Test2::API::test2_is_testing_done(), "Testing is not done"); + done_testing; +die "Testing should be done, but it is not!" unless Test2::API::test2_is_testing_done(); + +{ + package My::Cleanup; + + sub DESTROY { + return if Test2::API::test2_is_testing_done(); + print "not ok - Testing should be done, but it is not!\n"; + warn "Testing should be done, but it is not!"; + eval "END { $? = 255 }; 1" or die $@; + exit 255; + } +} + +# This should destroy the thing +END { no warnings 'once'; $main::cleanup2 = bless {}, 'My::Cleanup' } diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Breakage.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Breakage.t index e2932469f38..26d01b84601 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Breakage.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Breakage.t @@ -33,12 +33,12 @@ for my $meth (qw/upgrade_suggested upgrade_required known_broken/) { { local %INC = ( %INC, - 'T2Test/UG1.pm' => 1, - 'T2Test/UG2.pm' => 1, - 'T2Test/UR1.pm' => 1, - 'T2Test/UR2.pm' => 1, - 'T2Test/KB1.pm' => 1, - 'T2Test/KB2.pm' => 1, + 'T2Test/UG1.pm' => 'T2Test/UG1.pm', + 'T2Test/UG2.pm' => 'T2Test/UG2.pm', + 'T2Test/UR1.pm' => 'T2Test/UR1.pm', + 'T2Test/UR2.pm' => 'T2Test/UR2.pm', + 'T2Test/KB1.pm' => 'T2Test/KB1.pm', + 'T2Test/KB2.pm' => 'T2Test/KB2.pm', ); local $T2Test::UG1::VERSION = '0.9'; local $T2Test::UG2::VERSION = '0.9'; @@ -49,14 +49,16 @@ for my $meth (qw/upgrade_suggested upgrade_required known_broken/) { my @report = $CLASS->report; + $_ =~ s{\S+/Breakage\.pm}{Breakage.pm}g for @report; + is_deeply( [sort @report], [ sort - " * Module 'T2Test::UG1' is outdated, we recommed updating above 1.0.", " * Module 'T2Test::UR1' is outdated and known to be broken, please update to 1.0 or higher.", " * Module 'T2Test::KB1' is known to be broken in version 1.0 and below, newer versions have not been tested. You have: 0.9", " * Module 'T2Test::KB2' is known to be broken in version 0.5 and below, newer versions have not been tested. You have: 0.9", + " * Module 'T2Test::UG1' is outdated, we recommed updating above 1.0. error was: 'T2Test::UG1 version 1.0 required--this is only version 0.9 at Breakage.pm line 75.'; INC is T2Test/UG1.pm", ], "Got expected report items" ); diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Context.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Context.t index 207f3d0a070..b17dd20695f 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Context.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Context.t @@ -477,4 +477,30 @@ sub { }->(); +sub ctx_destroy_test { + my (undef, undef, $line1) = caller(); + my (@warn, $line2); + local $SIG{__WARN__} = sub { push @warn => $_[0] }; + + { my $ctx = context(); $ctx = undef } $line2 = __LINE__; + + use Data::Dumper; +# print Dumper(@warn); + + like($warn[0], qr/context appears to have been destroyed without first calling release/, "Is normal context warning"); + like($warn[0], qr{\QContext destroyed at ${ \__FILE__ } line $line2\E}, "Reported context destruction trace"); + + my $created = <<" EOT"; +Here are the context creation details, just in case a tool forgot to call +release(): + File: ${ \__FILE__ } + Line: $line1 + Tool: main::ctx_destroy_test + EOT + + like($warn[0], qr{\Q$created\E}, "Reported context creation details"); +}; + +ctx_destroy_test(); + done_testing; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t index ee54a151c5f..43ec086d117 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/Formatter/TAP.t @@ -1,6 +1,7 @@ use strict; use warnings; # HARNESS-NO-PRELOAD +# HARNESS-NO-STREAM my $CLASS; my %BEFORE_LOAD; @@ -1019,7 +1020,7 @@ my $can_table = $CLASS->supports_tables; my $author_testing = $ENV{AUTHOR_TESTING}; if ($author_testing && !$can_table) { - die "This test requires Term::Table to be installed, and must be run in AUTHOR_TESTING mode"; + die "You are running this test under AUTHOR_TESTING, doing so requires Term::Table to be installed, but it is not currently installed, this is a fatal error. Please install Term::Table before attempting to run this test under AUTHOR_TESTING."; } elsif ($can_table) { tests tables => sub { diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/812-todo.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/812-todo.t index dd4e0b46466..f3acb5ccc45 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/812-todo.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/812-todo.t @@ -5,7 +5,6 @@ use Test2::API qw/intercept/; use Test::More; my @values = ( - "", # false but defined -> inconsistent 0, # false but defined -> inconsistent 0.0, # false but defined -> inconsistent "0.0", # true -> TODO @@ -18,4 +17,12 @@ for my $value (@values) { fail "Testing: $x"; } +my $e = intercept { + local $TODO = ""; + fail "Testing: '\"\"'"; +}; + +ok(!$e->[0]->effective_pass, "Test was not TODO when set to \"\""); +like($e->[1]->message, qr/Failed test '/, "Did not add TODO to the diagnostics"); + done_testing; diff --git a/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/errors_facet.t b/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/errors_facet.t index c4e30f995cc..6427ba23067 100644 --- a/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/errors_facet.t +++ b/gnu/usr.bin/perl/cpan/Test-Simple/t/regression/errors_facet.t @@ -14,7 +14,7 @@ use Test2::API qw/intercept context/; my $out = $self->common_facet_data; - $out->{errors} = [{tag => 'OOPS', fail => !$ENV{FAILURE_DO_PASS}, details => "An error occured"}]; + $out->{errors} = [{tag => 'OOPS', fail => !$ENV{FAILURE_DO_PASS}, details => "An error occurred"}]; return $out; } diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/t/06large.t b/gnu/usr.bin/perl/cpan/Time-Piece/t/06large.t new file mode 100644 index 00000000000..aa0c192f8b0 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Time-Piece/t/06large.t @@ -0,0 +1,42 @@ +use Test::More; +use Time::Piece; +use Time::Seconds; + +# Large tests - test dates outside of the epoch range, +# somewhat silly, but lets see what happens + + +plan skip_all => "Large time tests not required for installation" + unless ( $ENV{AUTOMATED_TESTING} ); + +TODO: { + local $TODO = "Big dates will probably fail on some platforms"; + my $t = gmtime; + + my $base_year = $t->year; + my $one_year = ONE_YEAR; + + for ( 1 .. 50 ) { + $t = $t + $one_year; + cmp_ok( + $t->year, '==', + $base_year + $_, + "Year is: " . ( $base_year + $_ ) + ); + } + + $t = gmtime; + $base_year = $t->year; + + for ( 1 .. 200 ) { + $t = $t - $one_year; + cmp_ok( + $t->year, '==', + $base_year - $_, + "Year is: " . ( $base_year - $_ ) + ); + } + +} + +done_testing(250); diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/t/08truncate.t b/gnu/usr.bin/perl/cpan/Time-Piece/t/08truncate.t new file mode 100644 index 00000000000..4bacf0e0639 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Time-Piece/t/08truncate.t @@ -0,0 +1,51 @@ +use strict; +use warnings; +use Test::More tests => 24; + +use Time::Piece; + +my $epoch = 1373371631; +my $t = gmtime($epoch); # 2013-07-09T12:07:11 + +is ($t->truncate, $t, 'No args, same object'); +is ($t->truncate('foo'), $t, 'No "to" arg, same object'); +eval { $t->truncate('to') }; +like ($@, qr/Invalid value of 'to' parameter/, + 'No "to" value croaks'); +eval { $t->truncate('to' => 'foo') }; +like ($@, qr/Invalid value of 'to' parameter: foo/, + 'Unrecognised "to" value croaks'); + +my $short = $t->truncate(to => 'second'); +my $exp = $epoch; +cmp_ok ($short->epoch, '==', $exp, 'Truncate to second'); + +$short = $t->truncate(to => 'minute'); +$exp -= 11; +cmp_ok ($short->epoch, '==', $exp, 'Truncate to minute'); + +$short = $t->truncate(to => 'hour'); +$exp -= 420; +cmp_ok ($short->epoch, '==', $exp, 'Truncate to hour'); + +$short = $t->truncate(to => 'day'); +$exp -= 43200; +cmp_ok ($short->epoch, '==', $exp, 'Truncate to day'); + +$short = $t->truncate(to => 'month'); +$exp -= 8 * 86400; +cmp_ok ($short->epoch, '==', $exp, 'Truncate to month'); + +$exp = gmtime ($exp)->add_months(-6); +$short = $t->truncate(to => 'year'); +cmp_ok ($short, '==', $exp, 'Truncate to year'); + +is ($t->epoch, $epoch, 'Time unchanged'); + +for my $addmon (0..12) { + my $quarter = $short->add_months ($addmon); + $exp = $quarter->add_months (0 - ($addmon % 3)); + $quarter = $quarter->truncate(to => 'quarter'); + cmp_ok ($quarter, '==', $exp, "Truncate to quarter (month $addmon)"); + +} diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/t/09locales.t b/gnu/usr.bin/perl/cpan/Time-Piece/t/09locales.t new file mode 100644 index 00000000000..b1d031646c9 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Time-Piece/t/09locales.t @@ -0,0 +1,111 @@ +use Test::More; +use Time::Piece; + +# Skip if doing a regular install +# These are mostly for reverse parsing tests, not required for installation +plan skip_all => "Reverse parsing not required for installation" + unless ( $ENV{AUTOMATED_TESTING} ); + +my $t = gmtime(1373371631); # 2013-07-09T12:07:11 + +#locale should be undef +is( $t->_locale, undef ); +&Time::Piece::_default_locale(); + +ok( $t->_locale ); + +#use localized names +cmp_ok( $t->monname, 'eq', &Time::Piece::_locale()->{mon}[ $t->_mon ] ); +cmp_ok( $t->month, 'eq', &Time::Piece::_locale()->{mon}[ $t->_mon ] ); +cmp_ok( $t->fullmonth, 'eq', &Time::Piece::_locale()->{month}[ $t->_mon ] ); + +#use localized names +cmp_ok( $t->wdayname, 'eq', &Time::Piece::_locale()->{wday}[ $t->_wday ] ); +cmp_ok( $t->day, 'eq', &Time::Piece::_locale()->{wday}[ $t->_wday ] ); +cmp_ok( $t->fullday, 'eq', &Time::Piece::_locale()->{weekday}[ $t->_wday ] ); + +my @frdays = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); +$t->day_list(@frdays); +cmp_ok( $t->day, 'eq', &Time::Piece::_locale()->{wday}[ $t->_wday ] ); +cmp_ok( $t->fullday, 'eq', &Time::Piece::_locale()->{weekday}[ $t->_wday ] ); + + +#load local locale +Time::Piece->use_locale(); + +#test reverse parsing +sub check_parsed +{ + my ( $t, $parsed, $t_str, $strp_format ) = @_; + + cmp_ok( $parsed->epoch, '==', $t->epoch, + "Epochs match for $t_str with $strp_format" ); + cmp_ok( + $parsed->strftime($strp_format), + 'eq', + $t->strftime($strp_format), + "Outputs formatted with $strp_format match" + ); + cmp_ok( $parsed->strftime(), 'eq', $t->strftime(), + 'Outputs formatted as default match' ); +} + +my @dates = ( + '%Y-%m-%d %H:%M:%S', + '%Y-%m-%d %T', + '%A, %e %B %Y at %H:%M:%S', + '%a, %e %b %Y at %r', + '%s', + '%c', + '%F %T', + +#TODO +# '%u %U %Y %T', #%U,W,V currently skipped inside strptime +# '%w %W %y %T', +# '%A, %e %B %Y at %I:%M:%S %p', #%I and %p can be locale dependant + '%x %X', #hard coded to American localization +); + +for my $time ( + time(), # Now, whenever that might be + 1451606400, # 2016-01-01 00:00 + 1451649600, # 2016-01-01 12:00 + ) +{ + my $t = gmtime($time); + for my $strp_format (@dates) { + + my $t_str = $t->strftime($strp_format); + my $parsed; + SKIP: { + eval { $parsed = $t->strptime( $t_str, $strp_format ); }; + skip "gmtime strptime parse failed", 3 if $@; + check_parsed( $t, $parsed, $t_str, $strp_format ); + } + + } + +} + +for my $time ( + time(), # Now, whenever that might be + 1451606400, # 2016-01-01 00:00 + 1451649600, # 2016-01-01 12:00 + ) +{ + my $t = localtime($time); + for my $strp_format (@dates) { + + my $t_str = $t->strftime($strp_format); + my $parsed; + SKIP: { + eval { $parsed = $t->strptime( $t_str, $strp_format ); }; + skip "localtime strptime parse failed", 3 if $@; + check_parsed( $t, $parsed, $t_str, $strp_format ); + } + + } + +} + +done_testing(154); diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/t/10overload.t b/gnu/usr.bin/perl/cpan/Time-Piece/t/10overload.t new file mode 100644 index 00000000000..a85b5097130 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Time-Piece/t/10overload.t @@ -0,0 +1,25 @@ +use strict; +use warnings; +use Time::Piece; +use Test::More; + +eval 'use Math::BigInt'; +plan skip_all => "Math::BigInt required for testing overloaded operands" if $@; + +my $t = Time::Piece->gmtime(315532800); # 00:00:00 1/1/1980 +isa_ok $t, 'Time::Piece'; +is $t->cdate, 'Tue Jan 1 00:00:00 1980', 'got expected gmtime with int secs'; + +$t = Time::Piece->gmtime(Math::BigInt->new('315532800')); # 00:00:00 1/1/1980 +is $t->cdate, 'Tue Jan 1 00:00:00 1980', 'got same time with overloaded secs'; + + +my $big_hour = Math::BigInt->new('3600'); + +$t = $t + $big_hour; +is $t->cdate, 'Tue Jan 1 01:00:00 1980', 'add overloaded value'; + +$t = $t - $big_hour; +is $t->cdate, 'Tue Jan 1 00:00:00 1980', 'sub overloaded value'; + +done_testing; diff --git a/gnu/usr.bin/perl/cpan/Time-Piece/t/99legacy.t b/gnu/usr.bin/perl/cpan/Time-Piece/t/99legacy.t new file mode 100644 index 00000000000..175e335347f --- /dev/null +++ b/gnu/usr.bin/perl/cpan/Time-Piece/t/99legacy.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +no warnings 'deprecated'; + +use Test::More tests => 5; + +BEGIN { use_ok('Time::Piece'); } + +# The parse() legacy method is deprecated and will not be maintained. +# The tests in this script illustrate both its functionality and some of +# its bugs. This script should be removed from the test suite once +# parse() has been deleted from Time::Piece. + +SKIP: { + skip "Linux only", 4 if $^O !~ /linux/i; + + my $timestring = '2000-01-01T06:00:00'; + my $t1 = Time::Piece->parse($timestring); + isnt( $t1->datetime, $timestring, 'LEGACY: parse string months fail' ); + my $t2 = $t1->parse( 0, 0, 6, 1, 0, 100 ); + is( $t2->datetime, $timestring, 'LEGACY: parse array' ); + eval { $t2 = Time::Piece->parse(); }; + is( $t2->datetime, $timestring, 'LEGACY: parse with no args dies' ); + eval { $t2 = Time::Piece::parse( 0, 0, 12, 1, 0, 100 ); }; + is( $t2->datetime, $timestring, 'LEGACY: parse as non-method dies' ); +} diff --git a/gnu/usr.bin/perl/cpan/Win32/longpath.inc b/gnu/usr.bin/perl/cpan/Win32/longpath.inc index ea6c1de48ac..429e65d00c1 100644 --- a/gnu/usr.bin/perl/cpan/Win32/longpath.inc +++ b/gnu/usr.bin/perl/cpan/Win32/longpath.inc @@ -81,7 +81,7 @@ LONGPATH(CHAR_T *path) *start = sep; if (fhand != INVALID_HANDLE_VALUE) { STRLEN len = FN_STRLEN(fdata.cFileName); - if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) { + if (len < (STRLEN)(tmpbuf - tmpstart + sizeof(tmpbuf))) { FN_STRCPY(tmpstart, fdata.cFileName); tmpstart += len; FindClose(fhand); diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/Guard.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/Guard.pm index bd34fc81b20..8ee412bac4f 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/Guard.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/Guard.pm @@ -4,7 +4,7 @@ use strict; use warnings; # ABSTRACT: Wrapper class for calling subs at end of scope -our $VERSION = '2.29'; # VERSION +our $VERSION = '2.32'; # VERSION # This code schedules the cleanup of subroutines at the end of # scope. It's directly inspired by chocolateboy's excellent diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/GuardStack.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/GuardStack.pm index 3ee3ae51db5..9b0a906d962 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/GuardStack.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Scope/GuardStack.pm @@ -6,7 +6,7 @@ use warnings; use autodie::Scope::Guard; # ABSTRACT: Hook stack for managing scopes via %^H -our $VERSION = '2.29'; # VERSION +our $VERSION = '2.32'; # VERSION my $H_KEY_STEM = __PACKAGE__ . '/guard'; my $COUNTER = 0; diff --git a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Util.pm b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Util.pm index 2a308a89778..1a04a195c0b 100644 --- a/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Util.pm +++ b/gnu/usr.bin/perl/cpan/autodie/lib/autodie/Util.pm @@ -14,7 +14,7 @@ our @EXPORT_OK = qw( on_end_of_compile_scope ); -our $VERSION = '2.29'; # VERSION: Generated by DZP::OurPkg:Version +our $VERSION = '2.32'; # VERSION: Generated by DZP::OurPkg:Version # ABSTRACT: Internal Utility subroutines for autodie and Fatal diff --git a/gnu/usr.bin/perl/cpan/autodie/t/kill.t b/gnu/usr.bin/perl/cpan/autodie/t/kill.t index 22d4b36c82c..eb2083fb99f 100644 --- a/gnu/usr.bin/perl/cpan/autodie/t/kill.t +++ b/gnu/usr.bin/perl/cpan/autodie/t/kill.t @@ -5,6 +5,10 @@ use autodie; use constant SYSINIT => 1; +if ($^O eq 'MSWin32') { + plan skip_all => "Can't send signals to own process on recent versions of Windows."; +} + if (not CORE::kill(0,$$)) { plan skip_all => "Can't send signals to own process on this system."; } @@ -13,14 +17,22 @@ if (CORE::kill(0, SYSINIT)) { plan skip_all => "Can unexpectedly signal process 1. Won't run as root."; } -plan tests => 4; +$SIG{HUP} = sub { }; # Ignore SIGHUP + +plan tests => 6; -eval { kill(0, $$); }; +eval { my $rv = kill(0, $$); }; is($@, '', "Signalling self is fine"); -eval { kill(0, SYSINIT ) }; -isa_ok($@, 'autodie::exception', "Signalling init is not allowed."); +eval { kill('HUP', $$); }; +is($@, '', "Kill with non-zero signal, in void context is ok"); + +eval { kill(0, SYSINIT) }; +isa_ok($@, 'autodie::exception', "kill 0 should die if called in void context"); + +eval { my $rv = kill(0, SYSINIT) }; +is($@, '', "kill 0 should never die if called in scalar context"); -eval { kill(0, $$, SYSINIT) }; +eval { my $rv = kill('HUP', $$, SYSINIT) }; isa_ok($@, 'autodie::exception', 'kill exception on single failure.'); is($@->return, 1, "kill fails correctly on a 'true' failure."); diff --git a/gnu/usr.bin/perl/cpan/autodie/t/no-default.t b/gnu/usr.bin/perl/cpan/autodie/t/no-default.t new file mode 100644 index 00000000000..44d2acf27a6 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/autodie/t/no-default.t @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +package foo; +use warnings; +use strict; +use Test::More tests => 2; +use autodie; + + +use_system(); +ok("system() works with a lexical 'no autodie' block (github issue #69"); +break_system(); + +sub break_system { + no autodie; + open(my $fh, "<", 'NONEXISTENT'); + ok("survived failing open"); +} + +sub use_system { + system($^X, '-e' , 1); +} +1; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/perl.conf b/gnu/usr.bin/perl/cpan/podlators/t/data/perl.conf index 8b76b1c8fbd..ca0556858bf 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/perl.conf +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/perl.conf @@ -1,7 +1,7 @@ # Configuration for Perl tests. -*- perl -*- # Default minimum version requirement. -$MINIMUM_VERSION = '5.006'; +$MINIMUM_VERSION = '5.008'; # File must end with this line. 1; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/overstrike/tag-width b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/overstrike/tag-width new file mode 100644 index 00000000000..d12b16be8e0 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/overstrike/tag-width @@ -0,0 +1,35 @@ +[name] +Tag width with formatting + +[input] +=head1 TAG WIDTH + +=over 10 + +=item 12345678 + +A + +=item B<12345678> + +B + +=item 1Z<> + +C + +=item B<1> + +D + +=back + +[output] +TTAAGG WWIIDDTTHH + 12345678 A + + 1122334455667788 B + + 1 C + + 11 D diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/overstrike/wrapping b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/overstrike/wrapping new file mode 100644 index 00000000000..93405f7c8ce --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/overstrike/wrapping @@ -0,0 +1,11 @@ +[name] +Wrapping + +[input] +=head1 WRAPPING + +B<I<Do>> I<B<not>> B<I<include>> B<I<formatting codes when>> B<I<wrapping>>. + +[output] +WWRRAAPPPPIINNGG + DDoo _n_o_t iinncclluuddee ffoorrmmaattttiinngg ccooddeess wwhheenn wwrraappppiinngg. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/termcap/term-unknown b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/termcap/term-unknown new file mode 100644 index 00000000000..2f060774337 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/termcap/term-unknown @@ -0,0 +1,13 @@ +[name] +Rendering with unknown terminal type + +[input] +=head1 UNKNOWN + +An unknown I<terminal type> B<should> C<suppress> all termcap-based +formatting and still wrap successfully. + +[output] +UNKNOWN + An unknown terminal type should "suppress" all termcap-based formatting + and still wrap successfully. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/alt b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/alt new file mode 100644 index 00000000000..9f4e9b73ab0 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/alt @@ -0,0 +1,38 @@ +[name] +Alternate output + +[options] +alt 1 + +[input] +=head1 SAMPLE + +=over 4 + +=item F + +Paragraph. + +=item Bar + +=item B + +Paragraph. + +=item Longer + +Paragraph. + +=back + +[output] + +==== SAMPLE ==== + +: F Paragraph. + +: Bar +: B Paragraph. + +: Longer + Paragraph. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/c-with-spaces b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/c-with-spaces new file mode 100644 index 00000000000..466e95e385c --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/c-with-spaces @@ -0,0 +1,11 @@ +[name] +C<> with spaces + +[input] +=head1 CE<lt>E<gt> WITH SPACES + +What does C<< this. >> end up looking like? + +[output] +C<> WITH SPACES + What does "this." end up looking like? diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/code b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/code new file mode 100644 index 00000000000..89c06bb43e3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/code @@ -0,0 +1,33 @@ +[name] +code option + +[options] +code 1 + +[input] +This is some random text. +This is more random text. + +This is some random text. +This is more random text. + +=head1 SAMPLE + +This is POD. + +=cut + +This is more random text. + +[output] +This is some random text. +This is more random text. + +This is some random text. +This is more random text. + +SAMPLE + This is POD. + + +This is more random text. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/empty b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/empty new file mode 100644 index 00000000000..307e36d2934 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/empty @@ -0,0 +1,7 @@ +[name] +Empty document + +[input] +=pod + +[output] diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-die b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-die new file mode 100644 index 00000000000..ab4a493bd56 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-die @@ -0,0 +1,25 @@ +[name] +Errors throw exceptions + +[options] +errors die + +[input] +=over 4 + +=item Foo + +Bar. + +=head1 NEXT + +[output] + Foo Bar. + +NEXT + +[errors] +Pod input around line 7: You forgot a '=back' before '=head1' + +[exception] +POD document had syntax errors diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-none b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-none new file mode 100644 index 00000000000..b0fa47b5991 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-none @@ -0,0 +1,19 @@ +[name] +Suppress errors + +[options] +errors none + +[input] +=over 4 + +=item Foo + +Bar. + +=head1 NEXT + +[output] + Foo Bar. + +NEXT diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-normal b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-normal new file mode 100644 index 00000000000..b99111661ad --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-normal @@ -0,0 +1,22 @@ +[name] +Normal error handling + +[input] +=over 4 + +=item Foo + +Bar. + +=head1 NEXT + +[output] + Foo Bar. + +NEXT +POD ERRORS + Hey! The above document had some coding errors, which are explained + below: + + Around line 7: + You forgot a '=back' before '=head1' diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-pod b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-pod new file mode 100644 index 00000000000..807de010f87 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-pod @@ -0,0 +1,25 @@ +[name] +Errors to POD source + +[options] +errors pod + +[input] +=over 4 + +=item Foo + +Bar. + +=head1 NEXT + +[output] + Foo Bar. + +NEXT +POD ERRORS + Hey! The above document had some coding errors, which are explained + below: + + Around line 7: + You forgot a '=back' before '=head1' diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-stderr b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-stderr new file mode 100644 index 00000000000..e1ec95b6f5e --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-stderr @@ -0,0 +1,22 @@ +[name] +Errors to standard error + +[options] +errors stderr + +[input] +=over 4 + +=item Foo + +Bar. + +=head1 NEXT + +[output] + Foo Bar. + +NEXT + +[errors] +Pod input around line 7: You forgot a '=back' before '=head1' diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-stderr-opt b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-stderr-opt new file mode 100644 index 00000000000..7547f846da0 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/error-stderr-opt @@ -0,0 +1,22 @@ +[name] +Errors to standard error with stderr option + +[options] +stderr 1 + +[input] +=over 4 + +=item Foo + +Bar. + +=head1 NEXT + +[output] + Foo Bar. + +NEXT + +[errors] +Pod input around line 7: You forgot a '=back' before '=head1' diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/for b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/for new file mode 100644 index 00000000000..56fb7673447 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/for @@ -0,0 +1,28 @@ +[name] +Handling of =for + +[input] +=head1 Test of =for + +=for comment +This won't be seen. + +Yes. + +=for text +This should be seen. + +=for TEXT As should this. + +=for man +But this shouldn't. + +Some more text. + +[output] +Test of =for + Yes. + +This should be seen. +As should this. + Some more text. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/iso-8859-1 b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/iso-8859-1 new file mode 100644 index 00000000000..739fa928301 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/iso-8859-1 @@ -0,0 +1,25 @@ +[name] +ISO-8859-1 encoding + +[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] +ACCENTS + Beyoncé! Beyoncé! Beyoncé!! + + Beyoncé! Beyoncé! + Beyoncé! Beyoncé! + Beyoncé! Beyoncé! + + Older versions didn't convert Beyoncé in verbatim. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/late-encoding b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/late-encoding new file mode 100644 index 00000000000..99c0de938a5 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/late-encoding @@ -0,0 +1,28 @@ +[name] +Late use of =encoding + +[input] +=pod + +=head1 NAME + +This is the first ascii text + +=encoding utf8 + +=over 4 + +=item ⇒This is the first non-ascii text⇠+ +This is the second ascii text + +=back + +=cut + +[output] +NAME + This is the first ascii text + + ⇒This is the first non-ascii text⇠+ This is the second ascii text diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/link-rt b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/link-rt new file mode 100644 index 00000000000..8669874f71a --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/link-rt @@ -0,0 +1,11 @@ +[name] +Link to an RT ticket + +[input] +=head1 RT LINK + +L<[perl #12345]|https://rt.cpan.org/12345> + +[output] +RT LINK + [perl #12345] <https://rt.cpan.org/12345> diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/link-url b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/link-url new file mode 100644 index 00000000000..7ef33fd172e --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/link-url @@ -0,0 +1,11 @@ +[name] +Link to a URL + +[input] +=head1 LINK TO URL + +This is a L<link|http://www.example.com/> to a URL. + +[output] +LINK TO URL + This is a link <http://www.example.com/> to a URL. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/margin b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/margin new file mode 100644 index 00000000000..786f06b97c3 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/margin @@ -0,0 +1,34 @@ +[name] +margin option + +[options] +margin 4 + +[input] +=head1 SAMPLE + +This is some body text that is long enough to be a paragraph that wraps, +thereby testing margins with wrapped paragraphs. + + This is some verbatim text. + +=over 6 + +=item Test + +This is a test of an indented paragraph. + +This is another indented paragraph. + +=back + +[output] + SAMPLE + This is some body text that is long enough to be a paragraph that + wraps, thereby testing margins with wrapped paragraphs. + + This is some verbatim text. + + Test This is a test of an indented paragraph. + + This is another indented paragraph. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/nonbreaking-space b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/nonbreaking-space new file mode 100644 index 00000000000..d57ed73ca18 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/nonbreaking-space @@ -0,0 +1,11 @@ +[name] +Multiple non-breaking spaces + +[input] +=head1 Test of SE<lt>E<gt> + +This is some S< > whitespace. + +[output] +Test of S<> + This is some whitespace. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/nourls b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/nourls new file mode 100644 index 00000000000..a34202a0614 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/nourls @@ -0,0 +1,14 @@ +[name] +nourls option + +[options] +nourls 1 + +[input] +=head1 URL suppression + +L<anchor|http://www.example.com/> + +[output] +URL suppression + anchor diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/periods b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/periods new file mode 100644 index 00000000000..44fe3a2bb87 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/periods @@ -0,0 +1,11 @@ +[name] +Quoting of periods + +[input] +=head1 PERIODS + +This C<.> should be quoted. + +[output] +PERIODS + This "." should be quoted. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/quotes-opt b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/quotes-opt new file mode 100644 index 00000000000..4d2e6b6408b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/quotes-opt @@ -0,0 +1,14 @@ +[name] +quotes option + +[options] +quotes <<<>>> + +[input] +=head1 FOO C<BAR> BAZ + +Foo C<bar> baz. + +[output] +FOO <<<BAR>>> BAZ + Foo <<<bar>>> baz. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/s-whitespace b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/s-whitespace new file mode 100644 index 00000000000..ff4febc6e71 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/s-whitespace @@ -0,0 +1,11 @@ +[name] +S<> whitespace + +[input] +=head1 Test of SE<lt>E<gt> + +This is S<some whitespace>. + +[output] +Test of S<> + This is some whitespace. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/sentence-spacing b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/sentence-spacing new file mode 100644 index 00000000000..bce8c813c85 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/sentence-spacing @@ -0,0 +1,18 @@ +[name] +Spacing with sentence option + +[options] +sentence 1 + +[input] +=head1 EXAMPLE + +Whitespace around C<< this. >> must be ignored per perlpodspec. >> +needs to eat all of the space in front of it. + +=cut + +[output] +EXAMPLE + Whitespace around "this." must be ignored per perlpodspec. >> needs to + eat all of the space in front of it. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/utf8 b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/utf8 new file mode 100644 index 00000000000..8231a2abd93 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/utf8 @@ -0,0 +1,38 @@ +[name] +UTF-8 text + +[input] +=encoding utf-8 + +=head1 I can eat glass + +=over 4 + +=item Esperanto + +Mi povas manÄi vitron, Äi ne damaÄas min. + +=item Braille + +⠊⠀⠉â â ⠀⠑â ⠞⠀⠛⠇â â Žâ Žâ €â â ⠙⠀⠊⠞⠀⠙⠕⠑⠎â ⠞⠀⠓⠥⠗⠞⠀â â ‘ + +=item Hindi + +मैं काà¤à¤š खा सकता हूठऔर मà¥à¤à¥‡ उससे कोई चोट नहीं पहà¥à¤‚चती. + +=back + +See L<http://www.columbia.edu/kermit/utf8.html> + +[output] +I can eat glass + Esperanto + Mi povas manÄi vitron, Äi ne damaÄas min. + + Braille + ⠊⠀⠉â â ⠀⠑â ⠞⠀⠛⠇â â Žâ Žâ €â â ⠙⠀⠊⠞⠀⠙⠕⠑⠎â ⠞⠀⠓⠥⠗⠞⠀â â ‘ + + Hindi + मैं काà¤à¤š खा सकता हूठऔर मà¥à¤à¥‡ उससे कोई चोट नहीं पहà¥à¤‚चती. + + See <http://www.columbia.edu/kermit/utf8.html> diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/utf8-iso b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/utf8-iso new file mode 100644 index 00000000000..ba375e49ad2 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/utf8-iso @@ -0,0 +1,28 @@ +[name] +ISO-8859-1 encoding with forced UTF-8 output + +[options] +utf8 1 + +[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] +ACCENTS + Beyoncé! Beyoncé! Beyoncé!! + + Beyoncé! Beyoncé! + Beyoncé! Beyoncé! + Beyoncé! Beyoncé! + + Older versions didn't convert Beyoncé in verbatim. diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/verbatim b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/verbatim new file mode 100644 index 00000000000..689a60f94df --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/snippets/text/verbatim @@ -0,0 +1,18 @@ +[name] +Verbatim text + +[input] +=pod + +text + + line1 + + line3 + +[output] + text + + line1 + + line3 diff --git a/gnu/usr.bin/perl/cpan/podlators/t/data/termcap b/gnu/usr.bin/perl/cpan/podlators/t/data/termcap index 80948156caa..32346dd08d5 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/data/termcap +++ b/gnu/usr.bin/perl/cpan/podlators/t/data/termcap @@ -6,3 +6,4 @@ # provide this file anyway to ensure the test suite will still run. xterm:co=#80:do=^J:md=\E[1m:us=\E[4m:me=\E[m +unknown:co=#80:do=^J diff --git a/gnu/usr.bin/perl/cpan/podlators/t/docs/spdx-license.t b/gnu/usr.bin/perl/cpan/podlators/t/docs/spdx-license.t index 100adf11eeb..5b34cab493b 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/docs/spdx-license.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/docs/spdx-license.t @@ -9,7 +9,7 @@ # The canonical version of this file is maintained in the rra-c-util package, # which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. # -# Copyright 2018 Russ Allbery <eagle@eyrie.org> +# Copyright 2018-2019 Russ Allbery <eagle@eyrie.org> # # Permission is hereby granted, free of charge, to any person obtaining a # copy of this software and associated documentation files (the "Software"), @@ -31,21 +31,22 @@ # # SPDX-License-Identifier: MIT -use 5.006; +use 5.008; use strict; use warnings; use lib 't/lib'; +use Test::RRA qw(skip_unless_automated); + use File::Find qw(find); use Test::More; -use Test::RRA qw(skip_unless_automated); # File name (the file without any directory component) and path patterns to # skip for this check. ## no critic (RegularExpressions::ProhibitFixedStringMatches) my @IGNORE = ( - qr{ \A Build ( [.] .* )? \z }ixms, # Generated file from Build.PL + qr{ \A Build ( [.] (?!PL) .* )? \z }ixms, # Generated file from Build.PL qr{ \A LICENSE \z }xms, # Generated file, no license itself qr{ \A (Changes|NEWS|THANKS) \z }xms, # Package license should be fine qr{ \A TODO \z }xms, # Package license should be fine @@ -60,11 +61,13 @@ my @IGNORE_PATHS = ( qr{ \A [.] /_build/ }xms, # Module::Build metadata qr{ \A [.] /blib/ }xms, # Perl build system artifacts qr{ \A [.] /cover_db/ }xms, # Artifacts from coverage testing + qr{ \A [.] /debian/ }xms, # Found in debian/* branches qr{ \A [.] /docs/metadata/ }xms, # Package license should be fine qr{ \A [.] /README ( [.] .* )? \z }xms, # Package license should be fine qr{ \A [.] /share/ }xms, # Package license should be fine qr{ \A [.] /t/data .* /metadata/ }xms, # Test metadata qr{ \A [.] /t/data .* /output/ }xms, # Test output + qr{ \A [.] /t/data .* [.] json \z }xms, # Test metadata ); ## use critic @@ -81,9 +84,7 @@ sub check_file { my $filename = $_; my $path = $File::Find::name; - # Ignore files in the whitelist, binary files, and files under 1KB. The - # latter can be rolled up into the overall project license and the license - # notice may be a substantial portion of the file size. + # Ignore files in the whitelist and binary files. for my $pattern (@IGNORE) { return if $filename =~ $pattern; } @@ -95,12 +96,14 @@ sub check_file { } return if -d $filename; return if !-T $filename; - return if -s $filename < 1024; # Scan the file. - my ($saw_spdx, $skip_spdx); + my ($saw_legacy_notice, $saw_spdx, $skip_spdx); open(my $file, '<', $filename) or BAIL_OUT("Cannot open $path"); while (defined(my $line = <$file>)) { + if ($line =~ m{ \b See \s+ LICENSE \s+ for \s+ licensing }xms) { + $saw_legacy_notice = 1; + } if ($line =~ m{ \b SPDX-License-Identifier: \s+ \S+ }xms) { $saw_spdx = 1; last; @@ -111,7 +114,16 @@ sub check_file { } } close($file) or BAIL_OUT("Cannot close $path"); - ok($saw_spdx || $skip_spdx, $path); + + # If there is a legacy license notice, report a failure regardless of file + # size. Otherwise, skip files under 1KB. They can be rolled up into the + # overall project license and the license notice may be a substantial + # portion of the file size. + if ($saw_legacy_notice) { + ok(!$saw_legacy_notice, "$path has legacy license notice"); + } else { + ok($saw_spdx || $skip_spdx || -s $filename < 1024, $path); + } return; } diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/iso-8859-1.t b/gnu/usr.bin/perl/cpan/podlators/t/man/iso-8859-1.t index 0c1dac38bef..2b2106f14f9 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/iso-8859-1.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/iso-8859-1.t @@ -2,12 +2,14 @@ # # Test Pod::Man ISO-8859-1 handling # -# Copyright 2016 Russ Allbery <rra@cpan.org> +# Copyright 2016, 2019 Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it # under the same terms as Perl itself. +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; @@ -22,4 +24,4 @@ BEGIN { } # Test the snippet with the proper encoding. -test_snippet('Pod::Man', 'man/iso-8859-1', { encoding => 'iso-8859-1' }); +test_snippet('Pod::Man', 'man/iso-8859-1'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/man/snippets.t b/gnu/usr.bin/perl/cpan/podlators/t/man/snippets.t index 159887199a4..7e0ad3808fd 100644 --- a/gnu/usr.bin/perl/cpan/podlators/t/man/snippets.t +++ b/gnu/usr.bin/perl/cpan/podlators/t/man/snippets.t @@ -2,7 +2,7 @@ # # Test Pod::Man behavior with various snippets. # -# Copyright 2002, 2004, 2006, 2008-2009, 2012-2013, 2015-2016, 2018 +# Copyright 2002, 2004, 2006, 2008-2009, 2012-2013, 2015-2016, 2018-2019 # Russ Allbery <rra@cpan.org> # # This program is free software; you may redistribute it and/or modify it @@ -10,7 +10,7 @@ # # SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl -use 5.006; +use 5.008; use strict; use warnings; diff --git a/gnu/usr.bin/perl/cpan/podlators/t/style/obsolete-strings.t b/gnu/usr.bin/perl/cpan/podlators/t/style/obsolete-strings.t new file mode 100644 index 00000000000..fca5a80f30b --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/style/obsolete-strings.t @@ -0,0 +1,96 @@ +#!/usr/bin/perl +# +# Check for obsolete strings in source files. +# +# Examine all source files in a distribution for obsolete strings and report +# on files that fail this check. This catches various transitions I want to +# do globally in all my packages, like changing my personal URLs to https. +# +# The canonical version of this file is maintained in the rra-c-util package, +# which can be found at <https://www.eyrie.org/~eagle/software/rra-c-util/>. +# +# Copyright 2016, 2018-2019 Russ Allbery <eagle@eyrie.org> +# +# Permission is hereby granted, free of charge, to any person obtaining a +# copy of this software and associated documentation files (the "Software"), +# to deal in the Software without restriction, including without limitation +# the rights to use, copy, modify, merge, publish, distribute, sublicense, +# and/or sell copies of the Software, and to permit persons to whom the +# Software is furnished to do so, subject to the following conditions: +# +# The above copyright notice and this permission notice shall be included in +# all copies or substantial portions of the Software. +# +# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +# THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +# DEALINGS IN THE SOFTWARE. +# +# SPDX-License-Identifier: MIT + +use 5.008; +use strict; +use warnings; + +use lib 't/lib'; + +use Test::RRA qw(skip_unless_automated); + +use File::Find qw(find); +use Test::More; + +# Bad patterns to search for. +my @BAD_REGEXES = (qr{ http:// \S+ [.]eyrie[.]org }xms); +my @BAD_STRINGS = qw(rra@stanford.edu RRA_MAINTAINER_TESTS); + +# File or directory names to always skip. +my %SKIP = map { $_ => 1 } qw( + .git Changes _build blib cover_db obsolete-strings.t +); + +# Only run this test during automated testing, since failure doesn't indicate +# any user-noticable flaw in the package itself. +skip_unless_automated('Obsolete strings tests'); + +# Scan files for bad URL patterns. This is meant to be run as the wanted +# function from File::Find. +sub check_file { + my $filename = $_; + + # Ignore and prune any skipped files. Ignore directories and binaries. + if ($SKIP{$filename}) { + $File::Find::prune = 1; + return; + } + return if -d $filename; + return if !-T $filename; + + # Scan the file. + open(my $fh, '<', $filename) or BAIL_OUT("Cannot open $File::Find::name"); + while (defined(my $line = <$fh>)) { + for my $regex (@BAD_REGEXES) { + if ($line =~ $regex) { + ok(0, "$File::Find::name contains $regex"); + close($fh) or BAIL_OUT("Cannot close $File::Find::name"); + return; + } + } + for my $string (@BAD_STRINGS) { + if (index($line, $string) != -1) { + ok(0, "$File::Find::name contains $string"); + close($fh) or BAIL_OUT("Cannot close $File::Find::name"); + return; + } + } + } + close($fh) or BAIL_OUT("Cannot close $File::Find::name"); + ok(1, $File::Find::name); + return; +} + +# Use File::Find to scan all files from the top of the directory. +find(\&check_file, q{.}); +done_testing(); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/invalid.t b/gnu/usr.bin/perl/cpan/podlators/t/text/invalid.t new file mode 100644 index 00000000000..27a4e820fa7 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/invalid.t @@ -0,0 +1,61 @@ +#!/usr/bin/perl -w +# +# Test Pod::Text with a document that produces only errors. +# +# Documents with only errors were shown as contentless but had a POD ERRORS +# section, which previously led to internal errors because state variables +# weren't properly initialized. See CPAN RT #88724. +# +# Copyright 2013, 2018, 2020 Russ Allbery <rra@cpan.org> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl + +use 5.008; +use strict; +use warnings; + +use Test::More tests => 8; + +BEGIN { + use_ok('Pod::Text'); +} + +# Set up Pod::Text to output to a string. +my $parser = Pod::Text->new; +isa_ok($parser, 'Pod::Text'); +my $output; +$parser->output_string(\$output); + +# Ensure any warnings cause a test failure. +## no critic (ErrorHandling::RequireCarping) +local $SIG{__WARN__} = sub { die $_[0] }; + +# Parse a document provided as a string, ensure that it doesn't produce any +# warnings or errors, and check that it either contains no content or a POD +# ERRORS section. +# +# $document - Document to parse +# $name - Name of the test +sub check_document { + my ($document, $name) = @_; + my $result = eval { $parser->parse_string_document($document) }; + ok($result, "Parsed $name"); + is($@, q{}, 'No exceptions'); + if ($output eq q{}) { + # Older Pod::Simple doesn't always produce errors. + ok(1, 'Output is empty'); + } else { + like($output, qr{POD [ ] ERRORS}xms, 'Output contains POD ERRORS'); + } + return; +} + +# Document whose only content is an invalid command. +## no critic (ValuesAndExpressions::ProhibitEscapedCharacters) +check_document("=\xa0", 'invalid command'); + +# Document containing only a =cut. +check_document('=cut', 'document with only =cut'); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/iso-8859-1.t b/gnu/usr.bin/perl/cpan/podlators/t/text/iso-8859-1.t new file mode 100644 index 00000000000..889d553bd8f --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/iso-8859-1.t @@ -0,0 +1,27 @@ +#!/usr/bin/perl +# +# Test Pod::Text ISO-8859-1 handling +# +# Copyright 2016, 2019 Russ Allbery <rra@cpan.org> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl + +use 5.008; +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More tests => 3; +use Test::Podlators qw(test_snippet); + +# Load the module. +BEGIN { + use_ok('Pod::Text'); +} + +# Test the snippet with the proper encoding. +test_snippet('Pod::Text', 'text/iso-8859-1', { encoding => 'iso-8859-1' }); diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/snippets.t b/gnu/usr.bin/perl/cpan/podlators/t/text/snippets.t new file mode 100644 index 00000000000..7667de794ec --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/snippets.t @@ -0,0 +1,38 @@ +#!/usr/bin/perl +# +# Test Pod::Text behavior with various snippets. +# +# Copyright 2002, 2004, 2006-2009, 2012, 2018-2020 +# Russ Allbery <rra@cpan.org> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl + +use 5.008; +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More tests => 53; +use Test::Podlators qw(test_snippet); + +# Load the module. +BEGIN { + use_ok('Pod::Text'); +} + +# List of snippets run by this test. +my @snippets = qw( + alt c-with-spaces code cpp empty error-die error-none error-normal error-pod + error-stderr error-stderr-opt for late-encoding link-rt link-url margin + nonbreaking-space nourls periods quotes-opt s-whitespace sentence-spacing + utf8 verbatim +); + +# Run all the tests. +for my $snippet (@snippets) { + test_snippet('Pod::Text', "text/$snippet"); +} diff --git a/gnu/usr.bin/perl/cpan/podlators/t/text/utf8-io.t b/gnu/usr.bin/perl/cpan/podlators/t/text/utf8-io.t new file mode 100644 index 00000000000..2e59c417007 --- /dev/null +++ b/gnu/usr.bin/perl/cpan/podlators/t/text/utf8-io.t @@ -0,0 +1,48 @@ +#!/usr/bin/perl +# +# Test Pod::Text UTF-8 handling, with and without PerlIO. +# +# Copyright 2002, 2004, 2006-2010, 2012, 2014, 2018, 2020 +# Russ Allbery <rra@cpan.org> +# +# This program is free software; you may redistribute it and/or modify it +# under the same terms as Perl itself. +# +# SPDX-License-Identifier: GPL-1.0-or-later OR Artistic-1.0-Perl + +use 5.008; +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More tests => 17; +use Test::Podlators qw(test_snippet_with_io); + +BEGIN { + use_ok('Pod::Text'); +} + +# Force UTF-8 on all relevant file handles. Hide this in a string eval so +# that older versions of Perl don't croak and minimum-version tests still +# pass. +# +## no critic (BuiltinFunctions::ProhibitStringyEval) +## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) +eval 'binmode(\*STDOUT, ":encoding(utf-8)")'; +my $builder = Test::More->builder; +eval 'binmode($builder->output, ":encoding(utf-8)")'; +eval 'binmode($builder->failure_output, ":encoding(utf-8)")'; +## use critic + +# For each of the UTF-8 snippets, check them with and without PerlIO layers. +for my $snippet (qw(late-encoding s-whitespace utf8)) { + test_snippet_with_io('Pod::Text', "text/$snippet"); + test_snippet_with_io('Pod::Text', "text/$snippet", { perlio_utf8 => 1 }); +} + +# Load a snippet in ISO 8859-1 that forces the output to be in UTF-8. +test_snippet_with_io('Pod::Text', 'text/utf8-iso', + { encoding => 'iso-8859-1' }); +test_snippet_with_io('Pod::Text', 'text/utf8-iso', + { encoding => 'iso-8859-1', perlio_utf8 => 1 }); |