X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1ed240b748e3e57ddb97e1ee9e41c543ca8362d8..e4343ef32499562ce956ba3cb9cf4454d5d2ff7f:/t/op/coreamp.t diff --git a/t/op/coreamp.t b/t/op/coreamp.t index 06464f1..4b68569 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -9,14 +9,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = qw(. ../lib); - require "test.pl"; + require "./test.pl"; require './charset_tools.pl'; $^P |= 0x100; + set_up_inc( qw(. ../lib ../dist/if) ); } -# Since tests inside evals can too easily fail silently, we cannot rely -# on done_testing. It’s much easier to count the tests as we go than to -# declare the plan up front, so this script ends with a test that makes -# sure the right number of tests have happened. + +no warnings 'experimental::smartmatch'; sub lis($$;$) { &is(map(@$_ ? "[@{[map $_//'~~u~~', @$_]}]" : 'nought', @_[0,1]), $_[2]); @@ -25,16 +23,23 @@ sub lis($$;$) { package hov { use overload '%{}' => sub { +{} } } +package aov { + use overload '@{}' => sub { [] } +} package sov { use overload '${}' => sub { \my $x } } my %op_desc = ( + evalbytes=> 'eval "string"', join => 'join or string', + pos => 'match position', + prototype=> 'subroutine prototype', readline => '', readpipe => 'quoted execution (``, qx)', reset => 'symbol reset', ref => 'reference-type operator', + undef => 'undef operator', ); sub op_desc($) { return $op_desc{$_[0]} || $_[0]; @@ -50,6 +55,7 @@ sub test_proto { *{"my$o"} = \&{"CORE::$o"}; my $p = prototype "CORE::$o"; + $p = '$;$' if $p eq '$_'; if ($p eq '') { $tests ++; @@ -58,7 +64,7 @@ sub test_proto { like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; } - elsif ($p eq '_') { + elsif ($p =~ /^_;?\z/) { $tests ++; eval " &CORE::$o(1,2) "; @@ -68,7 +74,7 @@ sub test_proto { if (!@_) { return } - $tests += 6; + $tests += 3; my($in,$out) = @_; # for testing implied $_ @@ -80,31 +86,6 @@ sub test_proto { $_ = $in; is &{"CORE::$o"}(), $out, "&$o with no args"; - - # Since there is special code to deal with lexical $_, make sure it - # works in all cases. - undef $_; - { - my $_ = $in; - is &{"CORE::$o"}(), $out, "&$o with no args uses lexical \$_"; - } - # Make sure we get the right pad under recursion - my $r; - $r = sub { - if($_[0]) { - my $_ = $in; - is &{"CORE::$o"}(), $out, - "&$o with no args uses the right lexical \$_ under recursion"; - } - else { - &$r(1) - } - }; - &$r(0); - my $_ = $in; - eval { - is "CORE::$o"->(), $out, "&$o with the right lexical \$_ in an eval" - }; } elsif ($p =~ '^;([$*]+)\z') { # ;$ ;* ;$$ etc. my $maxargs = length $1; @@ -117,10 +98,11 @@ sub test_proto { elsif ($p =~ '^([$*]+);?\z') { # Fixed-length $$$ or *** my $args = length $1; $tests += 2; + my $desc = quotemeta op_desc($o); eval " &CORE::$o((1)x($args-1)) "; - like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; + like $@, qr/^Not enough arguments for $desc at /, "&$o w/too few args"; eval " &CORE::$o((1)x($args+1)) "; - like $@, qr/^Too many arguments for $o at /, "&$o with too many args"; + like $@, qr/^Too many arguments for $desc at /, "&$o w/too many args"; } elsif ($p =~ '^([$*]+);([$*]+)\z') { # Variable-length $$$ or *** my $minargs = length $1; @@ -188,29 +170,126 @@ sub test_proto { like $@, qr/^Type of arg 1 to &CORE::$o must be hash reference at /, "&$o with non-hash arg with hash overload (which does not count)"; } - elsif ($p eq '\[$@%&*]') { - $tests += 5; + elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) { + $tests += 3; - eval " &CORE::$o(1,2) "; - like $@, qr/^Too many arguments for $o at /, - "&$o with too many args"; - eval " &CORE::$o() "; + unless ($3) { + $tests ++; + eval " &CORE::$o(1,2) "; + like $@, qr/^Too many arguments for ${\op_desc($o)} at /, + "&$o with too many args"; + } + unless ($1) { + $tests ++; + eval { &{"CORE::$o"}($3 ? 1 : ()) }; + like $@, qr/^Not enough arguments for $o at /, + "&$o with too few args"; + } + my $more_args = $3 ? ',1' : ''; + eval " &CORE::$o(2$more_args) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: + ) \[\Q$2\E\] at /, + "&$o with non-ref arg"; + eval " &CORE::$o(*STDOUT{IO}$more_args) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: + ) \[\Q$2\E\] at /, + "&$o with ioref arg"; + my $class = ref *DATA{IO}; + eval " &CORE::$o(bless(*DATA{IO}, 'hov')$more_args) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: + ) \[\Q$2\E\] at /, + "&$o with ioref arg with hash overload (which does not count)"; + bless *DATA{IO}, $class; + if (do {$2 !~ /&/}) { + $tests++; + eval " &CORE::$o(\\&scriggle$more_args) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one (?x: + )of \[\Q$2\E\] at /, + "&$o with coderef arg"; + } + } + elsif ($p =~ /^;?\\\@([\@;])?/) { # ;\@ \@@ \@;$$@ + $tests += 7; + + if ($1) { + eval { &{"CORE::$o"}() }; + like $@, qr/^Not enough arguments for $o at /, + "&$o with too few args"; + } + else { + eval " &CORE::$o(\\\@1,2) "; + like $@, qr/^Too many arguments for $o at /, + "&$o with too many args"; + } + eval " &CORE::$o(2) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, + "&$o with non-ref arg"; + eval " &CORE::$o(*STDOUT{IO}) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, + "&$o with ioref arg"; + my $class = ref *DATA{IO}; + eval " &CORE::$o(bless(*DATA{IO}, 'aov')) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, + "&$o with ioref arg with array overload (which does not count)"; + bless *DATA{IO}, $class; + eval " &CORE::$o(\\&scriggle) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, + "&$o with coderef arg"; + eval " &CORE::$o(\\\$_) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, + "&$o with scalarref arg"; + eval " &CORE::$o({}) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be array reference at /, + "&$o with hashref arg"; + } + elsif ($p eq '\[%@]') { + $tests += 7; + + eval " &CORE::$o(\\%1,2) "; + like $@, qr/^Too many arguments for ${\op_desc($o)} at /, + "&$o with too many args"; + eval { &{"CORE::$o"}() }; like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; eval " &CORE::$o(2) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: - ) \[\$\@%&\*] at /, + like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: + )reference at /, "&$o with non-ref arg"; eval " &CORE::$o(*STDOUT{IO}) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: - ) \[\$\@%&\*] at /, + like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: + )reference at /, "&$o with ioref arg"; my $class = ref *DATA{IO}; eval " &CORE::$o(bless(*DATA{IO}, 'hov')) "; - like $@, qr/^Type of arg 1 to &CORE::$o must be reference to one of(?x: - ) \[\$\@%&\*] at /, + like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: + )reference at /, "&$o with ioref arg with hash overload (which does not count)"; bless *DATA{IO}, $class; + eval " &CORE::$o(\\&scriggle) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: + )reference at /, + "&$o with coderef arg"; + eval " &CORE::$o(\\\$_) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be hash or array (?x: + )reference at /, + "&$o with scalarref arg"; + } + elsif ($p eq ';\[$*]') { + $tests += 4; + + my $desc = quotemeta op_desc($o); + eval " &CORE::$o(1,2) "; + like $@, qr/^Too many arguments for $desc at /, + "&$o with too many args"; + eval " &CORE::$o([]) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, + "&$o with array ref arg"; + eval " &CORE::$o(1) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, + "&$o with scalar arg"; + eval " &CORE::$o(bless([], 'sov')) "; + like $@, qr/^Type of arg 1 to &CORE::$o must be scalar reference at /, + "&$o with non-scalar arg w/scalar overload (which does not count)"; } else { @@ -218,42 +297,65 @@ sub test_proto { } } +# Test that &CORE::foo calls without parentheses (no new @_) can handle the +# total absence of any @_ without crashing. +undef *_; +&CORE::wantarray; +$tests++; +pass('no crash with &CORE::foo when *_{ARRAY} is undef'); + test_proto '__FILE__'; test_proto '__LINE__'; test_proto '__PACKAGE__'; +test_proto '__SUB__'; is file(), 'frob' , '__FILE__ does check its caller' ; ++ $tests; is line(), 5 , '__LINE__ does check its caller' ; ++ $tests; is pakg(), 'stribble', '__PACKAGE__ does check its caller'; ++ $tests; +sub __SUB__test { &my__SUB__ } +is __SUB__test, \&__SUB__test, '&__SUB__'; ++ $tests; test_proto 'abs', -5, 5; -test_proto 'accept'; -$tests += 6; eval q{ - is &CORE::accept(qw{foo bar}), undef, "&accept"; - lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context"; - - &myaccept(my $foo, my $bar); - is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument'; - is $bar, undef, 'CORE::accept does not autovivify its second argument'; - use strict; - undef $foo; - eval { 'myaccept'->($foo, $bar) }; - like $@, qr/^Can't use an undefined value as a symbol reference at/, +SKIP: +{ + if ($^O eq "MSWin32" && is_miniperl) { + $tests += 8; + skip "accept() not available in Win32 miniperl", 8 + } + $tests += 6; + test_proto 'accept'; + eval q{ + is &CORE::accept(qw{foo bar}), undef, "&accept"; + lis [&{"CORE::accept"}(qw{foo bar})], [undef], "&accept in list context"; + + &myaccept(my $foo, my $bar); + is ref $foo, 'GLOB', 'CORE::accept autovivifies its first argument'; + is $bar, undef, 'CORE::accept does not autovivify its second argument'; + use strict; + undef $foo; + eval { 'myaccept'->($foo, $bar) }; + like $@, qr/^Can't use an undefined value as a symbol reference at/, 'CORE::accept will not accept undef 2nd arg under strict'; - is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict'; -}; + is ref $foo, 'GLOB', 'CORE::accept autovivs its first arg under strict'; + }; +} test_proto 'alarm'; test_proto 'atan2'; test_proto 'bind'; $tests += 3; -is &CORE::bind('foo', 'bear'), undef, "&bind"; -lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context"; -eval { &mybind(my $foo, "bear") }; -like $@, qr/^Bad symbol for filehandle at/, - 'CORE::bind dies with undef first arg'; +SKIP: +{ + skip "bind() not available in Win32 miniperl", 3 + if $^O eq "MSWin32" && is_miniperl(); + is &CORE::bind('foo', 'bear'), undef, "&bind"; + lis [&CORE::bind('foo', 'bear')], [undef], "&bind in list context"; + eval { &mybind(my $foo, "bear") }; + like $@, qr/^Bad symbol for filehandle at/, + 'CORE::bind dies with undef first arg'; +} test_proto 'binmode'; $tests += 3; @@ -286,7 +388,15 @@ sub caller_test { is scalar &CORE::caller, 'hadhad', '&caller'; is scalar &CORE::caller(1), 'main', '&caller(1)'; lis [&CORE::caller], [caller], '&caller in list context'; - lis [&CORE::caller(1)], [caller(1)], '&caller(1) in list context'; + # The last element of caller in list context is a hint hash, which + # may be a different hash for caller vs &CORE::caller, so an eq com- + # parison (which lis() uses for convenience) won’t work. So just + # pop the last element, since the rest are sufficient to prove that + # &CORE::caller works. + my @ampcaller = &CORE::caller(1); + my @caller = caller(1); + pop @ampcaller; pop @caller; + lis \@ampcaller, \@caller, '&caller(1) in list context'; } sub { package hadhad; @@ -341,8 +451,13 @@ lis [&CORE::closedir(foo)], [undef], '&CORE::closedir in list context'; test_proto 'connect'; $tests += 2; -is &CORE::connect('foo','bar'), undef, '&connect'; -lis [&myconnect('foo','bar')], [undef], '&connect in list context'; +SKIP: +{ + skip "connect() not available in Win32 miniperl", 2 + if $^O eq "MSWin32" && is_miniperl(); + is &CORE::connect('foo','bar'), undef, '&connect'; + lis [&myconnect('foo','bar')], [undef], '&connect in list context'; +} test_proto 'continue'; $tests ++; @@ -366,6 +481,15 @@ test_proto 'dbmopen'; $db{1} = 2; $db{3} = 4; &mydbmclose(\%db); is scalar keys %db, 0, '&dbmopen and &dbmclose'; + my $Dfile = "$filename.pag"; + if (! -e $Dfile) { + ($Dfile) = <$filename*>; + } + if ($^O eq 'VMS') { + unlink "$filename.sdbm_dir", $Dfile; + } else { + unlink "$filename.dir", $Dfile; + } } test_proto 'die'; @@ -376,6 +500,30 @@ test_proto $_ for qw( endgrent endhostent endnetent endprotoent endpwent endservent ); +test_proto 'evalbytes'; +$tests += 4; +{ + my $U_100_bytes = byte_utf8a_to_utf8n("\xc4\x80"); + chop(my $upgraded = "use utf8; $U_100_bytes" . chr 256); + is &myevalbytes($upgraded), chr 256, '&evalbytes'; + # Test hints + require strict; + strict->import; + &myevalbytes(' + is someone, "someone", "run-time hint bits do not leak into &evalbytes" + '); + use strict; + BEGIN { $^H{coreamp} = 42 } + $^H{coreamp} = 75; + &myevalbytes(' + BEGIN { + is $^H{coreamp}, 42, "compile-time hh propagates into &evalbytes"; + } + ${"frobnicate"} + '); + like $@, qr/strict/, 'compile-time hint bits propagate into &evalbytes'; +} + test_proto 'exit'; $tests ++; is runperl(prog => '&CORE::exit; END { print qq-ok\n- }'), "ok\n", @@ -389,7 +537,24 @@ is &myformline(' @<<< @>>>', 1, 2), 1, '&myformline retval'; is $^A, ' 1 2', 'effect of &myformline'; lis [&myformline('@')], [1], '&myformline in list context'; +test_proto 'each'; +$tests += 4; +is &myeach({ "a","b" }), "a", '&myeach(\%hash) in scalar cx'; +lis [&myeach({qw})], [qw], '&myeach(\%hash) in list cx'; +is &myeach([ "a","b" ]), 0, '&myeach(\@array) in scalar cx'; +lis [&myeach([qw])], [qw<0 a>], '&myeach(\@array) in list cx'; + test_proto 'exp'; + +test_proto 'fc'; +$tests += 2; +{ + my $sharp_s = uni_to_native("\xdf"); + is &myfc($sharp_s), $sharp_s, '&fc, no unicode_strings'; + use feature 'unicode_strings'; + is &myfc($sharp_s), "ss", '&fc, unicode_strings'; +} + test_proto 'fcntl'; test_proto 'fileno'; @@ -426,6 +591,20 @@ test_proto "get$_" for qw ' pwent pwnam pwuid servbyname servbyport servent sockname sockopt '; +# Make sure the following tests test what we think they are testing. +ok ! $CORE::{glob}, '*CORE::glob not autovivified yet'; $tests ++; +{ + # Make sure ck_glob does not respect the override when &CORE::glob is + # autovivified (by test_proto). + local *CORE::GLOBAL::glob = sub {}; + test_proto 'glob'; +} +$_ = "t/*.t"; +@_ = &myglob($_); +is join($", &myglob()), "@_", '&glob without arguments'; +is join($", &myglob("t/*.t")), "@_", '&glob with an arg'; +$tests += 2; + test_proto 'gmtime'; &CORE::gmtime; pass '&gmtime without args does not crash'; ++$tests; @@ -446,6 +625,25 @@ $tests += 2; is &myjoin('a','b','c'), 'bac', '&join'; lis [&myjoin('a','b','c')], ['bac'], '&join in list context'; +test_proto 'keys'; +$tests += 6; +is &mykeys({ 1..4 }), 2, '&mykeys(\%hash) in scalar cx'; +lis [sort &mykeys({1..4})], [1,3], '&mykeys(\%hash) in list cx'; +is &mykeys([ 1..4 ]), 4, '&mykeys(\@array) in scalar cx'; +lis [&mykeys([ 1..4 ])], [0..3], '&mykeys(\@array) in list cx'; + +SKIP: { + skip "no Hash::Util on miniperl", 2, if is_miniperl; + require Hash::Util; + sub Hash::Util::bucket_ratio (\%); + + my %h = 1..2; + &mykeys(\%h) = 1024; + like Hash::Util::bucket_ratio(%h), qr|/1024\z|, '&mykeys = changed number of buckets allocated'; + eval { (&mykeys(\%h)) = 1025; }; + like $@, qr/^Can't modify keys in list assignment at /; +} + test_proto 'kill'; # set up mykill alias if ($^O ne 'riscos') { $tests ++; @@ -502,21 +700,71 @@ close file; } test_proto 'opendir'; -test_proto 'ord', chr(64), 64; +test_proto 'ord', chr(utf8::unicode_to_native(64)), utf8::unicode_to_native(64); test_proto 'pack'; $tests += 2; -is &mypack("H*", '5065726c'), 'Perl', '&pack'; -lis [&mypack("H*", '5065726c')], ['Perl'], '&pack in list context'; +my $Perl_as_a_hex_string = join "", map + { sprintf("%2X", utf8::unicode_to_native($_)) } + 0x50, 0x65, 0x72, 0x6c; +is &mypack("H*", $Perl_as_a_hex_string), 'Perl', '&pack'; +lis [&mypack("H*", $Perl_as_a_hex_string)], ['Perl'], '&pack in list context'; test_proto 'pipe'; + +test_proto 'pop'; +$tests += 6; +@ARGV = qw; +is &mypop(), 'c', 'retval of &pop with no args (@ARGV)'; +is "@ARGV", "a b", 'effect of &pop on @ARGV'; +sub { + is &mypop(), 'k', 'retval of &pop with no args (@_)'; + is "@_", "q j", 'effect of &pop on @_'; +}->(qw(q j k)); +{ + my @a = 1..4; + is &mypop(\@a), 4, 'retval of &pop'; + lis [@a], [1..3], 'effect of &pop'; +} + +test_proto 'pos'; +$tests += 4; +$_ = "hello"; +pos = 3; +is &mypos, 3, 'reading &pos without args'; +&mypos = 4; +is pos, 4, 'writing to &pos without args'; +{ + my $x = "gubai"; + pos $x = 3; + is &mypos(\$x), 3, 'reading &pos without args'; + &mypos(\$x) = 4; + is pos $x, 4, 'writing to &pos without args'; +} + +test_proto 'prototype'; +$tests++; +is &myprototype(\&myprototype), prototype("CORE::prototype"), '&prototype'; + +test_proto 'push'; +$tests += 2; +{ + my @a = qw; + is &mypush(\@a, "d", "e"), 5, 'retval of &push'; + is "@a", "a b c d e", 'effect of &push'; +} + test_proto 'quotemeta', '$', '\$'; test_proto 'rand'; $tests += 3; -like &CORE::rand, qr/^0[.\d]*\z/, '&rand'; +my $r = &CORE::rand; +ok eval { + use warnings FATAL => qw{numeric uninitialized}; + $r >= 0 && $r < 1; +}, '&rand returns a valid number'; unlike join(" ", &CORE::rand), qr/ /, '&rand in list context'; -&cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 2 args'); +&cmp_ok(&CORE::rand(78), qw '< 78', '&rand with 1 arg'); test_proto 'read'; { @@ -583,12 +831,12 @@ $tests += 2; my $oncer = sub { "a" =~ m?a? }; &$oncer; &myreset; -ok &$oncer, '&reset with one arg'; +ok &$oncer, '&reset with no args'; package resettest { $b = "c"; $banana = "cream"; &::myreset('b'); - ::lis [$b,$banana],[(undef)x2], '2-arg &reset'; + ::lis [$b,$banana],[(undef)x2], '1-arg &reset'; } test_proto 'reverse'; @@ -607,6 +855,11 @@ is &myrindex("foffooo","o"),6,'&rindex with 2 args'; test_proto 'rmdir'; +test_proto 'scalar'; +$tests += 2; +is &myscalar(3), 3, '&scalar'; +lis [&myscalar(3)], [3], '&scalar in list cx'; + test_proto 'seek'; { last if is_miniperl; @@ -640,55 +893,221 @@ like $@, qr/^Not enough arguments for select system call at /, eval { &myselect(1,2,3,4,5) }; like $@, qr/^Too many arguments for select system call at /, ,'&myselect($a,$total,$of,$five,$args)'; -&myselect((undef)x3,.25); -# Just have to assume that worked. :-) If we get here, at least it didn’t -# crash or anything. +unless ($^O eq "MSWin32" && is_miniperl) { + &myselect((undef)x3,.25); + # Just have to assume that worked. :-) If we get here, at least it didn’t + # crash or anything. + # select() is unimplemented in Win32 miniperl +} test_proto "sem$_" for qw "ctl get op"; test_proto 'send'; test_proto "set$_" for qw ' - grent hostent netent priority protoent pwent servent sockopt + grent hostent netent +'; + +test_proto 'setpgrp'; +$tests +=2; +eval { &mysetpgrp( 0) }; +pass "&setpgrp with one argument"; +eval { &mysetpgrp }; +pass "&setpgrp with no arguments"; + +test_proto "set$_" for qw ' + priority protoent pwent servent sockopt '; +test_proto 'shift'; +$tests += 6; +@ARGV = qw; +is &myshift(), 'a', 'retval of &shift with no args (@ARGV)'; +is "@ARGV", "b c", 'effect of &shift on @ARGV'; +sub { + is &myshift(), 'q', 'retval of &shift with no args (@_)'; + is "@_", "j k", 'effect of &shift on @_'; +}->(qw(q j k)); +{ + my @a = 1..4; + is &myshift(\@a), 1, 'retval of &shift'; + lis [@a], [2..4], 'effect of &shift'; +} + test_proto "shm$_" for qw "ctl get read write"; test_proto 'shutdown'; test_proto 'sin'; +test_proto 'sleep'; test_proto "socket$_" for "", "pair"; +test_proto 'splice'; +$tests += 8; +{ + my @a = qw; + is &mysplice(\@a, 1), 'c', 'retval of 2-arg &splice in scalar context'; + lis \@a, ['a'], 'effect of 2-arg &splice in scalar context'; + @a = qw; + lis [&mysplice(\@a, 1)], ['b','c'], 'retval of 2-arg &splice in list cx'; + lis \@a, ['a'], 'effect of 2-arg &splice in list context'; + @a = qw; + lis [&mysplice(\@a,1,2)],['b','c'], 'retval of 3-arg &splice in list cx'; + lis \@a, ['a','d'], 'effect of 3-arg &splice in list context'; + @a = qw; + lis [&mysplice(\@a,1,1,'e')],['b'], 'retval of 4-arg &splice in list cx'; + lis \@a, [qw], 'effect of 4-arg &splice in list context'; +} + test_proto 'sprintf'; $tests += 2; is &mysprintf("%x", 65), '41', '&sprintf'; lis [&mysprintf("%x", '65')], ['41'], '&sprintf in list context'; test_proto 'sqrt', 4, 2; + +test_proto 'srand'; +$tests ++; +&CORE::srand; +() = &CORE::srand; +pass '&srand with no args does not crash'; + +test_proto 'study'; + +test_proto 'substr'; +$tests += 5; +$_ = "abc"; +is &mysubstr($_, 1, 1, "d"), 'b', '4-arg &substr'; +is $_, 'adc', 'what 4-arg &substr does'; +is &mysubstr("abc", 1, 1), 'b', '3-arg &substr'; +is &mysubstr("abc", 1), 'bc', '2-arg &substr'; +&mysubstr($_, 1) = 'long'; +is $_, 'along', 'lvalue &substr'; + test_proto 'symlink'; test_proto 'syscall'; + +test_proto 'sysopen'; +$tests +=2; +{ + &mysysopen(my $fh, 'test.pl', 0); + pass '&sysopen does not crash with 3 args'; + ok $fh, 'sysopen autovivifies'; +} + test_proto 'sysread'; test_proto 'sysseek'; test_proto 'syswrite'; + +test_proto 'tell'; +{ + $tests += 2; + open my $fh, "test.pl" or die "Cannot open test.pl"; + <$fh>; + is &mytell(), tell($fh), '&tell with no args'; + is &mytell($fh), tell($fh), '&tell with an arg'; +} + test_proto 'telldir'; +test_proto 'tie'; +test_proto 'tied'; +$tests += 3; +{ + my $fetches; + package tier { + sub TIESCALAR { bless[] } + sub FETCH { ++$fetches } + } + my $tied; + my $obj = &mytie(\$tied, 'tier'); + is &mytied(\$tied), $obj, '&tie and &tied retvals'; + () = "$tied"; + is $fetches, 1, '&tie actually ties'; + &CORE::untie(\$tied); + () = "$tied"; + is $fetches, 1, '&untie unties'; +} + test_proto 'time'; $tests += 2; -like &mytime, '^\d+\z', '&time in scalar context'; -like join('-', &mytime), '^\d+\z', '&time in list context'; +like &mytime, qr/^\d+\z/, '&time in scalar context'; +like join('-', &mytime), qr/^\d+\z/, '&time in list context'; test_proto 'times'; $tests += 2; -like &mytimes, '^[\d.]+\z', '× in scalar context'; -like join('-',&mytimes), '^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z', +like &mytimes, qr/^[\d.]+\z/, '× in scalar context'; +like join('-',&mytimes), qr/^[\d.]+-[\d.]+-[\d.]+-[\d.]+\z/, '× in list context'; test_proto 'uc', 'aa', 'AA'; test_proto 'ucfirst', 'aa', "Aa"; +test_proto 'umask'; +$tests ++; +is &myumask, umask, '&umask with no args'; + +test_proto 'undef'; +$tests += 12; +is &myundef(), undef, '&undef returns undef'; +lis [&myundef()], [undef], '&undef returns undef in list cx'; +lis [&myundef(\$_)], [undef], '&undef(...) returns undef in list cx'; +is \&myundef(), \undef, '&undef returns the right undef'; +$_ = 'anserine questions'; +&myundef(\$_); +is $_, undef, '&undef(\$_) undefines $_'; +@_ = 1..3; +&myundef(\@_); +is @_, 0, '&undef(\@_) undefines @_'; +%_ = 1..4; +&myundef(\%_); +ok !%_, '&undef(\%_) undefines %_'; +&myundef(\&utf8::valid); # nobody should be using this :-) +ok !defined &utf8::valid, '&undef(\&foo) undefines &foo'; +@_ = \*_; +&myundef; +is *_{ARRAY}, undef, '@_=\*_, &undef undefines *_'; +@_ = \*_; +&myundef(\*_); +is *_{ARRAY}, undef, '&undef(\*_) undefines *_'; +(&myundef(), @_) = 1..10; +lis \@_, [2..10], 'list assignment to &undef()'; +ok !defined undef, 'list assignment to &undef() does not affect undef'; +undef @_; + +test_proto 'unpack'; +$tests += 2; +my $abcd_as_a_hex_string = join "", map + { sprintf("%2X", utf8::unicode_to_native($_)) } + 0x61, 0x62, 0x63, 0x64; +my $bcde_as_a_hex_string = join "", map + { sprintf("%2X", utf8::unicode_to_native($_)) } + 0x62, 0x63, 0x64, 0x65; +$_ = 'abcd'; +is &myunpack("H*"), $abcd_as_a_hex_string, '&unpack with one arg'; +is &myunpack("H*", "bcde"), $bcde_as_a_hex_string, '&unpack with two arg'; + + +test_proto 'unshift'; +$tests += 2; +{ + my @a = qw; + is &myunshift(\@a, "d", "e"), 5, 'retval of &unshift'; + is "@a", "d e a b c", 'effect of &unshift'; +} + +test_proto 'untie'; # behaviour already tested along with tie(d) + test_proto 'utime'; $tests += 2; is &myutime(undef,undef), 0, '&utime'; lis [&myutime(undef,undef)], [0], '&utime in list context'; +test_proto 'values'; +$tests += 4; +is &myvalues({ 1..4 }), 2, '&myvalues(\%hash) in scalar cx'; +lis [sort &myvalues({1..4})], [2,4], '&myvalues(\%hash) in list cx'; +is &myvalues([ 1..4 ]), 4, '&myvalues(\@array) in scalar cx'; +lis [&myvalues([ 1..4 ])], [1..4], '&myvalues(\@array) in list cx'; + test_proto 'vec'; $tests += 3; is &myvec("foo", 0, 4), 6, '&vec'; @@ -723,6 +1142,12 @@ test_proto 'warn'; lis [&mywarn()], [1], '&warn retval in list context'; } +test_proto 'write'; +$tests ++; +eval {&mywrite}; +like $@, qr'^Undefined format "STDOUT" called', + "&write without arguments can handle the null"; + # This is just a check to make sure we have tested everything. If we # haven’t, then either the sub needs to be tested or the list in # gv.c is wrong. @@ -736,10 +1161,17 @@ test_proto 'warn'; open my $kh, $keywords_file or die "$0 cannot open $keywords_file: $!"; while(<$kh>) { - if (m?__END__?..${\0} and /^[-](.*)/) { + if (m?__END__?..${\0} and /^[-+](.*)/) { my $word = $1; next if - $word =~ /^(?:CORE|and|cmp|dump|eq|ge|gt|le|lt|ne|or|x|xor)\z/; + $word =~ /^(?:s(?:tate|ort|ay|ub)?|d(?:ef + ault|ump|o)|p(?:rintf?|ackag + e)|e(?:ls(?:if|e)|val|q)|g(?:[et]|iven|oto + |rep)|u(?:n(?:less|til)|se)|l(?:(?:as)?t|ocal|e)|re + (?:quire|turn|do)|__(?:DATA|END)__|for(?:each|mat)?|(?: + AUTOLOA|EN)D|n(?:e(?:xt)?|o)|C(?:HECK|ORE)|wh(?:ile|en) + |(?:ou?|t)r|m(?:ap|y)?|UNITCHECK|q[qrwx]?|x(?:or)?|DEST + ROY|BEGIN|INIT|and|cmp|if|y)\z/x; $tests ++; ok exists &{"my$word"} || (eval{&{"CORE::$word"}}, $@ =~ /cannot be called directly/), @@ -756,21 +1188,29 @@ test_proto 'warn'; last if is_miniperl; require Cwd; import Cwd; - $tests += 2; + $tests += 3; require File::Temp ; my $dir = File::Temp::tempdir(uc cleanup => 1); my $cwd = cwd(); chdir($dir); - my $_ = 'Phoo'; + + # Make sure that implicit $_ is not applied to mkdir’s second argument. + local $^W = 1; + my $warnings; + local $SIG{__WARN__} = sub { ++$warnings }; + + local $_ = 'Phoo'; ok &mymkdir(), '&mkdir'; like <*>, qr/^phoo(.DIR)?\z/i, 'mkdir works with implicit $_'; + + is $warnings, undef, 'no implicit $_ for second argument to mkdir'; + chdir($cwd); # so auto-cleanup can remove $dir } # ------------ END TESTING ----------- # -is curr_test, $tests+1, 'right number of tests'; -done_testing; +done_testing $tests; #line 3 frob @@ -784,7 +1224,7 @@ sub main::pakg { &CORE::__PACKAGE__ } package main; CORE::__DATA__ I wandered lonely as a cloud -That floats on high o’er vales and hills, +That floats on high o'er vales and hills, And all at once I saw a crowd, A host of golden daffodils! Beside the lake, beneath the trees,