dslinux/user/perl/ext/attrs Makefile.PL attrs.pm attrs.xs

cayenne dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:49 CET 2006

Update of /cvsroot/dslinux/dslinux/user/perl/ext/attrs
In directory antilope:/tmp/cvs-serv17422/ext/attrs

Added Files:
	Makefile.PL attrs.pm attrs.xs 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: attrs.pm ---
package attrs;
use XSLoader ();

$VERSION = "1.02";

=head1 NAME

attrs - set/get attributes of a subroutine (deprecated)


    sub foo {
        use attrs qw(locked method);

    @a = attrs::get(\&foo);


NOTE: Use of this pragma is deprecated.  Use the syntax

    sub foo : locked method { }

to declare attributes instead.  See also L<attributes>.

This pragma 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<attrs::get> on a subroutine reference or name returns its list
of attribute names. Notice that C<attrs::get> is not exported.
Valid attributes are as follows.

=over 4

=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.



XSLoader::load 'attrs', $VERSION;


--- NEW FILE: attrs.xs ---
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

static cv_flags_t
get_flag(const char *attr)
    if (strnEQ(attr, "method", 6))
	return CVf_METHOD;
    else if (strnEQ(attr, "locked", 6))
	return CVf_LOCKED;
	return 0;

MODULE = attrs		PACKAGE = attrs

	unimport = 1
	int i;
       if (items < 1)
           Perl_croak(aTHX_ "Usage: %s(Class, ...)", GvNAME(CvGV(cv)));
	if (!PL_compcv || !(cv = CvOUTSIDE(PL_compcv)))
	    croak("can't set attributes outside a subroutine scope");
	    Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
			"pragma \"attrs\" is deprecated, "
			"use \"sub NAME : ATTRS\" instead");
	for (i = 1; i < items; i++) {
	    const char * const attr = SvPV_nolen(ST(i));
	    const cv_flags_t flag = get_flag(attr);
	    if (!flag)
		croak("invalid attribute name %s", attr);
	    if (ix)
    		CvFLAGS(cv) &= ~flag;
		CvFLAGS(cv) |= flag;

SV *	sub
	if (SvROK(sub)) {
	    sub = SvRV(sub);
	    if (SvTYPE(sub) != SVt_PVCV)
		sub = Nullsv;
	else {
	    const char * const name = SvPV_nolen(sub);
	    sub = (SV*)perl_get_cv(name, FALSE);
	if (!sub)
	    croak("invalid subroutine reference or name");
	if (CvFLAGS(sub) & CVf_METHOD)
	    XPUSHs(sv_2mortal(newSVpvn("method", 6)));
	if (CvFLAGS(sub) & CVf_LOCKED)
	    XPUSHs(sv_2mortal(newSVpvn("locked", 6)));

--- NEW FILE: Makefile.PL ---
use ExtUtils::MakeMaker;
    NAME	=> 'attrs',
    VERSION_FROM => 'attrs.pm',
    MAN3PODS 	=> {}, 	# Pods will be built by installman.
    XSPROTOARG => '-noprototypes'

More information about the dslinux-commit mailing list