Rewrite synchronisation of subs/methods and add attrs

extension for specifying 'locked' and 'method' attributes.

p4raw-id: //depot/perl@56

3 files changed, 122 insertions, 0 deletions

diff --git a/ext/attrs/Makefile.PL b/ext/attrs/Makefile.PL
new file mode 100644
index 0000000000..c421757615
--- /dev/null
+++ b/ext/attrs/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+    NAME	=> 'attrs',
+    VERSION_FROM => 'attrs.pm',
+    MAN3PODS 	=> ' ', 	# Pods will be built by installman.
+    XSPROTOARG => '-noprototypes'
+);
diff --git a/ext/attrs/attrs.pm b/ext/attrs/attrs.pm
new file mode 100644
index 0000000000..fe2bf356e4
--- /dev/null
+++ b/ext/attrs/attrs.pm
@@ -0,0 +1,55 @@
+package attrs;
+require DynaLoader;
+use vars '@ISA';
+@ISA = 'DynaLoader';
+
+use vars qw($VERSION);
+$VERSION = "1.0";
+
+=head1 NAME
+
+attrs - set/get attributes of a subroutine
+
+=head1 SYNOPSIS
+
+    sub foo {
+        use attrs qw(locked method);
+        ...
+    }
+
+    @a = attrs::get(\&foo);
+
+=head1 DESCRIPTION
+
+This module lets you set and get attributes for subroutines.
+Setting attributes takes place at compile time; trying to set
+invalid attribute names causes a compile-time error. Calling
+C<attr::get> on a subroutine reference or name returns its list
+of attribute names. Notice that C<attr::get> is not exported.
+Valid attributes are as follows.
+
+=over
+
+=item method
+
+Indicates that the invoking subroutine is a method.
+
+=item locked
+
+Setting this attribute is only meaningful when the subroutine or
+method is to be called by multiple threads. When set on a method
+subroutine (i.e. one marked with the B<method> attribute above),
+perl ensures that any invocation of it implicitly locks its first
+argument before execution. When set on a non-method subroutine,
+perl ensures that a lock is taken on the subroutine itself before
+execution. The semantics of the lock are exactly those of one
+explicitly taken with the C<lock> operator immediately after the
+subroutine is entered.
+
+=back
+
+=cut
+
+bootstrap attrs $VERSION;
+
+1;
diff --git a/ext/attrs/attrs.xs b/ext/attrs/attrs.xs
new file mode 100644
index 0000000000..f34ac850ea
--- /dev/null
+++ b/ext/attrs/attrs.xs
@@ -0,0 +1,60 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static cv_flags_t
+get_flag(attr)
+char *attr;
+{
+    if (strnEQ(attr, "method", 6))
+	return CVf_METHOD;
+    else if (strnEQ(attr, "locked", 6))
+	return CVf_LOCKED;
+    else
+	return 0;
+}
+
+MODULE = attrs		PACKAGE = attrs
+
+void
+import(class, ...)
+char *	class
+    ALIAS:
+	unimport = 1
+    PREINIT:
+	int i;
+	CV *cv;
+    PPCODE:
+	if (!compcv || !(cv = CvOUTSIDE(compcv)))
+	    croak("can't set attributes outside a subroutine scope");
+	for (i = 1; i < items; i++) {
+	    char *attr = SvPV(ST(i), na);
+	    cv_flags_t flag = get_flag(attr);
+	    if (!flag)
+		croak("invalid attribute name %s", attr);
+	    if (ix)
+    		CvFLAGS(cv) &= ~flag;
+	    else
+		CvFLAGS(cv) |= flag;
+	}
+
+void
+get(sub)
+SV *	sub
+    PPCODE:
+	if (SvROK(sub)) {
+	    sub = SvRV(sub);
+	    if (SvTYPE(sub) != SVt_PVCV)
+		sub = Nullsv;
+	}
+	else {
+	    char *name = SvPV(sub, na);
+	    sub = (SV*)perl_get_cv(name, FALSE);
+	}
+	if (!sub)
+	    croak("invalid subroutine reference or name");
+	if (CvFLAGS(sub) & CVf_METHOD)
+	    XPUSHs(sv_2mortal(newSVpv("method", 0)));
+	if (CvFLAGS(sub) & CVf_LOCKED)
+	    XPUSHs(sv_2mortal(newSVpv("locked", 0)));
+