From: Gurusamy Sarathy Date: Fri, 21 Jan 2000 01:45:51 +0000 (+0000) Subject: support for C (from Spider Boardman) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=afebc493229293927e6b724b2070ac810a813a28;p=p5sagit%2Fp5-mst-13.2.git support for C (from Spider Boardman) p4raw-id: //depot/perl@4827 --- diff --git a/MANIFEST b/MANIFEST index f6e96a7..0e6282f 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1311,6 +1311,7 @@ t/op/do.t See if subroutines work t/op/each.t See if hash iterators work t/op/eval.t See if eval operator works t/op/exec.t See if exec and system work +t/op/exists_sub.t See if exists(&sub) works t/op/exp.t See if math functions work t/op/fh.t See if filehandles work t/op/filetest.t See if file tests work diff --git a/op.c b/op.c index 4baf03b..386e9de 100644 --- a/op.c +++ b/op.c @@ -1691,7 +1691,7 @@ Perl_ref(pTHX_ OP *o, I32 type) switch (o->op_type) { case OP_ENTERSUB: - if ((type == OP_DEFINED || type == OP_LOCK) && + if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; @@ -5033,7 +5033,14 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type == OP_AELEM) + if (kid->op_type == OP_ENTERSUB) { + (void) ref(kid, o->op_type); + if (kid->op_type != OP_RV2CV && !PL_error_count) + Perl_croak(aTHX_ "%s argument is not a subroutine name", + PL_op_desc[o->op_type]); + o->op_private |= OPpEXISTS_SUB; + } + else if (kid->op_type == OP_AELEM) o->op_flags |= OPf_SPECIAL; else if (kid->op_type != OP_HELEM) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", diff --git a/op.h b/op.h index c69d897..ae37f03 100644 --- a/op.h +++ b/op.h @@ -77,6 +77,7 @@ typedef U32 PADOFFSET; /* On flipflop, we saw ... instead of .. */ /* On UNOPs, saw bare parens, e.g. eof(). */ /* On OP_ENTERSUB || OP_NULL, saw a "do". */ + /* On OP_EXISTS, treat av as av, not avhv. */ /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */ /* On OP_ENTERITER, loop var is per-thread */ /* On pushre, re is /\s+/ imp. by split " " */ @@ -160,6 +161,9 @@ typedef U32 PADOFFSET; /* Private for OP_DELETE */ #define OPpSLICE 64 /* Operating on a list of keys */ +/* Private for OP_EXISTS */ +#define OPpEXISTS_SUB 64 /* Checking for &sub, not {} or []. */ + /* Private for OP_SORT, OP_PRTF, OP_SPRINTF, OP_FTTEXT, OP_FTBINARY, */ /* string comparisons, and case changers. */ #define OPpLOCALE 64 /* Use locale */ diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 15b60ba..cd596e2 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -425,6 +425,12 @@ This is rather similar to how the arrow may be omitted from C<$foo[10]->{'foo'}>. Note however, that the arrow is still required for C('bar')>. +=head2 exists() is supported on subroutine names + +The exists() builtin now works on subroutine names. A subroutine +is considered to exist if it has been declared (even if implicitly). +See L for examples. + =head2 exists() and delete() are supported on array elements The exists() and delete() builtins now work on simple arrays as well. @@ -1115,6 +1121,10 @@ File test operators. Verify operations that access pad objects (lexicals and temporaries). +=item op/exists_sub + +Verify C operations. + =back =head1 Modules and Pragmata @@ -1593,6 +1603,11 @@ definition ahead of the call to get proper prototype checking. Alternatively, if you are certain that you're calling the function correctly, you may put an ampersand before the name to avoid the warning. See L. +=item %s argument is not a subroutine name + +(F) The argument to exists() for C must be a subroutine +name, and not a subroutine call. C will generate this error. + =item %s package attribute may clash with future reserved word: %s (W) A lowercase attribute name was used that had a package-specific handler. diff --git a/pod/perldiag.pod b/pod/perldiag.pod index f82cd25..752605d 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -159,6 +159,11 @@ or a hash or array slice, such as: @foo[$bar, $baz, $xyzzy] @{$ref->[12]}{"susie", "queue"} +=item %s argument is not a subroutine name + +(F) The argument to exists() for C must be a subroutine +name, and not a subroutine call. C will generate this error. + =item %s did not return a true value (F) A required (or used) file must return a true value to indicate that diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index d730b43..dbefd85 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -1422,8 +1422,16 @@ element is not autovivified if it doesn't exist. A hash or array element can be true only if it's defined, and defined if it exists, but the reverse doesn't necessarily hold true. +Given an expression that specifies the name of a subroutine, +returns true if the specified subroutine has ever been declared, even +if it is undefined. Mentioning a subroutine name for exists or defined +does not count as declaring it. + + print "Exists\n" if exists &subroutine; + print "Defined\n" if defined &subroutine; + Note that the EXPR can be arbitrarily complicated as long as the final -operation is a hash or array key lookup: +operation is a hash or array key lookup or subroutine name: if (exists $ref->{A}->{B}->{$key}) { } if (exists $hash{A}{B}{$key}) { } @@ -1431,6 +1439,8 @@ operation is a hash or array key lookup: if (exists $ref->{A}->{B}->[$ix]) { } if (exists $hash{A}{B}[$ix]) { } + if (exists &{$ref->{A}{B}{$key}}) { } + Although the deepest nested array or hash will not spring into existence just because its existence was tested, any intervening ones will. Thus C<$ref-E{"A"}> and C<$ref-E{"A"}-E{"B"}> will spring @@ -1448,6 +1458,12 @@ release. See L for specifics on how exists() acts when used on a pseudo-hash. +Use of a subroutine call, rather than a subroutine name, as an argument +to exists() is an error. + + exists ⊂ # OK + exists &sub(); # Error + =item exit EXPR Evaluates EXPR and exits immediately with that value. Example: diff --git a/pp.c b/pp.c index c387433..267da99 100644 --- a/pp.c +++ b/pp.c @@ -2701,8 +2701,22 @@ PP(pp_delete) PP(pp_exists) { djSP; - SV *tmpsv = POPs; - HV *hv = (HV*)POPs; + SV *tmpsv; + HV *hv; + + if (PL_op->op_private & OPpEXISTS_SUB) { + GV *gv; + CV *cv; + SV *sv = POPs; + cv = sv_2cv(sv, &hv, &gv, FALSE); + if (cv) + RETPUSHYES; + if (gv && isGV(gv) && GvCV(gv) && !GvCVGEN(gv)) + RETPUSHYES; + RETPUSHNO; + } + tmpsv = POPs; + hv = (HV*)POPs; if (SvTYPE(hv) == SVt_PVHV) { if (hv_exists_ent(hv, tmpsv, 0)) RETPUSHYES; diff --git a/t/op/exists_sub.t b/t/op/exists_sub.t new file mode 100755 index 0000000..3363dfd --- /dev/null +++ b/t/op/exists_sub.t @@ -0,0 +1,46 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..9\n"; + +sub t1; +sub t2 : locked; +sub t3 (); +sub t4 ($); +sub t5 {1;} +{ + package P1; + sub tmc {1;} + package P2; + @ISA = 'P1'; +} + +print "not " unless exists &t1 && not defined &t1; +print "ok 1\n"; +print "not " unless exists &t2 && not defined &t2; +print "ok 2\n"; +print "not " unless exists &t3 && not defined &t3; +print "ok 3\n"; +print "not " unless exists &t4 && not defined &t4; +print "ok 4\n"; +print "not " unless exists &t5 && defined &t5; +print "ok 5\n"; +P2::->tmc; +print "not " unless not exists &P2::tmc && not defined &P2::tmc; +print "ok 6\n"; +my $ref; +$ref->{A}[0] = \&t4; +print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]}; +print "ok 7\n"; +undef &P1::tmc; +print "not " unless exists &P1::tmc && not defined &P1::tmc; +print "ok 8\n"; +eval 'exists &t5()'; +print "not " unless $@; +print "ok 9\n"; + +exit 0;