From: Ilya Zakharevich Date: Thu, 26 Dec 1996 00:31:14 +0000 (+1200) Subject: New tests: op/method.t and op/locale.t X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=92d69e20477bd17b2201cccdad79af847a7313f5;p=p5sagit%2Fp5-mst-13.2.git New tests: op/method.t and op/locale.t Signed-off-by: Ilya Zakharevich --- diff --git a/MANIFEST b/MANIFEST index 025bb2c..ea6fe73 100644 --- a/MANIFEST +++ b/MANIFEST @@ -609,6 +609,7 @@ t/lib/io_taint.t See if the untaint method from IO works t/lib/io_tell.t See if seek()/tell()-related methods from IO work t/lib/io_udp.t See if UDP socket-related methods from IO work t/lib/io_xs.t See if XSUB methods from IO work +t/lib/locale.t See if locale support (i18n and l10n) works t/lib/ndbm.t See if NDBM_File works t/lib/odbm.t See if ODBM_File works t/lib/opcode.t See if Opcode works @@ -653,6 +654,7 @@ t/op/join.t See if join works t/op/list.t See if array lists work t/op/local.t See if local works t/op/magic.t See if magic variables work +t/op/method.t See if method calls work t/op/misc.t See if miscellaneous bugs have been fixed t/op/mkdir.t See if mkdir works t/op/my.t See if lexical scoping works diff --git a/t/lib/locale.t b/t/lib/locale.t index e69de29..83fa46b 100755 --- a/t/lib/locale.t +++ b/t/lib/locale.t @@ -0,0 +1,331 @@ +#!./perl -wT + +print "1..67\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; +use POSIX qw(locale_h); + +use vars qw($a + $English $German $French $Spanish + @C @English @German @French @Spanish + $Locale @Locale %iLocale %UPPER %lower @Neoalpha); + +$a = 'abc %'; + +sub ok { + my ($n, $result) = @_; + + print 'not ' unless ($result); + print "ok $n\n"; +} + +# First we'll do a lot of taint checking for locales. +# This is the easiest to test, actually, as any locale, +# even the default locale will taint under 'use locale'. + +sub is_tainted { # hello, camel two. + my $dummy; + not eval { $dummy = join("", @_), kill 0; 1 } +} + +sub check_taint ($$) { + ok $_[0], is_tainted($_[1]); +} + +sub check_taint_not ($$) { + ok $_[0], not is_tainted($_[1]); +} + +use locale; # engage locale and therefore locale taint. + +check_taint_not 1, $a; + +check_taint 2, uc($a); +check_taint 3, "\U$a"; +check_taint 4, ucfirst($a); +check_taint 5, "\u$a"; +check_taint 6, lc($a); +check_taint 7, "\L$a"; +check_taint 8, lcfirst($a); +check_taint 9, "\l$a"; + +check_taint 10, sprintf('%e', 123.456); +check_taint 11, sprintf('%f', 123.456); +check_taint 12, sprintf('%g', 123.456); +check_taint_not 13, sprintf('%d', 123.456); +check_taint_not 14, sprintf('%x', 123.456); + +$_ = $a; # untaint $_ + +$_ = uc($a); # taint $_ + +check_taint 15, $_; + +/(\w)/; # taint $&, $`, $', $+, $1. +check_taint 16, $&; +check_taint 17, $`; +check_taint 18, $'; +check_taint 19, $+; +check_taint 20, $1; +check_taint_not 21, $2; + +/(\W)/; # taint $&, $`, $', $+, $1. +check_taint 22, $&; +check_taint 23, $`; +check_taint 24, $'; +check_taint 25, $+; +check_taint 26, $1; +check_taint_not 27, $2; + +/(\s)/; # taint $&, $`, $', $+, $1. +check_taint 28, $&; +check_taint 29, $`; +check_taint 30, $'; +check_taint 31, $+; +check_taint 32, $1; +check_taint_not 33, $2; + +/(\S)/; # taint $&, $`, $', $+, $1. +check_taint 34, $&; +check_taint 35, $`; +check_taint 36, $'; +check_taint 37, $+; +check_taint 38, $1; +check_taint_not 39, $2; + +$_ = $a; # untaint $_ + +check_taint_not 40, $_; + +/(b)/; # this must not taint +check_taint_not 41, $&; +check_taint_not 42, $`; +check_taint_not 43, $'; +check_taint_not 44, $+; +check_taint_not 45, $1; +check_taint_not 46, $2; + +$_ = $a; # untaint $_ + +check_taint_not 47, $_; + +$b = uc($a); # taint $b +s/(.+)/$b/; # this must taint only the $_ + +check_taint 48, $_; +check_taint_not 49, $&; +check_taint_not 50, $`; +check_taint_not 51, $'; +check_taint_not 52, $+; +check_taint_not 53, $1; +check_taint_not 54, $2; + +$_ = $a; # untaint $_ + +s/(.+)/b/; # this must not taint +check_taint_not 55, $_; +check_taint_not 56, $&; +check_taint_not 57, $`; +check_taint_not 58, $'; +check_taint_not 59, $+; +check_taint_not 60, $1; +check_taint_not 61, $2; + +check_taint_not 62, $a; + +# I think we've seen quite enough of taint. +# Let us do some *real* locale work now. + +sub getalnum { + sort grep /\w/, map { chr } 0..255 +} + +sub locatelocale ($$@) { + my ($lcall, $alnum, @try) = @_; + + undef $$lcall; + + for (@try) { + local $^W = 0; # suppress "Subroutine LC_ALL redefined" + if (setlocale(LC_ALL, $_)) { + $$lcall = $_; + @$alnum = &getalnum; + last; + } + } + + @$alnum = () unless (defined $$lcall); +} + +# Find some default locale + +locatelocale(\$Locale, \@Locale, qw(C POSIX)); + +# Find some English locale + +locatelocale(\$English, \@English, + qw(en_US.ISO8859-1 en_GB.ISO8859-1 + en en_US en_UK en_IE en_CA en_AU en_NZ + english english.iso88591 + american american.iso88591 + british british.iso88591 + )); + +# Find some German locale + +locatelocale(\$German, \@German, + qw(de_DE.ISO8859-1 de_AT.ISO8859-1 de_CH.ISO8859-1 + de de_DE de_AT de_CH + german german.iso88591)); + +# Find some French locale + +locatelocale(\$French, \@French, + qw(fr_FR.ISO8859-1 fr_BE.ISO8859-1 fr_CA.ISO8859-1 fr_CH.ISO8859-1 + fr fr_FR fr_BE fr_CA fr_CH + french french.iso88591)); + +# Find some Spanish locale + +locatelocale(\$Spanish, \@Spanish, + qw(es_AR.ISO8859-1 es_BO.ISO8859-1 es_CL.ISO8859-1 + es_CO.ISO8859-1 es_CR.ISO8859-1 es_EC.ISO8859-1 + es_ES.ISO8859-1 es_GT.ISO8859-1 es_MX.ISO8859-1 + es_NI.ISO8859-1 es_PA.ISO8859-1 es_PE.ISO8859-1 + es_PY.ISO8859-1 es_SV.ISO8859-1 es_UY.ISO8859-1 es_VE.ISO8859-1 + es es_AR es_BO es_CL + es_CO es_CR es_EC + es_ES es_GT es_MX + es_NI es_PA es_PE + es_PY es_SV es_UY es_VE + spanish spanish.iso88591)); + +# Select the largest of the alpha(num)bets. + +($Locale, @Locale) = ($English, @English) + if (length(@English) > length(@Locale)); +($Locale, @Locale) = ($German, @German) + if (length(@German) > length(@Locale)); +($Locale, @Locale) = ($French, @French) + if (length(@French) > length(@Locale)); +($Locale, @Locale) = ($Spanish, @Spanish) + if (length(@Spanish) > length(@Locale)); + +print "# Locale = $Locale\n"; +print "# Alnum_ = @Locale\n"; + +{ + local $^W = 0; + setlocale(LC_ALL, $Locale); +} + +{ + my $i = 0; + + for (@Locale) { + $iLocale{$_} = $i++; + } +} + +# Sieve the uppercase and the lowercase. + +for (@Locale) { + if (/[^\d_]/) { # skip digits and the _ + if (lc eq $_) { + $UPPER{$_} = uc; + } else { + $lower{$_} = lc; + } + } +} + +# Cross-check the upper and the lower. +# Yes, this is broken when the upper<->lower changes the number of +# the glyphs (e.g. the German sharp-s aka double-s aka sz-ligature. +# But so far all the implementations do this wrong so we can do it wrong too. + +for (keys %UPPER) { + if (defined $lower{$UPPER{$_}}) { + if ($_ ne $lower{$UPPER{$_}}) { + print 'not '; + last; + } + } +} +print "ok 63\n"; + +for (keys %lower) { + if (defined $UPPER{$lower{$_}}) { + if ($_ ne $UPPER{$lower{$_}}) { + print 'not '; + last; + } + } +} +print "ok 64\n"; + +# Find the alphabets that are not alphabets in the default locale. + +{ + no locale; + + for (keys %UPPER, keys %lower) { + push(@Neoalpha, $_) if (/\W/); + } +} + +@Neoalpha = sort @Neoalpha; + +# Test \w. + +{ + my $word = join('', @Neoalpha); + + $word =~ /^(\w*)$/; + + print 'not ' if ($1 ne $word); +} +print "ok 65\n"; + +# Find places where the collation order differs from the default locale. + +{ + no locale; + + my @k = sort (keys %UPPER, keys %lower); + my ($i, $j, @d); + + for ($i = 0; $i < @k; $i++) { + for ($j = $i + 1; $j < @k; $j++) { + if ($iLocale{$k[$j]} < $iLocale{$k[$i]}) { + push(@d, [$k[$j], $k[$i]]); + } + } + } + + # Cross-check those places. + + for (@d) { + ($i, $j) = @$_; + print 'not ' if ($i le $j or not (($i cmp $j) == 1)); + } +} +print "ok 66\n"; + +# Cross-check whole character set. + +for (map { chr } 0..255) { + if (/\w/ and /\W/) { print 'not '; last } + if (/\d/ and /\D/) { print 'not '; last } + if (/\s/ and /\S/) { print 'not '; last } + if (/\w/ and /\D/ and not /_/ and + not (exists $UPPER{$_} or exists $lower{$_})) { + print 'not '; last + } +} +print "ok 67\n"; diff --git a/t/op/method.t b/t/op/method.t index e69de29..7c19ecd 100755 --- a/t/op/method.t +++ b/t/op/method.t @@ -0,0 +1,100 @@ +#!./perl + +# +# test method calls and autoloading. +# + +print "1..18\n"; + +@A::ISA = 'B'; +@B::ISA = 'C'; + +sub C::d {"C::d"} +sub D::d {"D::d"} + +my $cnt = 0; +sub test { + print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1]; + # print "not " unless shift eq shift; + print "ok ", ++$cnt, "\n" +} + +test( A->d, "C::d"); # Update hash table; + +*B::d = \&D::d; # Import now. +test (A->d, "D::d"); # Update hash table; + +eval 'sub B::d {"B::d1"}'; # Import now. +test (A->d, "B::d1"); # Update hash table; + +undef &B::d; # Should work without any help too +test (A->d, "C::d"); + +eval 'sub B::d {"B::d2"}'; # Import now. +test (A->d, "B::d2"); # Update hash table; + +# What follows is hardly guarantied to work, since the names in scripts +# are already linked to "pruned" globs. Say, `undef &B::d' if it were +# after `delete $B::{d}; sub B::d {}' would reach an old subroutine. + +undef &B::d; +delete $B::{d}; +test (A->d, "C::d"); # Update hash table; + +eval 'sub B::d {"B::d3"}'; # Import now. +test (A->d, "B::d3"); # Update hash table; + +delete $B::{d}; +*dummy::dummy = sub {}; # Mark as updated +test (A->d, "C::d"); + +eval 'sub B::d {"B::d4"}'; # Import now. +test (A->d, "B::d4"); # Update hash table; + +delete $B::{d}; # Should work without any help too +test (A->d, "C::d"); + +eval <<'EOF'; +sub C::e; +sub Y::f; +$counter = 0; + +@X::ISA = 'Y'; +@Y::ISA = 'B'; + +sub B::AUTOLOAD { + my $c = ++$counter; + my $method = $B::AUTOLOAD; + *$B::AUTOLOAD = sub { "B: In $method, $c" }; + goto &$B::AUTOLOAD; +} +sub C::AUTOLOAD { + my $c = ++$counter; + my $method = $C::AUTOLOAD; + *$C::AUTOLOAD = sub { "C: In $method, $c" }; + goto &$C::AUTOLOAD; +} +EOF + +test(A->e(), "C: In C::e, 1"); # We get a correct autoload +test(A->e(), "C: In C::e, 1"); # Which sticks + +test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top +test(A->ee(), "B: In A::ee, 2"); # Which sticks + +test(Y->f(), "B: In Y::f, 3"); # We vivify a correct method +test(Y->f(), "B: In Y::f, 3"); # Which sticks + +# This test is not intended to be reasonable. It is here just to let you +# know that you broke some old construction. Feel free to rewrite the test +# if your patch breaks it. + +*B::AUTOLOAD = sub { + my $c = ++$counter; + my $method = $main::__ANON__; + *$main::__ANON__ = sub { "new B: In $method, $c" }; + goto &$main::__ANON__; +}; + +test(A->eee(), "new B: In A::eee, 4"); # We get a correct $autoload +test(A->eee(), "new B: In A::eee, 4"); # Which sticks