support for C<exists &func> (from Spider Boardman)

p4raw-id: //depot/perl@4827

diff --git a/MANIFEST b/MANIFEST
index f6e96a7..0e6282f 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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<foo(10)->('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<perlfunc/exists> 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<exists &sub> 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<perlsub>.
 
+=item %s argument is not a subroutine name
+
+(F) The argument to exists() for C<exists &sub> must be a subroutine
+name, and not a subroutine call.  C<exists &sub()> 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 (file)
--- 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<exists &sub> must be a subroutine
+name, and not a subroutine call.  C<exists &sub()> 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 (file)
--- 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<gt>{"A"}> and C<$ref-E<gt>{"A"}-E<gt>{"B"}> will spring
@@ -1448,6 +1458,12 @@ release.
 See L<perlref/"Pseudo-hashes"> 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 &sub;       # 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 (file)
--- 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 (executable)
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;