xsub attributes

Message-ID: <Pine.LNX.4.10.10006141456050.340-100000@mojo.covalent.net>

p4raw-id: //depot/cfgperl@6273

diff --git a/embed.h b/embed.h
index f419792..f5ce052 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -71,6 +71,7 @@
 #define append_elem            Perl_append_elem
 #define append_list            Perl_append_list
 #define apply                  Perl_apply
+#define apply_attrs_string     Perl_apply_attrs_string
 #define avhv_delete_ent                Perl_avhv_delete_ent
 #define avhv_exists_ent                Perl_avhv_exists_ent
 #define avhv_fetch_ent         Perl_avhv_fetch_ent
@@ -892,6 +893,7 @@
 #define cv_dump                        S_cv_dump
 #define cv_clone2              S_cv_clone2
 #define scalar_mod_type                S_scalar_mod_type
+#define method_2entersub       S_method_2entersub
 #define my_kid                 S_my_kid
 #define dup_attrlist           S_dup_attrlist
 #define apply_attrs            S_apply_attrs
@@ -1090,6 +1092,7 @@
 #define scan_trans             S_scan_trans
 #define scan_word              S_scan_word
 #define skipspace              S_skipspace
+#define swallow_bom            S_swallow_bom
 #define checkcomma             S_checkcomma
 #define force_ident            S_force_ident
 #define incline                        S_incline
@@ -1542,6 +1545,7 @@
 #define append_elem(a,b,c)     Perl_append_elem(aTHX_ a,b,c)
 #define append_list(a,b,c)     Perl_append_list(aTHX_ a,b,c)
 #define apply(a,b,c)           Perl_apply(aTHX_ a,b,c)
+#define apply_attrs_string(a,b,c,d)    Perl_apply_attrs_string(aTHX_ a,b,c,d)
 #define avhv_delete_ent(a,b,c,d)       Perl_avhv_delete_ent(aTHX_ a,b,c,d)
 #define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c)
 #define avhv_fetch_ent(a,b,c,d)        Perl_avhv_fetch_ent(aTHX_ a,b,c,d)
@@ -2334,6 +2338,7 @@
 #define cv_dump(a)             S_cv_dump(aTHX_ a)
 #define cv_clone2(a,b)         S_cv_clone2(aTHX_ a,b)
 #define scalar_mod_type(a,b)   S_scalar_mod_type(aTHX_ a,b)
+#define method_2entersub(a,b,c)        S_method_2entersub(aTHX_ a,b,c)
 #define my_kid(a,b)            S_my_kid(aTHX_ a,b)
 #define dup_attrlist(a)                S_dup_attrlist(aTHX_ a)
 #define apply_attrs(a,b,c)     S_apply_attrs(aTHX_ a,b,c)
@@ -2531,6 +2536,7 @@
 #define scan_trans(a)          S_scan_trans(aTHX_ a)
 #define scan_word(a,b,c,d,e)   S_scan_word(aTHX_ a,b,c,d,e)
 #define skipspace(a)           S_skipspace(aTHX_ a)
+#define swallow_bom(a)         S_swallow_bom(aTHX_ a)
 #define checkcomma(a,b,c)      S_checkcomma(aTHX_ a,b,c)
 #define force_ident(a,b)       S_force_ident(aTHX_ a,b)
 #define incline(a)             S_incline(aTHX_ a)
@@ -2993,6 +2999,8 @@
 #define append_list            Perl_append_list
 #define Perl_apply             CPerlObj::Perl_apply
 #define apply                  Perl_apply
+#define Perl_apply_attrs_string        CPerlObj::Perl_apply_attrs_string
+#define apply_attrs_string     Perl_apply_attrs_string
 #define Perl_avhv_delete_ent   CPerlObj::Perl_avhv_delete_ent
 #define avhv_delete_ent                Perl_avhv_delete_ent
 #define Perl_avhv_exists_ent   CPerlObj::Perl_avhv_exists_ent
@@ -4561,6 +4569,8 @@
 #define cv_clone2              S_cv_clone2
 #define S_scalar_mod_type      CPerlObj::S_scalar_mod_type
 #define scalar_mod_type                S_scalar_mod_type
+#define S_method_2entersub     CPerlObj::S_method_2entersub
+#define method_2entersub       S_method_2entersub
 #define S_my_kid               CPerlObj::S_my_kid
 #define my_kid                 S_my_kid
 #define S_dup_attrlist         CPerlObj::S_dup_attrlist
@@ -4921,6 +4931,8 @@
 #define scan_word              S_scan_word
 #define S_skipspace            CPerlObj::S_skipspace
 #define skipspace              S_skipspace
+#define S_swallow_bom          CPerlObj::S_swallow_bom
+#define swallow_bom            S_swallow_bom
 #define S_checkcomma           CPerlObj::S_checkcomma
 #define checkcomma             S_checkcomma
 #define S_force_ident          CPerlObj::S_force_ident

diff --git a/embed.pl b/embed.pl
index b7cad10..536dd43 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1375,6 +1375,7 @@ Ap        |bool   |Gv_AMupdate    |HV* stash
 p      |OP*    |append_elem    |I32 optype|OP* head|OP* tail
 p      |OP*    |append_list    |I32 optype|LISTOP* first|LISTOP* last
 p      |I32    |apply          |I32 type|SV** mark|SV** sp
+Afp    |void   |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len
 Ap     |SV*    |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
 Ap     |bool   |avhv_exists_ent|AV *ar|SV* keysv|U32 hash
 Ap     |SV**   |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash

diff --git a/global.sym b/global.sym
index 1f03877..4990e03 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -21,6 +21,7 @@ Perl_get_context
 Perl_set_context
 Perl_amagic_call
 Perl_Gv_AMupdate
+Perl_apply_attrs_string
 Perl_avhv_delete_ent
 Perl_avhv_exists_ent
 Perl_avhv_fetch_ent

diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index eb085f5..1e9ff45 100755 (executable)
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -288,7 +288,7 @@ $END = "!End!\n\n";         # "impossible" keyword (multiple newline)
 # Match an XS keyword
 $BLOCK_re= '\s*(' . join('|', qw(
        REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
-       CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+       CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
        SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL
        )) . "|$END)\\s*:";
 
@@ -573,6 +573,15 @@ sub GetAliases
         if $line ;
 }
 
+sub ATTRS_handler ()
+{
+    for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
+       next unless /\S/;
+       TrimWhitespace($_) ;
+        push @Attributes, $_;
+    }
+}
+
 sub ALIAS_handler ()
 {
     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
@@ -1056,7 +1065,7 @@ while (fetch_para()) {
        last;
     }
     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
-    %XsubAliases = %XsubAliasValues = %Interfaces = ();
+    %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
     $DoSetMagic = 1;
 
     $orig_args =~ s/\\\s*/ /g;         # process line continuations
@@ -1227,7 +1236,7 @@ EOF
         $gotRETVAL = 0;
 
        INPUT_handler() ;
-       process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|PROTOTYPE|SCOPE") ;
+       process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE") ;
 
        print Q<<"EOF" if $ScopeThisXSUB;
 #   ENTER;
@@ -1269,7 +1278,7 @@ EOF
                }
                print $deferred;
 
-        process_keyword("INIT|ALIAS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
+        process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
 
                if (check_keyword("PPCODE")) {
                        print_section();
@@ -1313,7 +1322,7 @@ EOF
        # $wantRETVAL set if 'RETVAL =' autogenerated
        ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
        undef %outargs ;
-       process_keyword("POSTCALL|OUTPUT|ALIAS|PROTOTYPE"); 
+       process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE"); 
 
        # all OUTPUT done, so now push the return value on the stack
        if ($gotRETVAL && $RETVAL_code) {
@@ -1358,7 +1367,7 @@ EOF
        generate_output($var_types{$_}, $num++, $_, 0, 1) for @in_out;
 
        # do cleanup
-       process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
+       process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE") ;
 
        print Q<<"EOF" if $ScopeThisXSUB;
 #   ]]
@@ -1448,6 +1457,12 @@ EOF
 EOF
         }
     } 
+    elsif (@Attributes) {
+           push(@InitFileCode, Q<<"EOF");
+#        cv = newXS(\"$pname\", XS_$Full_func_name, file);
+#        apply_attrs_string("$Package", cv, "@Attributes", 0);
+EOF
+    }
     elsif ($interface) {
        while ( ($name, $value) = each %Interfaces) {
            $name = "$Package\::$name" unless $name =~ /::/;

diff --git a/objXSUB.h b/objXSUB.h
index e30258b..245b75c 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -35,6 +35,10 @@
 #define Perl_Gv_AMupdate       pPerl->Perl_Gv_AMupdate
 #undef  Gv_AMupdate
 #define Gv_AMupdate            Perl_Gv_AMupdate
+#undef  Perl_apply_attrs_string
+#define Perl_apply_attrs_string        pPerl->Perl_apply_attrs_string
+#undef  apply_attrs_string
+#define apply_attrs_string     Perl_apply_attrs_string
 #undef  Perl_avhv_delete_ent
 #define Perl_avhv_delete_ent   pPerl->Perl_avhv_delete_ent
 #undef  avhv_delete_ent

diff --git a/op.c b/op.c
index af7ca34..97f8d29 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1851,6 +1851,37 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
     LEAVE;
 }
 
+void
+Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
+                        char *attrstr, STRLEN len)
+{
+    OP *attrs = Nullop;
+
+    if (!len) {
+        len = strlen(attrstr);
+    }
+
+    while (len) {
+        for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
+        if (len) {
+            char *sstr = attrstr;
+            for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
+            attrs = append_elem(OP_LIST, attrs,
+                                newSVOP(OP_CONST, 0,
+                                        newSVpvn(sstr, attrstr-sstr)));
+        }
+    }
+
+    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+                     newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                     Nullsv, prepend_elem(OP_LIST,
+                                 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
+                                 prepend_elem(OP_LIST,
+                                              newSVOP(OP_CONST, 0,
+                                                      newRV((SV*)cv)),
+                                               attrs)));
+}
+
 STATIC OP *
 S_my_kid(pTHX_ OP *o, OP *attrs)
 {

diff --git a/perlapi.c b/perlapi.c
index 29428d5..51323c0 100755 (executable)
--- a/perlapi.c
+++ b/perlapi.c
@@ -85,6 +85,13 @@ Perl_Gv_AMupdate(pTHXo_ HV* stash)
     return ((CPerlObj*)pPerl)->Perl_Gv_AMupdate(stash);
 }
 
+#undef  Perl_apply_attrs_string
+void
+Perl_apply_attrs_string(pTHXo_ char *stashpv, CV *cv, char *attrstr, STRLEN len)
+{
+    ((CPerlObj*)pPerl)->Perl_apply_attrs_string(stashpv, cv, attrstr, len);
+}
+
 #undef  Perl_avhv_delete_ent
 SV*
 Perl_avhv_delete_ent(pTHXo_ AV *ar, SV* keysv, I32 flags, U32 hash)

diff --git a/proto.h b/proto.h
index 0746b11..f251d20 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -61,6 +61,11 @@ PERL_CALLCONV bool   Perl_Gv_AMupdate(pTHX_ HV* stash);
 PERL_CALLCONV OP*      Perl_append_elem(pTHX_ I32 optype, OP* head, OP* tail);
 PERL_CALLCONV OP*      Perl_append_list(pTHX_ I32 optype, LISTOP* first, LISTOP* last);
 PERL_CALLCONV I32      Perl_apply(pTHX_ I32 type, SV** mark, SV** sp);
+PERL_CALLCONV void     Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len)
+#ifdef CHECK_FORMAT
+ __attribute__((format(printf,pTHX_3,pTHX_4)))
+#endif
+;
 PERL_CALLCONV SV*      Perl_avhv_delete_ent(pTHX_ AV *ar, SV* keysv, I32 flags, U32 hash);
 PERL_CALLCONV bool     Perl_avhv_exists_ent(pTHX_ AV *ar, SV* keysv, U32 hash);
 PERL_CALLCONV SV**     Perl_avhv_fetch_ent(pTHX_ AV *ar, SV* keysv, I32 lval, U32 hash);