In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/74e8ce349633219f5a1aba2c2aaa959675e24299?hp=d9159685e05b3d86d58992e4879989b659852d4a>
- Log ----------------------------------------------------------------- commit 74e8ce349633219f5a1aba2c2aaa959675e24299 Author: Nicholas Clark <[email protected]> Date: Sat Oct 9 20:34:29 2010 +0100 Create populate_isa() to de-duplicate logic to populate @ISA. Previously yylex() was conditionally populating @AnyDBM_File::ISA (if it was not set, and the token dbmopen was seen), and init_predump_symbols() was populating @IO::File::ISA (unconditionally, but this is so early that nothing previously could have set it). This refactoring eliminates code duplication. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 4 ++++ perl.c | 47 ++++++++++++++++++++++++++++++++++++++--------- proto.h | 5 +++++ toke.c | 24 +++++++----------------- 4 files changed, 54 insertions(+), 26 deletions(-) diff --git a/embed.fnc b/embed.fnc index ec6c8ce..45b2419 100644 --- a/embed.fnc +++ b/embed.fnc @@ -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: diff --git a/perl.c b/perl.c index db950d5..b524084 100644 --- a/perl.c +++ b/perl.c @@ -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); diff --git a/proto.h b/proto.h index 5e40a62..076cac6 100644 --- a/proto.h +++ b/proto.h @@ -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); diff --git a/toke.c b/toke.c index 55b1970..832b9e9 100644 --- a/toke.c +++ b/toke.c @@ -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: -- Perl5 Master Repository
