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

p4raw-id: //depot/perl@4827

8 files changed, 113 insertions, 5 deletions

diff --git a/MANIFEST b/MANIFEST
index f6e96a7d8b..0e6282f5a7 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 4baf03b313..386e9de0bf 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 c69d897239..ae37f03c9f 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 15b60ba0db..cd596e2044 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<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 f82cd25409..752605d2f8 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<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 d730b43e47..dbefd85ee4 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<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 c3874337e3..267da99747 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 0000000000..3363dfd837
--- /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;