From: Gurusamy Sarathy Date: Wed, 8 Mar 2000 18:04:45 +0000 (+0000) Subject: abstract code for C 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 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 */ @@ -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);