diff options
| -rw-r--r-- | embed.fnc | 4 | ||||
| -rw-r--r-- | perl.c | 47 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | toke.c | 24 |
4 files changed, 54 insertions, 26 deletions
@@ -2379,4 +2379,8 @@ Aanop |CLONE_PARAMS *|clone_params_new|NN PerlInterpreter *const from \ |NN PerlInterpreter *const to Anop |void |clone_params_del|NN CLONE_PARAMS *param #endif + +: Used in perl.c and toke.c +op |void |populate_isa |NN const char *name|STRLEN len|... + : ex: set ts=8 sts=4 sw=4 noet: @@ -3893,6 +3893,39 @@ S_nuke_stacks(pTHX) Safefree(PL_savestack); } +void +Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) +{ + GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV); + AV *const isa = GvAVn(gv); + va_list args; + + PERL_ARGS_ASSERT_POPULATE_ISA; + + if(AvFILLp(isa) != -1) + return; + + /* NOTE: No support for tied ISA */ + + va_start(args, len); + do { + const char *const parent = va_arg(args, const char*); + size_t parent_len; + + if (!parent) + break; + parent_len = va_arg(args, size_t); + + /* Arguments are supplied with a trailing :: */ + assert(parent_len > 2); + assert(parent[parent_len - 1] == ':'); + assert(parent[parent_len - 2] == ':'); + av_push(isa, newSVpvn(parent, parent_len - 2)); + (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); + } while (1); + va_end(args); +} + STATIC void S_init_predump_symbols(pTHX) @@ -3900,7 +3933,6 @@ S_init_predump_symbols(pTHX) dVAR; GV *tmpgv; IO *io; - AV *isa; sv_setpvs(get_sv("\"", GV_ADD), " "); PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV)); @@ -3919,14 +3951,11 @@ S_init_predump_symbols(pTHX) so that code that does C<use IO::Handle>; will still work. */ - isa = get_av("IO::File::ISA", GV_ADD | GV_ADDMULTI); - av_push(isa, newSVpvs("IO::Handle")); - av_push(isa, newSVpvs("IO::Seekable")); - av_push(isa, newSVpvs("Exporter")); - (void) gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVGV); - (void) gv_fetchpvs("IO::Seekable::", GV_ADD, SVt_PVGV); - (void) gv_fetchpvs("Exporter::", GV_ADD, SVt_PVGV); - + Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), + STR_WITH_LEN("IO::Handle::"), + STR_WITH_LEN("IO::Seekable::"), + STR_WITH_LEN("Exporter::"), + NULL); PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); @@ -2775,6 +2775,11 @@ PERL_CALLCONV OP* Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) assert(o); assert(expr) PERL_CALLCONV void Perl_pop_scope(pTHX); +PERL_CALLCONV void Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_POPULATE_ISA \ + assert(name) + PERL_CALLCONV OP * Perl_pp_aassign(pTHX); PERL_CALLCONV OP * Perl_pp_abs(pTHX); PERL_CALLCONV OP * Perl_pp_accept(pTHX); @@ -6914,23 +6914,13 @@ Perl_yylex(pTHX) UNI(OP_DELETE); case KEY_dbmopen: - { - /* NOTE: No support for tied ISA */ - AV *isa = get_av("AnyDBM_File::ISA", GV_ADD | GV_ADDMULTI); - - if(AvFILLp(isa) == -1) { - av_push(isa, newSVpvs("NDBM_File")); - gv_stashpvs("NDBM_File", GV_ADD); - av_push(isa, newSVpvs("DB_File")); - gv_stashpvs("DB_File", GV_ADD); - av_push(isa, newSVpvs("GDBM_File")); - gv_stashpvs("GDBM_File", GV_ADD); - av_push(isa, newSVpvs("SDBM_File")); - gv_stashpvs("SDBM_File", GV_ADD); - av_push(isa, newSVpvs("ODBM_File")); - gv_stashpvs("ODBM_File", GV_ADD); - } - } + Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"), + STR_WITH_LEN("NDBM_File::"), + STR_WITH_LEN("DB_File::"), + STR_WITH_LEN("GDBM_File::"), + STR_WITH_LEN("SDBM_File::"), + STR_WITH_LEN("ODBM_File::"), + NULL); LOP(OP_DBMOPEN,XTERM); case KEY_dbmclose: |