abstract code for C<use Foo 1.23 @ary;> into a Perl_load_module()

API function

p4raw-id: //depot/perl@5619

diff --git a/embed.h b/embed.h
index 3b3a836..b68b1e9 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -116,6 +116,7 @@
 #define die_nocontext          Perl_die_nocontext
 #define deb_nocontext          Perl_deb_nocontext
 #define form_nocontext         Perl_form_nocontext
+#define load_module_nocontext  Perl_load_module_nocontext
 #define mess_nocontext         Perl_mess_nocontext
 #define warn_nocontext         Perl_warn_nocontext
 #define warner_nocontext       Perl_warner_nocontext
@@ -322,6 +323,8 @@
 #define linklist               Perl_linklist
 #define list                   Perl_list
 #define listkids               Perl_listkids
+#define load_module            Perl_load_module
+#define vload_module           Perl_vload_module
 #define localize               Perl_localize
 #define looks_like_number      Perl_looks_like_number
 #define magic_clearenv         Perl_magic_clearenv
@@ -1762,6 +1765,7 @@
 #define linklist(a)            Perl_linklist(aTHX_ a)
 #define list(a)                        Perl_list(aTHX_ a)
 #define listkids(a)            Perl_listkids(aTHX_ a)
+#define vload_module(a,b,c,d)  Perl_vload_module(aTHX_ a,b,c,d)
 #define localize(a,b)          Perl_localize(aTHX_ a,b)
 #define looks_like_number(a)   Perl_looks_like_number(aTHX_ a)
 #define magic_clearenv(a,b)    Perl_magic_clearenv(aTHX_ a,b)
@@ -3055,6 +3059,8 @@
 #define deb_nocontext          Perl_deb_nocontext
 #define Perl_form_nocontext    CPerlObj::Perl_form_nocontext
 #define form_nocontext         Perl_form_nocontext
+#define Perl_load_module_nocontext     CPerlObj::Perl_load_module_nocontext
+#define load_module_nocontext  Perl_load_module_nocontext
 #define Perl_mess_nocontext    CPerlObj::Perl_mess_nocontext
 #define mess_nocontext         Perl_mess_nocontext
 #define Perl_warn_nocontext    CPerlObj::Perl_warn_nocontext
@@ -3456,6 +3462,10 @@
 #define list                   Perl_list
 #define Perl_listkids          CPerlObj::Perl_listkids
 #define listkids               Perl_listkids
+#define Perl_load_module       CPerlObj::Perl_load_module
+#define load_module            Perl_load_module
+#define Perl_vload_module      CPerlObj::Perl_vload_module
+#define vload_module           Perl_vload_module
 #define Perl_localize          CPerlObj::Perl_localize
 #define localize               Perl_localize
 #define Perl_looks_like_number CPerlObj::Perl_looks_like_number
@@ -5751,6 +5761,7 @@
 #  define deb                          Perl_deb_nocontext
 #  define die                          Perl_die_nocontext
 #  define form                         Perl_form_nocontext
+#  define load_module                  Perl_load_module_nocontext
 #  define mess                         Perl_mess_nocontext
 #  define newSVpvf                     Perl_newSVpvf_nocontext
 #  define sv_catpvf                    Perl_sv_catpvf_nocontext
@@ -5769,6 +5780,7 @@
 #  define Perl_die_nocontext           Perl_die
 #  define Perl_deb_nocontext           Perl_deb
 #  define Perl_form_nocontext          Perl_form
+#  define Perl_load_module_nocontext   Perl_load_module
 #  define Perl_mess_nocontext          Perl_mess
 #  define Perl_newSVpvf_nocontext      Perl_newSVpvf
 #  define Perl_sv_catpvf_nocontext     Perl_sv_catpvf

diff --git a/embed.pl b/embed.pl
index 2783805..fc13957 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -500,6 +500,7 @@ print EM <<'END';
 #  define deb                          Perl_deb_nocontext
 #  define die                          Perl_die_nocontext
 #  define form                         Perl_form_nocontext
+#  define load_module                  Perl_load_module_nocontext
 #  define mess                         Perl_mess_nocontext
 #  define newSVpvf                     Perl_newSVpvf_nocontext
 #  define sv_catpvf                    Perl_sv_catpvf_nocontext
@@ -518,6 +519,7 @@ print EM <<'END';
 #  define Perl_die_nocontext           Perl_die
 #  define Perl_deb_nocontext           Perl_deb
 #  define Perl_form_nocontext          Perl_form
+#  define Perl_load_module_nocontext   Perl_load_module
 #  define Perl_mess_nocontext          Perl_mess
 #  define Perl_newSVpvf_nocontext      Perl_newSVpvf
 #  define Perl_sv_catpvf_nocontext     Perl_sv_catpvf
@@ -931,6 +933,7 @@ my %vfuncs = qw(
     Perl_warner                        Perl_vwarner
     Perl_die                   Perl_vdie
     Perl_form                  Perl_vform
+    Perl_load_module           Perl_vload_module
     Perl_mess                  Perl_vmess
     Perl_deb                   Perl_vdeb
     Perl_newSVpvf              Perl_vnewSVpvf
@@ -1399,6 +1402,7 @@ Afnrp     |void   |croak_nocontext|const char* pat|...
 Afnp   |OP*    |die_nocontext  |const char* pat|...
 Afnp   |void   |deb_nocontext  |const char* pat|...
 Afnp   |char*  |form_nocontext |const char* pat|...
+Afnp   |void   |load_module_nocontext|U32 flags|SV* name|SV* ver|...
 Afnp   |SV*    |mess_nocontext |const char* pat|...
 Afnp   |void   |warn_nocontext |const char* pat|...
 Afnp   |void   |warner_nocontext|U32 err|const char* pat|...
@@ -1616,6 +1620,8 @@ p |void   |lex_start      |SV* line
 p      |OP*    |linklist       |OP* o
 p      |OP*    |list           |OP* o
 p      |OP*    |listkids       |OP* o
+Afp    |void   |load_module|U32 flags|SV* name|SV* ver|...
+Ap     |void   |vload_module|U32 flags|SV* name|SV* ver|va_list* args
 p      |OP*    |localize       |OP* arg|I32 lexical
 Apd    |I32    |looks_like_number|SV* sv
 p      |int    |magic_clearenv |SV* sv|MAGIC* mg

diff --git a/global.sym b/global.sym
index e34d5c0..10b5303 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -58,6 +58,7 @@ Perl_croak_nocontext
 Perl_die_nocontext
 Perl_deb_nocontext
 Perl_form_nocontext
+Perl_load_module_nocontext
 Perl_mess_nocontext
 Perl_warn_nocontext
 Perl_warner_nocontext
@@ -195,6 +196,8 @@ Perl_is_utf8_punct
 Perl_is_utf8_xdigit
 Perl_is_utf8_mark
 Perl_leave_scope
+Perl_load_module
+Perl_vload_module
 Perl_looks_like_number
 Perl_markstack_grow
 Perl_mess

diff --git a/objXSUB.h b/objXSUB.h
index bc17e87..569065c 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -188,6 +188,10 @@
 #define Perl_form_nocontext    pPerl->Perl_form_nocontext
 #undef  form_nocontext
 #define form_nocontext         Perl_form_nocontext
+#undef  Perl_load_module_nocontext
+#define Perl_load_module_nocontext     pPerl->Perl_load_module_nocontext
+#undef  load_module_nocontext
+#define load_module_nocontext  Perl_load_module_nocontext
 #undef  Perl_mess_nocontext
 #define Perl_mess_nocontext    pPerl->Perl_mess_nocontext
 #undef  mess_nocontext
@@ -747,6 +751,14 @@
 #define Perl_leave_scope       pPerl->Perl_leave_scope
 #undef  leave_scope
 #define leave_scope            Perl_leave_scope
+#undef  Perl_load_module
+#define Perl_load_module       pPerl->Perl_load_module
+#undef  load_module
+#define load_module            Perl_load_module
+#undef  Perl_vload_module
+#define Perl_vload_module      pPerl->Perl_vload_module
+#undef  vload_module
+#define vload_module           Perl_vload_module
 #undef  Perl_looks_like_number
 #define Perl_looks_like_number pPerl->Perl_looks_like_number
 #undef  looks_like_number

diff --git a/op.c b/op.c
index d6a16db..bc07904 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1821,7 +1821,6 @@ S_dup_attrlist(pTHX_ OP *o)
 STATIC void
 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
 {
-    OP *modname;       /* for 'use' */
     SV *stashsv;
 
     /* fake up C<use attributes $pkg,$rv,@attrs> */
@@ -1831,19 +1830,18 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
        stashsv = newSVpv(HvNAME(stash), 0);
     else
        stashsv = &PL_sv_no;
+
 #define ATTRSMODULE "attributes"
-    modname = newSVOP(OP_CONST, 0,
-                     newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
-    modname->op_private |= OPpCONST_BARE;
-    /* that flag is required to make 'use' work right */
-    utilize(1, start_subparse(FALSE, 0),
-           Nullop, /* version */
-           modname,
-           prepend_elem(OP_LIST,
-                        newSVOP(OP_CONST, 0, stashsv),
-                        prepend_elem(OP_LIST,
-                                     newSVOP(OP_CONST, 0, newRV(target)),
-                                     dup_attrlist(attrs))));
+
+    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+                    newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                    Nullsv,
+                    prepend_elem(OP_LIST,
+                                 newSVOP(OP_CONST, 0, stashsv),
+                                 prepend_elem(OP_LIST,
+                                              newSVOP(OP_CONST, 0,
+                                                      newRV(target)),
+                                              dup_attrlist(attrs))));
     LEAVE;
 }
 
@@ -3175,6 +3173,58 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
     PL_expect = XSTATE;
 }
 
+void
+Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
+{
+    va_list args;
+    va_start(args, ver);
+    vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+
+#ifdef PERL_IMPLICIT_CONTEXT
+void
+Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
+{
+    dTHX;
+    va_list args;
+    va_start(args, ver);
+    vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+#endif
+
+void
+Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
+{
+    OP *modname, *veop, *imop;
+
+    modname = newSVOP(OP_CONST, 0, name);
+    modname->op_private |= OPpCONST_BARE;
+    if (ver) {
+       veop = newSVOP(OP_CONST, 0, ver);
+    }
+    else
+       veop = Nullop;
+    if (flags & PERL_LOADMOD_NOIMPORT) {
+       imop = sawparens(newNULLLIST());
+    }
+    else if (flags & PERL_LOADMOD_IMPORT_OPS) {
+       imop = va_arg(*args, OP*);
+    }
+    else {
+       SV *sv;
+       imop = Nullop;
+       sv = va_arg(*args, SV*);
+       while (sv) {
+           imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
+           sv = va_arg(*args, SV*);
+       }
+    }
+    utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+           veop, modname, imop);
+}
+
 OP *
 Perl_dofile(pTHX_ OP *term)
 {
@@ -5510,11 +5560,10 @@ Perl_ck_glob(pTHX_ OP *o)
 #if !defined(PERL_EXTERNAL_GLOB)
     /* XXX this can be tightened up and made more failsafe. */
     if (!gv) {
-       OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10));
-       modname->op_private |= OPpCONST_BARE;
        ENTER;
-       utilize(1, start_subparse(FALSE, 0), Nullop, modname,
-               newSVOP(OP_CONST, 0, newSVpvn(":globally", 9)));
+       Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
+                        /* null-terminated import list */
+                        newSVpvn(":globally", 9), Nullsv);
        gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
        LEAVE;
     }

diff --git a/op.h b/op.h
index da03aa4..2cc39d2 100644 (file)
--- a/op.h
+++ b/op.h
@@ -418,3 +418,8 @@ struct loop {
 #  define OpREFCNT_inc(o)              (o)
 #  define OpREFCNT_dec(o)              0
 #endif
+
+/* flags used by Perl_load_module() */
+#define PERL_LOADMOD_DENY              0x1
+#define PERL_LOADMOD_NOIMPORT          0x2
+#define PERL_LOADMOD_IMPORT_OPS                0x4

diff --git a/perlapi.c b/perlapi.c
index 1d619ef..cfb4dc8 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -371,6 +371,17 @@ Perl_form_nocontext(const char* pat, ...)
 
 }
 
+#undef  Perl_load_module_nocontext
+void
+Perl_load_module_nocontext(U32 flags, SV* name, SV* ver, ...)
+{
+    dTHXo;
+    va_list args;
+    va_start(args, ver);
+    ((CPerlObj*)pPerl)->Perl_vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+
 #undef  Perl_mess_nocontext
 SV*
 Perl_mess_nocontext(const char* pat, ...)
@@ -1389,6 +1400,23 @@ Perl_leave_scope(pTHXo_ I32 base)
     ((CPerlObj*)pPerl)->Perl_leave_scope(base);
 }
 
+#undef  Perl_load_module
+void
+Perl_load_module(pTHXo_ U32 flags, SV* name, SV* ver, ...)
+{
+    va_list args;
+    va_start(args, ver);
+    ((CPerlObj*)pPerl)->Perl_vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+
+#undef  Perl_vload_module
+void
+Perl_vload_module(pTHXo_ U32 flags, SV* name, SV* ver, va_list* args)
+{
+    ((CPerlObj*)pPerl)->Perl_vload_module(flags, name, ver, args);
+}
+
 #undef  Perl_looks_like_number
 I32
 Perl_looks_like_number(pTHXo_ SV* sv)

diff --git a/proto.h b/proto.h
index 83adf58..e338205 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -129,6 +129,11 @@ PERL_CALLCONV char*        Perl_form_nocontext(const char* pat, ...)
  __attribute__((format(printf,1,2)))
 #endif
 ;
+PERL_CALLCONV void     Perl_load_module_nocontext(U32 flags, SV* name, SV* ver, ...)
+#ifdef CHECK_FORMAT
+ __attribute__((format(printf,3,4)))
+#endif
+;
 PERL_CALLCONV SV*      Perl_mess_nocontext(const char* pat, ...)
 #ifdef CHECK_FORMAT
  __attribute__((format(printf,1,2)))
@@ -383,6 +388,12 @@ PERL_CALLCONV void Perl_lex_start(pTHX_ SV* line);
 PERL_CALLCONV OP*      Perl_linklist(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_list(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_listkids(pTHX_ OP* o);
+PERL_CALLCONV void     Perl_load_module(pTHX_ U32 flags, SV* name, SV* ver, ...)
+#ifdef CHECK_FORMAT
+ __attribute__((format(printf,pTHX_3,pTHX_4)))
+#endif
+;
+PERL_CALLCONV void     Perl_vload_module(pTHX_ U32 flags, SV* name, SV* ver, va_list* args);
 PERL_CALLCONV OP*      Perl_localize(pTHX_ OP* arg, I32 lexical);
 PERL_CALLCONV I32      Perl_looks_like_number(pTHX_ SV* sv);
 PERL_CALLCONV int      Perl_magic_clearenv(pTHX_ SV* sv, MAGIC* mg);