1 files changed, 59 insertions, 0 deletions
diff --git a/contrib/perl5/ext/attrs/attrs.xs b/contrib/perl5/ext/attrs/attrs.xs
new file mode 100644
index 0000000..da952d5
--- /dev/null
+++ b/contrib/perl5/ext/attrs/attrs.xs
@@ -0,0 +1,59 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+static cv_flags_t
+get_flag(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 (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
+	    croak("can't set attributes outside a subroutine scope");
+	for (i = 1; i < items; i++) {
+	    char *attr = SvPV(ST(i), PL_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, PL_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)));
+