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]);
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 => '<HANDLE>',
readpipe => 'quoted execution (``, qx)',
reset => 'symbol reset',
ref => 'reference-type operator',
+ undef => 'undef operator',
);
sub op_desc($) {
return $op_desc{$_[0]} || $_[0];
*{"my$o"} = \&{"CORE::$o"};
my $p = prototype "CORE::$o";
+ $p = '$;$' if $p eq '$_';
if ($p eq '') {
$tests ++;
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) ";
if (!@_) { return }
- $tests += 6;
+ $tests += 3;
my($in,$out) = @_; # for testing implied $_
$_ = $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;
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;
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 {
}
}
+# 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;
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;
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 ++;
$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';
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",
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<a b>})], [qw<a b>], '&myeach(\%hash) in list cx';
+is &myeach([ "a","b" ]), 0, '&myeach(\@array) in scalar cx';
+lis [&myeach([qw<a b>])], [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';
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;
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 ++;
}
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<a b c>;
+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<a b c>;
+ 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';
{
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';
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;
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<a b c>;
+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<a b c>;
+ 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<a b c>;
+ 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<a b c d>;
+ 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<a b c d>;
+ lis [&mysplice(\@a,1,1,'e')],['b'], 'retval of 4-arg &splice in list cx';
+ lis \@a, [qw<a e c d>], '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<a b c>;
+ 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';
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.
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/),
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
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,
https://perl5.git.perl.org / perl5.git / blobdiff