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

[cayenne]

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)

=head1 SYNOPSIS

    sub foo {
        use attrs qw(locked method);
        ...
    }

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

=head1 DESCRIPTION

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.

=back

=cut

XSLoader::load 'attrs', $VERSION;

1;

--- NEW FILE: attrs.xs ---
#define PERL_NO_GET_CONTEXT
#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;
    else
	return 0;
}

MODULE = attrs		PACKAGE = attrs

void
import(...)
    ALIAS:
	unimport = 1
    PREINIT:
	int i;
    PPCODE:
       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");
	if (ckWARN(WARN_DEPRECATED))
	    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;
	    else
		CvFLAGS(cv) |= flag;
	}

void
get(sub)
SV *	sub
    PPCODE:
	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;
WriteMakefile(
    NAME	=> 'attrs',
    VERSION_FROM => 'attrs.pm',
    MAN3PODS 	=> {}, 	# Pods will be built by installman.
    XSPROTOARG => '-noprototypes'
);