diff options
author | Todd C. Miller <millert@cvs.openbsd.org> | 2005-01-15 21:18:29 +0000 |
---|---|---|
committer | Todd C. Miller <millert@cvs.openbsd.org> | 2005-01-15 21:18:29 +0000 |
commit | 900aea5fee6e7e0e7e6e8c4f0192f99befa3a927 (patch) | |
tree | 79ecffc72620d46df9fe0d71286e0e466415b7f5 /gnu/usr.bin/perl/lib | |
parent | a529bb51c131f3975e0a7daa8eb3d2c865f3fc52 (diff) |
perl 5.8.6 from CPAN
Diffstat (limited to 'gnu/usr.bin/perl/lib')
-rw-r--r-- | gnu/usr.bin/perl/lib/Carp.t | 140 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/Config.t | 107 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/Dumpvalue.t | 5 | ||||
-rwxr-xr-x | gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t | 38 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/open.pm | 141 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/open.t | 15 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/overload.t | 69 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/unicore/mktables | 1 | ||||
-rw-r--r-- | gnu/usr.bin/perl/lib/warnings.pm | 10 |
9 files changed, 363 insertions, 163 deletions
diff --git a/gnu/usr.bin/perl/lib/Carp.t b/gnu/usr.bin/perl/lib/Carp.t index cc2da1744c0..47f83c96c1c 100644 --- a/gnu/usr.bin/perl/lib/Carp.t +++ b/gnu/usr.bin/perl/lib/Carp.t @@ -1,31 +1,33 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; + require './test.pl'; } use Carp qw(carp cluck croak confess); -print "1..9\n"; +plan tests => 19; -print "ok 1\n"; +ok 1; -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!ok (\d+)\n at .+\b(?i:carp\.t) line \d+$! }; +{ local $SIG{__WARN__} = sub { + like $_[0], qr/ok (\d+)\n at.+\b(?i:carp\.t) line \d+$/, 'ok 2\n' }; -carp "ok 2\n"; - -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!(\d+) at .+\b(?i:carp\.t) line \d+$! }; + carp "ok 2\n"; -carp 3; +} + +{ local $SIG{__WARN__} = sub { + like $_[0], qr/(\d+) at.+\b(?i:carp\.t) line \d+$/, 'carp 3' }; + + carp 3; + +} sub sub_4 { -$SIG{__WARN__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at .+\b(?i:carp\.t) line \d+$! }; +local $SIG{__WARN__} = sub { + like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\tmain::sub_4\(\) called at.+\b(?i:carp\.t) line \d+$/, 'cluck 4' }; cluck 4; @@ -33,39 +35,123 @@ cluck 4; sub_4; -$SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+$! }; +{ local $SIG{__DIE__} = sub { + like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+$/, 'croak 5' }; -eval { croak 5 }; + eval { croak 5 }; +} sub sub_6 { - $SIG{__DIE__} = sub { - print "ok $1\n" - if $_[0] =~ m!^(\d+) at .+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at .+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at .+\b(?i:carp\.t) line \d+$! }; + local $SIG{__DIE__} = sub { + like $_[0], qr/^(\d+) at.+\b(?i:carp\.t) line \d+\n\teval \Q{...}\E called at.+\b(?i:carp\.t) line \d+\n\tmain::sub_6\(\) called at.+\b(?i:carp\.t) line \d+$/, 'confess 6' }; eval { confess 6 }; } sub_6; -print "ok 7\n"; +ok(1); # test for caller_info API my $eval = "use Carp::Heavy; return Carp::caller_info(0);"; my %info = eval($eval); -print "not " if ($info{sub_name} ne "eval '$eval'"); -print "ok 8\n"; +is($info{sub_name}, "eval '$eval'", 'caller_info API'); # test for '...::CARP_NOT used only once' warning from Carp::Heavy my $warning; eval { BEGIN { $^W = 1; - $SIG{__WARN__} = + local $SIG{__WARN__} = sub { if( defined $^S ){ warn $_[0] } else { $warning = $_[0] } } } - package Z; + package Z; BEGIN { eval { Carp::croak() } } }; -print $warning ? "not ok 9\n#$warning" : "ok 9\n"; +ok !$warning, q/'...::CARP_NOT used only once' warning from Carp::Heavy/; + + +# tests for global variables +sub x { carp @_ } +sub w { cluck @_ } + +# $Carp::Verbose; +{ my $aref = [ + qr/t at \S*(?i:carp.t) line \d+/, + qr/t at \S*(?i:carp.t) line \d+\n\s*main::x\('t'\) called at \S*(?i:carp.t) line \d+/ + ]; + my $i = 0; + + for my $re (@$aref) { + local $Carp::Verbose = $i++; + local $SIG{__WARN__} = sub { + like $_[0], $re, 'Verbose'; + }; + package Z; + main::x('t'); + } +} + +# $Carp::MaxEvalLen +{ my $test_num = 1; + for(0,4) { + my $txt = "Carp::cluck($test_num)"; + local $Carp::MaxEvalLen = $_; + local $SIG{__WARN__} = sub { + "@_"=~/'(.+?)(?:\n|')/s; + is length($1), length($_?substr($txt,0,$_):substr($txt,0)), 'MaxEvalLen'; + }; + eval "$txt"; $test_num++; + } +} + +# $Carp::MaxArgLen +{ + for(0,4) { + my $arg = 'testtest'; + local $Carp::MaxArgLen = $_; + local $SIG{__WARN__} = sub { + "@_"=~/'(.+?)'/; + is length($1), length($_?substr($arg,0,$_):substr($arg,0)), 'MaxArgLen'; + }; + + package Z; + main::w($arg); + } +} + +# $Carp::MaxArgNums +{ my $i = 0; + my $aref = [ + qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, 3, 4\) called at \S*(?i:carp.t) line \d+/, + qr/1234 at \S*(?i:carp.t) line \d+\n\s*main::w\(1, 2, \.\.\.\) called at \S*(?i:carp.t) line \d+/, + ]; + + for(@$aref) { + local $Carp::MaxArgNums = $i++; + local $SIG{__WARN__} = sub { + like "@_", $_, 'MaxArgNums'; + }; + + package Z; + main::w(1..4); + } +} + +# $Carp::CarpLevel +{ my $i = 0; + my $aref = [ + qr/1 at \S*(?i:carp.t) line \d+\n\s*main::w\(1\) called at \S*(?i:carp.t) line \d+/, + qr/1 at \S*(?i:carp.t) line \d+$/, + ]; + + for (@$aref) { + local $Carp::CarpLevel = $i++; + local $SIG{__WARN__} = sub { + like "@_", $_, 'CarpLevel'; + }; + + package Z; + main::w(1); + } +} diff --git a/gnu/usr.bin/perl/lib/Config.t b/gnu/usr.bin/perl/lib/Config.t index 502f0aa5e2f..3ed110a0499 100644 --- a/gnu/usr.bin/perl/lib/Config.t +++ b/gnu/usr.bin/perl/lib/Config.t @@ -6,7 +6,7 @@ BEGIN { require "./test.pl"; } -plan tests => 47; +plan 'no_plan'; use_ok('Config'); @@ -40,7 +40,7 @@ ok(!exists $Config{d_bork}, "has no d_bork"); like($Config{ivsize}, qr/^(4|8)$/, "ivsize is 4 or 8 (it is $Config{ivsize})"); -# byteorder is virtual, but it has rules. +# byteorder is virtual, but it has rules. like($Config{byteorder}, qr/^(1234|4321|12345678|87654321)$/, "byteorder is 1234 or 4321 or 12345678 or 87654321 (it is $Config{byteorder})"); @@ -62,56 +62,100 @@ ok(exists $Config{ccflags_nolargefiles}, "has ccflags_nolargefiles"); } } -like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); -like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); -like(join("\n", Config::config_re('c.*')), - qr/^c.*?=/, 'config_re' ); +like(Config::myconfig(), qr/osname=\Q$Config{osname}\E/, "myconfig"); +like(Config::config_sh(), qr/osname='\Q$Config{osname}\E'/, "config_sh"); +like(Config::config_sh(), qr/byteorder='[1-8]+'/, + "config_sh has a valid byteorder"); +foreach my $line (Config::config_re('c.*')) { + like($line, qr/^c.*?=.*$/, 'config_re' ); +} my $out = tie *STDOUT, 'FakeOut'; -Config::config_vars('cc'); +Config::config_vars('cc'); # non-regex test of essential cfg-var my $out1 = $$out; $out->clear; -Config::config_vars('d_bork'); +Config::config_vars('d_bork'); # non-regex, non-existent cfg-var my $out2 = $$out; $out->clear; -Config::config_vars('PERL_API_.*'); +Config::config_vars('PERL_API_.*'); # regex, tagged multi-line answer my $out3 = $$out; $out->clear; -Config::config_vars(':PERL_API_.*:'); +Config::config_vars('PERL_API_.*:'); # regex, tagged single-line answer my $out4 = $$out; $out->clear; -Config::config_vars(':PERL_API_REVISION:'); +Config::config_vars(':PERL_API_.*:'); # regex, non-tagged single-line answer my $out5 = $$out; $out->clear; -Config::config_vars('?flags'); +Config::config_vars(':PERL_API_.*'); # regex, non-tagged multi-line answer my $out6 = $$out; $out->clear; +Config::config_vars('PERL_API_REVISION.*:'); # regex, tagged +my $out7 = $$out; +$out->clear; + +Config::config_vars(':PERL_API_REVISION.*'); # regex, non-tagged multi-line answer +my $out8 = $$out; +$out->clear; + +Config::config_vars('PERL_EXPENSIVE_.*:'); # non-matching regex +my $out9 = $$out; +$out->clear; + +Config::config_vars('?flags'); # bogus regex, no explicit warning ! +my $out10 = $$out; +$out->clear; + untie *STDOUT; -like($out1, qr/^cc='\Q$Config{cc}\E';/, "config_vars cc"); -like($out2, qr/^d_bork='UNKNOWN';/, "config_vars d_bork is UNKNOWN"); -is(3, scalar split(/\n/, $out3), "3 PERL_API vars found"); -my @api = $out3 =~ /^PERL_API_(\w+)=(.*);/mg; -is("'5'", $api[1], "1st is 5"); -is("'8'", $api[5], "2nd is 9"); -is("'0'", $api[3], "3rd is 1"); -@api = split(/ /, $out4); -is(3, @api, "trailing colon puts 3 terms on same line"); -unlike($out4, qr/=/, "leading colon suppresses param names"); -is("'5'", $api[0], "revision is 5"); -is("'8'", $api[2], "version is 9"); -is("'0'", $api[1], "subversion is 1"); +like($out1, qr/^cc='\Q$Config{cc}\E';/, "found config_var cc"); +like($out2, qr/^d_bork='UNKNOWN';/, "config_var d_bork is UNKNOWN"); + +# test for leading, trailing colon effects +is(scalar split(/;\n/, $out3), 3, "3 lines found"); +is(scalar split(/;\n/, $out6), 3, "3 lines found"); -is("'5' ", $out5, "leading and trailing colons return just the value"); +is($out4 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out4"); +is($out5 =~ /(;\n)/s, '', "trailing colon gives 1-line response: $out5"); -like($out6, qr/\bnot\s+found\b/, "config_vars with invalid regexp"); +is(scalar split(/=/, $out3), 4, "found 'tag='"); +is(scalar split(/=/, $out4), 4, "found 'tag='"); + +my @api; + +my @rev = @Config{qw(PERL_API_REVISION PERL_API_VERSION PERL_API_SUBVERSION)}; + +print ("# test tagged responses, multi-line and single-line\n"); +foreach $api ($out3, $out4) { + @api = $api =~ /PERL_API_(\w+)=(.*?)(?:;\n|\s)/mg; + is($api[0], "REVISION", "REVISION tag"); + is($api[4], "VERSION", "VERSION tag"); + is($api[2], "SUBVERSION", "SUBVERSION tag"); + is($api[1], "'$rev[0]'", "REVISION is $rev[0]"); + is($api[5], "'$rev[1]'", "VERSION is $rev[1]"); + is($api[3], "'$rev[2]'", "SUBVERSION is $rev[2]"); +} + +print("# test non-tagged responses, multi-line and single-line\n"); +foreach $api ($out5, $out6) { + @api = split /(?: |;\n)/, $api; + is($api[0], "'$rev[0]'", "revision is $rev[0]"); + is($api[2], "'$rev[1]'", "version is $rev[1]"); + is($api[1], "'$rev[2]'", "subversion is $rev[2]"); +} + +# compare to each other, the outputs for trailing, leading colon +$out7 =~ s/ $//; +is("$out7;\n", "PERL_API_REVISION=$out8", "got expected diffs"); + +like($out9, qr/\bnot\s+found\b/, "$out9 - perl is FREE !"); +like($out10, qr/\bnot\s+found\b/, "config_vars with invalid regexp"); # Read-only. @@ -155,3 +199,12 @@ ok( exists $Config{d_fork}, "still d_fork"); is($Config{sig_num_init} =~ tr/,/,/, $Config{sig_size}, "sig_num_init size"); is($Config{sig_name_init} =~ tr/,/,/, $Config{sig_size}, "sig_name_init size"); + +# Test the troublesome virtual stuff +foreach my $pain (qw(byteorder)) { + # No config var is named with anything that is a regexp metachar" + my @result = Config::config_re($pain); + is (scalar @result, 1, "single result for config_re('$pain')"); + like ($result[0], qr/^$pain=(['"])$Config{$pain}\1$/, # grr ' + "which is the expected result for $pain"); +} diff --git a/gnu/usr.bin/perl/lib/Dumpvalue.t b/gnu/usr.bin/perl/lib/Dumpvalue.t index b22b86d7321..8eb70a34b84 100644 --- a/gnu/usr.bin/perl/lib/Dumpvalue.t +++ b/gnu/usr.bin/perl/lib/Dumpvalue.t @@ -205,7 +205,10 @@ is( $out->read, "\$_<foo = 1\n", 'dumped glob for $_<foo correctly (DB)' ); # test CvGV name SKIP: { - skip( 'no Devel::Peek', 1 ) unless use_ok( 'Devel::Peek' ); + if (" $Config::Config{'extensions'} " !~ m[ Devel/Peek ]) { + skip( 'no Devel::Peek', 2 ); + } + use_ok( 'Devel::Peek' ); is( $d->CvGV_name(\&TieOut::read), 'TieOut::read', 'CvGV_name found sub' ); } diff --git a/gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t b/gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t new file mode 100755 index 00000000000..ae04812ff2a --- /dev/null +++ b/gnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t @@ -0,0 +1,38 @@ +require 5; + # Time-stamp: "2004-10-06 23:07:06 ADT" +use strict; +use Test; +BEGIN { plan tests => 22 }; +BEGIN { ok 1 } +use I18N::LangTags (':ALL'); + +print "# Perl v$], I18N::LangTags v$I18N::LangTags::VERSION\n"; +print "# Loaded from ", $INC{'I18N/LangTags.pm'} || "??", "\n"; + +ok lc locale2language_tag('en'), 'en'; +ok lc locale2language_tag('en_US'), 'en-us'; +ok lc locale2language_tag('en_US.ISO8859-1'), 'en-us'; +ok lc(locale2language_tag('C')||''), ''; +ok lc(locale2language_tag('POSIX')||''), ''; + + +ok lc locale2language_tag('eu_mt'), 'eu-mt'; +ok lc locale2language_tag('eu'), 'eu'; +ok lc locale2language_tag('it'), 'it'; +ok lc locale2language_tag('it_IT'), 'it-it'; +ok lc locale2language_tag('it_IT.utf8'), 'it-it'; +ok lc locale2language_tag('it_IT.utf8@euro'), 'it-it'; +ok lc locale2language_tag('it_IT@euro'), 'it-it'; + + +ok lc locale2language_tag('zh_CN.gb18030'), 'zh-cn'; +ok lc locale2language_tag('zh_CN.gbk'), 'zh-cn'; +ok lc locale2language_tag('zh_CN.utf8'), 'zh-cn'; +ok lc locale2language_tag('zh_HK'), 'zh-hk'; +ok lc locale2language_tag('zh_HK.utf8'), 'zh-hk'; +ok lc locale2language_tag('zh_TW'), 'zh-tw'; +ok lc locale2language_tag('zh_TW.euctw'), 'zh-tw'; +ok lc locale2language_tag('zh_TW.utf8'), 'zh-tw'; + +print "# So there!\n"; +ok 1; diff --git a/gnu/usr.bin/perl/lib/open.pm b/gnu/usr.bin/perl/lib/open.pm index 32c5118be9d..45158994619 100644 --- a/gnu/usr.bin/perl/lib/open.pm +++ b/gnu/usr.bin/perl/lib/open.pm @@ -3,64 +3,58 @@ use warnings; use Carp; $open::hint_bits = 0x20000; # HINT_LOCALIZE_HH -our $VERSION = '1.03'; +our $VERSION = '1.04'; + +require 5.008001; # for PerlIO::get_layers() my $locale_encoding; -sub in_locale { $^H & ($locale::hint_bits || 0)} - -sub _get_locale_encoding { - unless (defined $locale_encoding) { - # I18N::Langinfo isn't available everywhere - eval { - require I18N::Langinfo; - I18N::Langinfo->import(qw(langinfo CODESET)); - $locale_encoding = langinfo(CODESET()); - }; - my $country_language; - - no warnings 'uninitialized'; - - if (not $locale_encoding && in_locale()) { - if ($ENV{LC_ALL} =~ /^([^.]+)\.([^.]+)$/) { - ($country_language, $locale_encoding) = ($1, $2); - } elsif ($ENV{LANG} =~ /^([^.]+)\.([^.]+)$/) { - ($country_language, $locale_encoding) = ($1, $2); - } - # LANGUAGE affects only LC_MESSAGES only on glibc - } elsif (not $locale_encoding) { - if ($ENV{LC_ALL} =~ /\butf-?8\b/i || - $ENV{LANG} =~ /\butf-?8\b/i) { - $locale_encoding = 'utf8'; - } - # Could do more heuristics based on the country and language - # parts of LC_ALL and LANG (the parts before the dot (if any)), - # since we have Locale::Country and Locale::Language available. - # TODO: get a database of Language -> Encoding mappings - # (the Estonian database at http://www.eki.ee/letter/ - # would be excellent!) --jhi - } - if (defined $locale_encoding && - lc($locale_encoding) eq 'euc' && - defined $country_language) { - if ($country_language =~ /^ja_JP|japan(?:ese)?$/i) { - $locale_encoding = 'euc-jp'; - } elsif ($country_language =~ /^ko_KR|korean?$/i) { - $locale_encoding = 'euc-kr'; - } elsif ($country_language =~ /^zh_CN|chin(?:a|ese)?$/i) { - $locale_encoding = 'euc-cn'; - } elsif ($country_language =~ /^zh_TW|taiwan(?:ese)?$/i) { - $locale_encoding = 'euc-tw'; - } else { - croak "Locale encoding 'euc' too ambiguous"; - } - } +sub _get_encname { + return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; + return; +} + +sub _drop_oldenc { + # If by the time we arrive here there already is at the top of the + # perlio layer stack an encoding identical to what we would like + # to push via this open pragma, we will pop away the old encoding + # (+utf8) so that we can push ourselves in place (this is easier + # than ignoring pushing ourselves because of the way how ${^OPEN} + # works). So we are looking for something like + # + # stdio encoding(xxx) utf8 + # + # in the existing layer stack, and in the new stack chunk for + # + # :encoding(xxx) + # + # If we find a match, we pop the old stack (once, since + # the utf8 is just a flag on the encoding layer) + my ($h, @new) = @_; + return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/; + my @old = PerlIO::get_layers($h); + return unless @old >= 3 && + $old[-1] eq 'utf8' && + $old[-2] =~ /^encoding\(.+\)$/; + require Encode; + my ($loname, $lcname) = _get_encname($old[-2]); + unless (defined $lcname) { # Should we trust get_layers()? + require Carp; + Carp::croak("open: Unknown encoding '$loname'"); + } + my ($voname, $vcname) = _get_encname($new[-1]); + unless (defined $vcname) { + require Carp; + Carp::croak("open: Unknown encoding '$voname'"); + } + if ($lcname eq $vcname) { + binmode($h, ":pop"); # utf8 is part of the encoding layer } } sub import { my ($class,@args) = @_; - croak("`use open' needs explicit list of PerlIO layers") unless @args; + croak("open: needs explicit list of PerlIO layers") unless @args; my $std; $^H |= $open::hint_bits; my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); @@ -81,7 +75,8 @@ sub import { $layer =~ s/^://; if ($layer eq 'locale') { require Encode; - _get_locale_encoding() + require encoding; + $locale_encoding = encoding::_get_locale_encoding() unless defined $locale_encoding; (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) unless defined $locale_encoding; @@ -105,19 +100,23 @@ sub import { } } if ($type eq 'IN') { - $in = join(' ',@val); + _drop_oldenc(*STDIN, @val); + $in = join(' ', @val); } elsif ($type eq 'OUT') { - $out = join(' ',@val); + _drop_oldenc(*STDOUT, @val); + $out = join(' ', @val); } elsif ($type eq 'IO') { - $in = $out = join(' ',@val); + _drop_oldenc(*STDIN, @val); + _drop_oldenc(*STDOUT, @val); + $in = $out = join(' ', @val); } else { croak "Unknown PerlIO layer class '$type'"; } } - ${^OPEN} = join("\0",$in,$out) if $in or $out; + ${^OPEN} = join("\0", $in, $out); if ($std) { if ($in) { if ($in =~ /:utf8\b/) { @@ -229,35 +228,9 @@ chosen to be in C<< :encoding(koi8r) >>, a C<:std> will cause only the STDOUT and STDERR to be in C<koi8r>. The C<:locale> subpragma implicitly turns on C<:std>. -The logic of C<:locale> is as follows: - -=over 4 - -=item 1. - -If the platform supports the langinfo(CODESET) interface, the codeset -returned is used as the default encoding for the open pragma. - -=item 2. - -If 1. didn't work but we are under the locale pragma, the environment -variables LC_ALL and LANG (in that order) are matched for encodings -(the part after C<.>, if any), and if any found, that is used -as the default encoding for the open pragma. - -=item 3. - -If 1. and 2. didn't work, the environment variables LC_ALL and LANG -(in that order) are matched for anything looking like UTF-8, and if -any found, C<:utf8> is used as the default encoding for the open -pragma. - -=back - -If your locale environment variables (LC_ALL, LC_CTYPE, LANG) -contain the strings 'UTF-8' or 'UTF8' (case-insensitive matching), -the default encoding of your STDIN, STDOUT, and STDERR, and of -B<any subsequent file open>, is UTF-8. +The logic of C<:locale> is described in full in L</encoding>, +but in short it is first trying nl_langinfo(CODESET) and then +guessing from the LC_ALL and LANG locale environment variables. Directory handles may also support PerlIO layers in the future. diff --git a/gnu/usr.bin/perl/lib/open.t b/gnu/usr.bin/perl/lib/open.t index 55b955bd0fc..554798b9d6e 100644 --- a/gnu/usr.bin/perl/lib/open.t +++ b/gnu/usr.bin/perl/lib/open.t @@ -7,7 +7,7 @@ BEGIN { require Config; import Config; } -use Test::More tests => 17; +use Test::More tests => 16; # open::import expects 'open' as its first argument, but it clashes with open() sub import { @@ -43,17 +43,10 @@ eval q{ use warnings 'layer'; use open IN => ':macguffin' ; }; like( $warn, qr/Unknown PerlIO layer/, 'should warn about unknown layer with bad layer provided' ); -SKIP: { - skip("no perlio, no :utf8", 1) unless (find PerlIO::Layer 'perlio'); - skip("no Encode for locale layer", 1) unless eval { require Encode }; - # now load a real-looking locale - $ENV{LC_ALL} = ' .utf8'; - import( 'IN', 'locale' ); - like( ${^OPEN}, qr/^(:utf8)?:utf8\0/, - 'should set a valid locale layer' ); -} +# open :locale logic changed since open 1.04, new logic +# difficult to test portably. -# and see if it sets the magic variables appropriately +# see if it sets the magic variables appropriately import( 'IN', ':crlf' ); ok( $^H & $open::hint_bits, 'hint bits should be set in $^H after open import' ); diff --git a/gnu/usr.bin/perl/lib/overload.t b/gnu/usr.bin/perl/lib/overload.t index f743a822116..519c6d8810d 100644 --- a/gnu/usr.bin/perl/lib/overload.t +++ b/gnu/usr.bin/perl/lib/overload.t @@ -53,17 +53,24 @@ print "1..",&last,"\n"; sub test { $test++; if (@_ > 1) { + my $comment = ""; + $comment = " # " . $_ [2] if @_ > 2; if ($_[0] eq $_[1]) { - print "ok $test\n"; + print "ok $test$comment\n"; + return 1; } else { - print "not ok $test: '$_[0]' ne '$_[1]'\n"; + $comment .= ": '$_[0]' ne '$_[1]'"; + print "not ok $test$comment\n"; + return 0; } } else { if (shift) { print "ok $test\n"; + return 1; } else { print "not ok $test\n"; - } + return 0; + } } } @@ -1086,11 +1093,11 @@ sub xet { @_ == 2 ? $_[0]->{$_[1]} : package main; my $a = Foo->new; $a->xet('b', 42); -print $a->xet('b') == 42 ? "ok 225\n" : "not ok 225\n"; -print defined eval { $a->{b} } ? "not ok 226\n" : "ok 226\n"; -print $@ =~ /zap/ ? "ok 227\n" : "not ok 227\n"; +test ($a->xet('b'), 42); +test (!defined eval { $a->{b} }); +test ($@ =~ /zap/); -print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" : "not ok 228\n"; +test (overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/); { package t229; @@ -1105,8 +1112,52 @@ print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" : my $y = $x; eval { $y++ }; } - print $warn ? "not ok 229\n" : "ok 229\n"; + main::test (!$warn); +} + +{ + my ($int, $out1, $out2); + { + BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; } + $out1 = 0; + $out2 = 1; + } + test($int, 2, "#24313"); # 230 + test($out1, 17, "#24313"); # 231 + test($out2, 17, "#24313"); # 232 +} + +{ + package Numify; + use overload (qw(0+ numify fallback 1)); + + sub new { + my $val = $_[1]; + bless \$val, $_[0]; + } + + sub numify { ${$_[0]} } } +# These are all check that overloaded values rather than reference addressess +# are what is getting tested. +my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; +my ($ein, $zwei) = (1, 2); + +my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2); +foreach my $op (qw(<=> == != < <= > >=)) { + foreach my $l (keys %map) { + foreach my $r (keys %map) { + my $ocode = "\$$l $op \$$r"; + my $rcode = "$map{$l} $op $map{$r}"; + + my $got = eval $ocode; + die if $@; + my $expect = eval $rcode; + die if $@; + test ($got, $expect, $ocode) or print "# $rcode\n"; + } + } +} # Last test is: -sub last {229} +sub last {484} diff --git a/gnu/usr.bin/perl/lib/unicore/mktables b/gnu/usr.bin/perl/lib/unicore/mktables index 18f0033506c..58092f19c55 100644 --- a/gnu/usr.bin/perl/lib/unicore/mktables +++ b/gnu/usr.bin/perl/lib/unicore/mktables @@ -1023,6 +1023,7 @@ sub UnicodeData_Txt() push @PVA, "\n", "\%utf8::$name = (\n", simple_dumper (%{$utf8::{$name}}), ");\n"; } + push @PVA, "1;\n"; WriteIfChanged("PVA.pl", @PVA); } diff --git a/gnu/usr.bin/perl/lib/warnings.pm b/gnu/usr.bin/perl/lib/warnings.pm index 14ed715fdc9..862f26d27c9 100644 --- a/gnu/usr.bin/perl/lib/warnings.pm +++ b/gnu/usr.bin/perl/lib/warnings.pm @@ -396,6 +396,8 @@ sub unimport ${^WARNING_BITS} = $mask ; } +my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = (); + sub __chk { my $category ; @@ -405,10 +407,10 @@ sub __chk if (@_) { # check the category supplied. $category = shift ; - if (ref $category) { - Croaker ("not an object") - if $category !~ /^([^=]+)=/ ; - $category = $1 ; + if (my $type = ref $category) { + Croaker("not an object") + if exists $builtin_type{$type}; + $category = $type; $isobj = 1 ; } $offset = $Offsets{$category}; |