summaryrefslogtreecommitdiff
path: root/gnu/usr.bin/perl/lib
diff options
context:
space:
mode:
authorTodd C. Miller <millert@cvs.openbsd.org>2005-01-15 21:18:29 +0000
committerTodd C. Miller <millert@cvs.openbsd.org>2005-01-15 21:18:29 +0000
commit900aea5fee6e7e0e7e6e8c4f0192f99befa3a927 (patch)
tree79ecffc72620d46df9fe0d71286e0e466415b7f5 /gnu/usr.bin/perl/lib
parenta529bb51c131f3975e0a7daa8eb3d2c865f3fc52 (diff)
perl 5.8.6 from CPAN
Diffstat (limited to 'gnu/usr.bin/perl/lib')
-rw-r--r--gnu/usr.bin/perl/lib/Carp.t140
-rw-r--r--gnu/usr.bin/perl/lib/Config.t107
-rw-r--r--gnu/usr.bin/perl/lib/Dumpvalue.t5
-rwxr-xr-xgnu/usr.bin/perl/lib/I18N/LangTags/t/20_locales.t38
-rw-r--r--gnu/usr.bin/perl/lib/open.pm141
-rw-r--r--gnu/usr.bin/perl/lib/open.t15
-rw-r--r--gnu/usr.bin/perl/lib/overload.t69
-rw-r--r--gnu/usr.bin/perl/lib/unicore/mktables1
-rw-r--r--gnu/usr.bin/perl/lib/warnings.pm10
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};