From 46bef06f0f3d8f94283e79e8c77eb5bf23d08fc3 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sat, 12 May 2012 19:05:24 -0700 Subject: [PATCH] Add &CORE::undef MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit In the error message, we can’t say ‘&CORE::undef operator’, so we should be using the op name, rather than the op description. Instead of using OP_NAME(PL_op->op_next), which would expand to PL_op->op_next->op_type == OP_CUSTOM ? XopENTRY(Perl_custom_op_xop(aTHX_ PL_op->op_next), xop_name) : PL_op_name[PL_op->op_next->op_type] we can simply use PL_op_name[opnum], which should be quicker. pp_undef can already handle nulls on the stack. There is one remaining problem. If &CORE::undef(\*_) is called, *_ will be undefined while @_ is localised during the sub call, so it won’t have the same effect as undef *_. I don’t know whether this should be considered a bug or not, but I could solve it by making pp_undef an XSUB. --- gv.c | 2 +- pp.c | 7 ++++--- t/op/coreamp.t | 55 ++++++++++++++++++++++++++++++++++++++++++------------- t/op/coresubs.t | 2 +- 4 files changed, 48 insertions(+), 18 deletions(-) diff --git a/gv.c b/gv.c index acf7f9b..ab2aef1 100644 --- a/gv.c +++ b/gv.c @@ -471,7 +471,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv, case KEY_qx : case KEY_redo : case KEY_require: case KEY_return: case KEY_s : case KEY_say : case KEY_sort : case KEY_state: case KEY_sub : - case KEY_tr : case KEY_undef: case KEY_UNITCHECK: case KEY_unless: + case KEY_tr : case KEY_UNITCHECK: case KEY_unless: case KEY_until: case KEY_use : case KEY_when : case KEY_while : case KEY_x : case KEY_xor : case KEY_y : return NULL; diff --git a/pp.c b/pp.c index c89b083..0d4dfc4 100644 --- a/pp.c +++ b/pp.c @@ -5992,17 +5992,18 @@ PP(pp_coreargs) type permits the latter. */ || SvTYPE(SvRV(*svp)) > ( wantscalar ? SVt_PVLV - : opnum == OP_LOCK ? SVt_PVCV + : opnum == OP_LOCK || opnum == OP_UNDEF + ? SVt_PVCV : SVt_PVHV ) ) DIE(aTHX_ /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/ "Type of arg %d to &CORE::%s must be %s", - whicharg, OP_DESC(PL_op->op_next), + whicharg, PL_op_name[opnum], wantscalar ? "scalar reference" - : opnum == OP_LOCK + : opnum == OP_LOCK || opnum == OP_UNDEF ? "reference to one of [$@%&*]" : "reference to one of [$@%*]" ); diff --git a/t/op/coreamp.t b/t/op/coreamp.t index 0a17b17..0ac5796 100644 --- a/t/op/coreamp.t +++ b/t/op/coreamp.t @@ -34,6 +34,7 @@ my %op_desc = ( readpipe => 'quoted execution (``, qx)', reset => 'symbol reset', ref => 'reference-type operator', + undef => 'undef operator', ); sub op_desc($) { return $op_desc{$_[0]} || $_[0]; @@ -189,38 +190,41 @@ 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 =~ /^\\\[(\$\@%&?\*)](\$\@)?\z/) { - $tests += 4; + elsif ($p =~ /^(;)?\\\[(\$\@%&?\*)](\$\@)?\z/) { + $tests += 3; - unless ($2) { + unless ($3) { $tests ++; eval " &CORE::$o(1,2) "; - like $@, qr/^Too many arguments for $o at /, + like $@, qr/^Too many arguments for ${\op_desc($o)} at /, "&$o with too many args"; } - eval { &{"CORE::$o"}($2 ? 1 : ()) }; - like $@, qr/^Not enough arguments for $o at /, + unless ($1) { + $tests ++; + eval { &{"CORE::$o"}($3 ? 1 : ()) }; + like $@, qr/^Not enough arguments for $o at /, "&$o with too few args"; - my $more_args = $2 ? ',1' : ''; + } + 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$1\E] at /, + ) \[\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$1\E] at /, + ) \[\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$1\E] at /, + ) \[\Q$2\E] at /, "&$o with ioref arg with hash overload (which does not count)"; bless *DATA{IO}, $class; - if (do {$1 !~ /&/}) { + 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$1\E] at /, + )of \[\Q$2\E] at /, "&$o with coderef arg"; } } @@ -875,6 +879,31 @@ test_proto 'umask'; $tests ++; is &myumask, umask, '&umask with no args'; +test_proto 'undef'; +$tests += 11; +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()}, @_) = 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; $_ = 'abcd'; @@ -948,7 +977,7 @@ like $@, qr'^Undefined format "STDOUT" called', $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|def|til)|se)|l(?:(?:as)?t|ocal|e)|re + |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 diff --git a/t/op/coresubs.t b/t/op/coresubs.t index 60db0fc..1909c03 100644 --- a/t/op/coresubs.t +++ b/t/op/coresubs.t @@ -20,7 +20,7 @@ my %unsupported = map +($_=>1), qw ( cmp default do dump else elsif eq eval for foreach format ge given goto grep gt if last le local lt m map my ne next no or our package print printf q qq qr qw qx redo require - return s say sort state sub tr undef unless until use + return s say sort state sub tr unless until use when while x xor y ); my %args_for = ( -- 2.7.4