| 1 | /* xsutils.c
|
|---|
| 2 | *
|
|---|
| 3 | * Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
|
|---|
| 4 | * by Larry Wall and others
|
|---|
| 5 | *
|
|---|
| 6 | * You may distribute under the terms of either the GNU General Public
|
|---|
| 7 | * License or the Artistic License, as specified in the README file.
|
|---|
| 8 | *
|
|---|
| 9 | */
|
|---|
| 10 |
|
|---|
| 11 | /*
|
|---|
| 12 | * "Perilous to us all are the devices of an art deeper than we possess
|
|---|
| 13 | * ourselves." --Gandalf
|
|---|
| 14 | */
|
|---|
| 15 |
|
|---|
| 16 |
|
|---|
| 17 | #include "EXTERN.h"
|
|---|
| 18 | #define PERL_IN_XSUTILS_C
|
|---|
| 19 | #include "perl.h"
|
|---|
| 20 |
|
|---|
| 21 | /*
|
|---|
| 22 | * Contributed by Spider Boardman ([email protected]).
|
|---|
| 23 | */
|
|---|
| 24 |
|
|---|
| 25 | /* package attributes; */
|
|---|
| 26 | PERL_XS_EXPORT_C void XS_attributes__warn_reserved(pTHX_ CV *cv);
|
|---|
| 27 | PERL_XS_EXPORT_C void XS_attributes_reftype(pTHX_ CV *cv);
|
|---|
| 28 | PERL_XS_EXPORT_C void XS_attributes__modify_attrs(pTHX_ CV *cv);
|
|---|
| 29 | PERL_XS_EXPORT_C void XS_attributes__guess_stash(pTHX_ CV *cv);
|
|---|
| 30 | PERL_XS_EXPORT_C void XS_attributes__fetch_attrs(pTHX_ CV *cv);
|
|---|
| 31 | PERL_XS_EXPORT_C void XS_attributes_bootstrap(pTHX_ CV *cv);
|
|---|
| 32 |
|
|---|
| 33 |
|
|---|
| 34 | /*
|
|---|
| 35 | * Note that only ${pkg}::bootstrap definitions should go here.
|
|---|
| 36 | * This helps keep down the start-up time, which is especially
|
|---|
| 37 | * relevant for users who don't invoke any features which are
|
|---|
| 38 | * (partially) implemented here.
|
|---|
| 39 | *
|
|---|
| 40 | * The various bootstrap definitions can take care of doing
|
|---|
| 41 | * package-specific newXS() calls. Since the layout of the
|
|---|
| 42 | * bundled *.pm files is in a version-specific directory,
|
|---|
| 43 | * version checks in these bootstrap calls are optional.
|
|---|
| 44 | */
|
|---|
| 45 |
|
|---|
| 46 | void
|
|---|
| 47 | Perl_boot_core_xsutils(pTHX)
|
|---|
| 48 | {
|
|---|
| 49 | const char file[] = __FILE__;
|
|---|
| 50 |
|
|---|
| 51 | newXS("attributes::bootstrap", XS_attributes_bootstrap, (char *)file);
|
|---|
| 52 | }
|
|---|
| 53 |
|
|---|
| 54 | #include "XSUB.h"
|
|---|
| 55 |
|
|---|
| 56 | static int
|
|---|
| 57 | modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
|
|---|
| 58 | {
|
|---|
| 59 | SV *attr;
|
|---|
| 60 | int nret;
|
|---|
| 61 |
|
|---|
| 62 | for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
|
|---|
| 63 | STRLEN len;
|
|---|
| 64 | const char *name = SvPV_const(attr, len);
|
|---|
| 65 | const bool negated = (*name == '-');
|
|---|
| 66 |
|
|---|
| 67 | if (negated) {
|
|---|
| 68 | name++;
|
|---|
| 69 | len--;
|
|---|
| 70 | }
|
|---|
| 71 | switch (SvTYPE(sv)) {
|
|---|
| 72 | case SVt_PVCV:
|
|---|
| 73 | switch ((int)len) {
|
|---|
| 74 | #ifdef CVf_ASSERTION
|
|---|
| 75 | case 9:
|
|---|
| 76 | if (memEQ(name, "assertion", 9)) {
|
|---|
| 77 | if (negated)
|
|---|
| 78 | CvFLAGS((CV*)sv) &= ~CVf_ASSERTION;
|
|---|
| 79 | else
|
|---|
| 80 | CvFLAGS((CV*)sv) |= CVf_ASSERTION;
|
|---|
| 81 | continue;
|
|---|
| 82 | }
|
|---|
| 83 | break;
|
|---|
| 84 | #endif
|
|---|
| 85 | case 6:
|
|---|
| 86 | switch (name[3]) {
|
|---|
| 87 | case 'l':
|
|---|
| 88 | #ifdef CVf_LVALUE
|
|---|
| 89 | if (memEQ(name, "lvalue", 6)) {
|
|---|
| 90 | if (negated)
|
|---|
| 91 | CvFLAGS((CV*)sv) &= ~CVf_LVALUE;
|
|---|
| 92 | else
|
|---|
| 93 | CvFLAGS((CV*)sv) |= CVf_LVALUE;
|
|---|
| 94 | continue;
|
|---|
| 95 | }
|
|---|
| 96 | break;
|
|---|
| 97 | case 'k':
|
|---|
| 98 | #endif /* defined CVf_LVALUE */
|
|---|
| 99 | if (memEQ(name, "locked", 6)) {
|
|---|
| 100 | if (negated)
|
|---|
| 101 | CvFLAGS((CV*)sv) &= ~CVf_LOCKED;
|
|---|
| 102 | else
|
|---|
| 103 | CvFLAGS((CV*)sv) |= CVf_LOCKED;
|
|---|
| 104 | continue;
|
|---|
| 105 | }
|
|---|
|
|---|
