From: Gurusamy Sarathy <gsar@cpan.org>
Date: Wed, 8 Mar 2000 18:04:45 +0000 (+0000)
Subject: abstract code for C<use Foo 1.23 @ary;> into a Perl_load_module()
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e4783991709775389a3fc70c841522b0165cd076;p=p5sagit%2Fp5-mst-13.2.git
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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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);